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 % h7  !  Zh=      "   #497<8@rptzzxx4qusyyww6rvtzzxx7rvtzzxxJ6;@su{{y4rtzzx6su{{y7su{{y'qz \ 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 00000000..fe5a05ce Binary files /dev/null and b/internal/gabriel/Results/Lyric/File-Servers.TEdit differ diff --git a/internal/gabriel/Results/Lyric/IO-BYTE.BENCHMARKS b/internal/gabriel/Results/Lyric/IO-BYTE.BENCHMARKS new file mode 100644 index 00000000..7a9d6ab4 --- /dev/null +++ b/internal/gabriel/Results/Lyric/IO-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) ***** fprint Benchmark *** FPrint Iteration 0 of fprint Timing for : fprint Elapsed time = 20.009 seconds SWAP time = 0.492 seconds reclaim time = 0.658 seconds net compute time = 18.859 seconds Page faults = 17 Storage allocated: 197 fixp, 2 floatp, 536 listp, 10 vmempagep, 2 stream, 1 bitmap, 48 oned-array, 1 pilotbbt, 1 \displaydata, 1 pathname, 1 window, 50 pagegroup, 1 filedescriptor, 1 fw-ofd Iteration 1 of fprint Timing for : fprint Elapsed time = 19.592 seconds SWAP time = 0.050 seconds reclaim time = 0.473 seconds net compute time = 19.069 seconds Page faults = 1 Storage allocated: 197 fixp, 2 floatp, 595 listp, 10 vmempagep, 2 stream, 1 bitmap, 72 oned-array, 1 pilotbbt, 1 \displaydata, 2 pathname, 1 window, 50 pagegroup, 1 filedescriptor, 1 fw-ofd ***** fread Benchmark *** FRead Iteration 0 of fread Timing for : fread Elapsed time = 11.755 seconds SWAP time = 0.053 seconds reclaim time = 0.708 seconds net compute time = 10.994 seconds Page faults = 1 Storage allocated: 120 fixp, 6249 listp, 4 vmempagep, 1 stream, 82 oned-array, 2 pathname, 37 pagegroup, 1 filedescriptor Iteration 1 of fread Timing for : fread Elapsed time = 11.747 seconds SWAP time = 0.043 seconds reclaim time = 0.712 seconds net compute time = 10.992 seconds Page faults = 1 Storage allocated: 120 fixp, 6249 listp, 4 vmempagep, 1 stream, 82 oned-array, 2 pathname, 37 pagegroup, 1 filedescriptor ***** tprint Benchmark *** TPrint Iteration 0 of tprint ((((((|678E| |567D| |567D| |456D| |456D| |345C|) |234B| (|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3) wxy2 ((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0) qrs9 (((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7) klm6 ((((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6) ijk5 ((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4) efg3 (((((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6) ijk5 ((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4 ((((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4) efg3) cde2 (((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4 ((((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4) efg3 ((((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4 (((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5 ((uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6 (qrs9 opq8 opq8 mno7 mno7 klm6) ijk5) ghi4) efg3) cde2) abc1) Timing for : tprint Elapsed time = 40.547 seconds reclaim time = 0.200 seconds net compute time = 40.347 seconds Storage allocated: 58 fixp, 1 floatp, 77 listp, 2 etherpacket, 24 pagegroup Iteration 1 of tprint ((((((|678E| |567D| |567D| |456D| |456D| |345C|) |234B| (|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3) wxy2 ((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0) qrs9 (((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7) klm6 ((((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6) ijk5 ((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4) efg3 (((((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6) ijk5 ((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4 ((((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4) efg3) cde2 (((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4 ((((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4) efg3 ((((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4 (((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5 ((uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6 (qrs9 opq8 opq8 mno7 mno7 klm6) ijk5) ghi4) efg3) cde2) abc1) Timing for : tprint Elapsed time = 40.924 seconds SWAP time = 0.123 seconds reclaim time = 0.381 seconds net compute time = 40.420 seconds Page faults = 4 Storage allocated: 57 fixp, 1 floatp, 80 listp, 3 etherpacket, 24 pagegroup \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/IO-PAV.BENCHMARKS b/internal/gabriel/Results/Lyric/IO-PAV.BENCHMARKS new file mode 100644 index 00000000..38aa4957 --- /dev/null +++ b/internal/gabriel/Results/Lyric/IO-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) ***** fprint Benchmark *** FPrint Iteration 0 of fprint Timing for : fprint Elapsed time = 20.146 seconds SWAP time = 0.060 seconds reclaim time = 0.953 seconds net compute time = 19.133 seconds Page faults = 1 Storage allocated: 211 fixp, 2 floatp, 594 listp, 11 vmempagep, 2 stream, 1 bitmap, 72 oned-array, 1 pilotbbt, 1 \displaydata, 2 pathname, 1 window, 51 pagegroup, 1 filedescriptor, 1 \btreebuf, 1 fw-ofd Iteration 1 of fprint Timing for : fprint Elapsed time = 19.655 seconds reclaim time = 0.534 seconds net compute time = 19.121 seconds Storage allocated: 219 fixp, 3 floatp, 552 listp, 10 vmempagep, 1 stream, 72 oned-array, 2 pathname, 50 pagegroup, 1 filedescriptor ***** fread Benchmark *** FRead Iteration 0 of fread Timing for : fread Elapsed time = 12.444 seconds SWAP time = 0.048 seconds reclaim time = 1.287 seconds net compute time = 11.109 seconds Page faults = 1 Storage allocated: 115 fixp, 6254 listp, 4 vmempagep, 1 stream, 82 oned-array, 2 pathname, 37 pagegroup, 1 filedescriptor Iteration 1 of fread Timing for : fread Elapsed time = 12.146 seconds reclaim time = 1.132 seconds net compute time = 11.014 seconds Storage allocated: 115 fixp, 6254 listp, 4 vmempagep, 1 stream, 82 oned-array, 2 pathname, 37 pagegroup, 1 filedescriptor ***** tprint Benchmark *** TPrint Iteration 0 of tprint ((((((|678E| |567D| |567D| |456D| |456D| |345C|) |234B| (|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3) wxy2 ((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0) qrs9 (((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7) klm6 ((((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6) ijk5 ((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4) efg3 (((((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6) ijk5 ((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4 ((((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4) efg3) cde2 (((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4 ((((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4) efg3 ((((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4 (((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5 ((uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6 (qrs9 opq8 opq8 mno7 mno7 klm6) ijk5) ghi4) efg3) cde2) abc1) Timing for : tprint Elapsed time = 40.548 seconds reclaim time = 0.226 seconds net compute time = 40.322 seconds Storage allocated: 59 fixp, 1 floatp, 78 listp, 24 pagegroup Iteration 1 of tprint ((((((|678E| |567D| |567D| |456D| |456D| |345C|) |234B| (|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3) wxy2 ((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0) qrs9 (((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7) klm6 ((((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6) ijk5 ((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4) efg3 (((((|567D| |456D| |456D| |345C| |345C| |234B|) |123A| (|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2) uvw1 ((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9) opq8 (((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6) ijk5 ((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4 ((((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4) efg3) cde2 (((((|456D| |345C| |345C| |234B| |234B| |123A|) xyz3 (|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1) stu0 ((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8) mno7 (((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5) ghi4 ((((|345C| |234B| |234B| |123A| |123A| xyz3) wxy2 (|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0) qrs9 ((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7) klm6 (((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4) efg3 ((((|234B| |123A| |123A| xyz3 xyz3 wxy2) uvw1 (|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9) opq8 ((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6) ijk5 (((|123A| xyz3 xyz3 wxy2 wxy2 uvw1) stu0 (xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8) mno7 ((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5) ghi4 (((xyz3 wxy2 wxy2 uvw1 uvw1 stu0) qrs9 (wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7) klm6 ((wxy2 uvw1 uvw1 stu0 stu0 qrs9) opq8 (uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6) ijk5 ((uvw1 stu0 stu0 qrs9 qrs9 opq8) mno7 (stu0 qrs9 qrs9 opq8 opq8 mno7) klm6 (qrs9 opq8 opq8 mno7 mno7 klm6) ijk5) ghi4) efg3) cde2) abc1) Timing for : tprint Elapsed time = 40.516 seconds reclaim time = 0.207 seconds net compute time = 40.309 seconds Storage allocated: 57 fixp, 1 floatp, 76 listp, 1 etherpacket, 24 pagegroup \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/RESULTS.TEDIT b/internal/gabriel/Results/Lyric/RESULTS.TEDIT new file mode 100644 index 00000000..eba29b13 Binary files /dev/null and b/internal/gabriel/Results/Lyric/RESULTS.TEDIT differ diff --git a/internal/gabriel/Results/Lyric/SUMMARY-5-27.TEDIT b/internal/gabriel/Results/Lyric/SUMMARY-5-27.TEDIT new file mode 100644 index 00000000..b9212f34 Binary files /dev/null and b/internal/gabriel/Results/Lyric/SUMMARY-5-27.TEDIT differ diff --git a/internal/gabriel/Results/Lyric/TAK-BYTE.BENCHMARKS b/internal/gabriel/Results/Lyric/TAK-BYTE.BENCHMARKS new file mode 100644 index 00000000..a8e14d6f --- /dev/null +++ b/internal/gabriel/Results/Lyric/TAK-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) ***** ctak Benchmark *** CTak Iteration 0 of ctak Timing for : ctak Elapsed time = 96.821 seconds net compute time = 96.821 seconds Iteration 1 of ctak Timing for : ctak Elapsed time = 97.117 seconds net compute time = 97.117 seconds ***** stak Benchmark *** STak Iteration 0 of stak Timing for : stak Elapsed time = 4.589 seconds net compute time = 4.589 seconds Iteration 1 of stak Timing for : stak Elapsed time = 4.589 seconds net compute time = 4.589 seconds ***** tak Benchmark *** Tak Iteration 0 of tak Timing for : tak Elapsed time = 1.630 seconds net compute time = 1.630 seconds Iteration 1 of tak Timing for : tak Elapsed time = 1.630 seconds net compute time = 1.630 seconds ***** takl Benchmark *** TakL Iteration 0 of takl Timing for : takl Elapsed time = 13.366 seconds net compute time = 13.366 seconds Iteration 1 of takl Timing for : takl Elapsed time = 13.365 seconds net compute time = 13.365 seconds ***** takr Benchmark *** TakR Iteration 0 of takr Timing for : takr Elapsed time = 1.737 seconds net compute time = 1.737 seconds Iteration 1 of takr Timing for : takr Elapsed time = 1.736 seconds net compute time = 1.736 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/TAK-PAV.BENCHMARKS b/internal/gabriel/Results/Lyric/TAK-PAV.BENCHMARKS new file mode 100644 index 00000000..ae1f20f7 --- /dev/null +++ b/internal/gabriel/Results/Lyric/TAK-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) ***** ctak Benchmark *** CTak Iteration 0 of ctak Timing for : ctak Elapsed time = 55.938 seconds SWAP time = 0.038 seconds reclaim time = 6.588 seconds net compute time = 49.312 seconds Page faults = 10 Storage allocated: 47707 listp Iteration 1 of ctak Timing for : ctak Elapsed time = 55.667 seconds reclaim time = 6.366 seconds net compute time = 49.301 seconds Storage allocated: 47707 listp ***** stak Benchmark *** STak Iteration 0 of stak Timing for : stak Elapsed time = 12.693 seconds net compute time = 12.693 seconds Iteration 1 of stak Timing for : stak Elapsed time = 12.693 seconds net compute time = 12.693 seconds ***** tak Benchmark *** Tak Iteration 0 of tak Timing for : tak Elapsed time = 1.789 seconds net compute time = 1.789 seconds Iteration 1 of tak Timing for : tak Elapsed time = 1.796 seconds net compute time = 1.796 seconds ***** takl Benchmark *** TakL Iteration 0 of takl Timing for : takl Elapsed time = 15.524 seconds net compute time = 15.524 seconds Iteration 1 of takl Timing for : takl Elapsed time = 15.525 seconds net compute time = 15.525 seconds ***** takr Benchmark *** TakR Iteration 0 of takr Timing for : takr Elapsed time = 1.838 seconds net compute time = 1.838 seconds Iteration 1 of takr Timing for : takr Elapsed time = 1.839 seconds net compute time = 1.839 seconds \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/all-byte.benchmarks b/internal/gabriel/Results/Lyric/all-byte.benchmarks new file mode 100644 index 00000000..1e304391 --- /dev/null +++ b/internal/gabriel/Results/Lyric/all-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) ***** PUZZLE Benchmark *** Puzzle Iteration 0 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 56.590 seconds net compute time = 56.601 seconds Storage allocated: 10 LISTP, 4 ONED-ARRAY Iteration 1 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 56.596 seconds net compute time = 56.596 seconds Storage allocated: 10 LISTP, 4 ONED-ARRAY ***** TRIANG Benchmark *** Triang Iteration 0 of TRIANG Timing for : TRIANG Elapsed time = 743.318 seconds reclaim time = 0.609 seconds net compute time = 742.709 seconds Page faults = 72 Storage allocated: 11626 LISTP Iteration 1 of TRIANG Timing for : TRIANG Elapsed time = 742.397 seconds reclaim time = 0.607 seconds net compute time = 741.790 seconds Storage allocated: 11626 LISTP ***** FFT Benchmark *** FFT Iteration 0 of FFT Timing for : FFT Elapsed time = 195.709 seconds SWAP time = 0.242 seconds reclaim time = 107.710 seconds net compute time = 87.757 seconds Page faults = 34 Storage allocated: 942640 FLOATP Iteration 1 of FFT Timing for : FFT Elapsed time = 195.582 seconds reclaim time = 108.111 seconds net compute time = 87.471 seconds Storage allocated: 942640 FLOATP ***** DIV2-2 Benchmark *** Div2, Recursive Iteration 0 of DIV2-2 Timing for : DIV2-2 Elapsed time = 34.659 seconds reclaim time = 21.244 seconds net compute time = 13.415 seconds Storage allocated: 120000 LISTP Iteration 1 of DIV2-2 Timing for : DIV2-2 Elapsed time = 34.718 seconds reclaim time = 21.051 seconds net compute time = 13.667 seconds Storage allocated: 120000 LISTP ***** DIV2-1 Benchmark *** Div2, Iterative Iteration 0 of DIV2-1 Timing for : DIV2-1 Elapsed time = 29.626 seconds reclaim time = 20.808 seconds net compute time = 8.818 seconds Storage allocated: 120000 LISTP Iteration 1 of DIV2-1 Timing for : DIV2-1 Elapsed time = 29.138 seconds reclaim time = 20.199 seconds net compute time = 8.939 seconds Storage allocated: 120000 LISTP ***** DESTRU Benchmark *** Destruct Iteration 0 of DESTRU Timing for : DESTRU Elapsed time = 21.310 seconds reclaim time = 5.924 seconds net compute time = 15.386 seconds Storage allocated: 43105 LISTP Iteration 1 of DESTRU Timing for : DESTRU Elapsed time = 21.368 seconds reclaim time = 5.989 seconds net compute time = 15.379 seconds Storage allocated: 43105 LISTP ***** DERIV Benchmark *** Deriv Iteration 0 of DERIV Timing for : DERIV Elapsed time = 65.391 seconds reclaim time = 43.602 seconds net compute time = 21.789 seconds Storage allocated: 245000 LISTP Iteration 1 of DERIV Timing for : DERIV Elapsed time = 64.697 seconds reclaim time = 43.130 seconds net compute time = 21.567 seconds Storage allocated: 245000 LISTP ***** DDERIV Benchmark *** DDeriv Evaluating setup for DDERIV Iteration 0 of DDERIV Timing for : DDERIV Elapsed time = 77.017 seconds reclaim time = 48.874 seconds net compute time = 28.143 seconds Storage allocated: 260000 LISTP Iteration 1 of DDERIV Timing for : DDERIV Elapsed time = 77.273 seconds reclaim time = 49.080 seconds net compute time = 28.193 seconds Storage allocated: 260000 LISTP ***** BOYER Benchmark *** Boyer Evaluating setup for BOYER Iteration 0 of BOYER Timing for : BOYER Elapsed time = 147.026 seconds SWAP time = 0.036 seconds reclaim time = 39.347 seconds net compute time = 107.643 seconds Page faults = 469 Storage allocated: 226464 LISTP, 272 COMPILED-CLOSURE Iteration 1 of BOYER Timing for : BOYER Elapsed time = 143.743 seconds reclaim time = 40.167 seconds net compute time = 103.576 seconds Page faults = 6 Storage allocated: 226464 LISTP, 272 COMPILED-CLOSURE ***** BROWSE* Benchmark *** Browse Iteration 0 of BROWSE* Timing for : BROWSE* Elapsed time = 384.124 seconds SWAP time = 0.050 seconds reclaim time = 114.650 seconds net compute time = 269.424 seconds Page faults = 71 Storage allocated: 488945 LISTP, 2202 ONED-ARRAY Iteration 1 of BROWSE* Timing for : BROWSE* Elapsed time = 409.821 seconds reclaim time = 123.117 seconds net compute time = 286.704 seconds Page faults = 66 Storage allocated: 488945 LISTP, 2202 ONED-ARRAY ***** BROWSE Benchmark *** Browse Iteration 0 of BROWSE Timing for : BROWSE Elapsed time = 912.229 seconds SWAP time = 0.052 seconds reclaim time = 277.775 seconds net compute time = 634.402 seconds Page faults = 59 Storage allocated: 488945 LISTP, 229002 ONED-ARRAY Iteration 1 of BROWSE Timing for : BROWSE Elapsed time = 919.685 seconds reclaim time = 284.812 seconds net compute time = 634.873 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-byte.benchmarks b/internal/gabriel/Results/Lyric/arefy-byte.benchmarks new file mode 100644 index 00000000..9300bc8c --- /dev/null +++ b/internal/gabriel/Results/Lyric/arefy-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) ***** puzzle Benchmark *** Puzzle Iteration 0 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 47.531 seconds SWAP time = 1.478 seconds net compute time = 46.053 seconds Page faults = 59 Storage allocated: 10 listp, 4 oned-array Iteration 1 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 46.034 seconds net compute time = 46.034 seconds Storage allocated: 10 listp, 4 oned-array ***** triang Benchmark *** Triang Iteration 0 of triang Timing for : triang Elapsed time = 745.004 seconds SWAP time = 0.009 seconds reclaim time = 0.799 seconds net compute time = 744.196 seconds Page faults = 1 Storage allocated: 11626 listp Iteration 1 of triang Timing for : triang Elapsed time = 744.929 seconds reclaim time = 0.802 seconds net compute time = 744.127 seconds Storage allocated: 11626 listp ***** fft Benchmark *** FFT Iteration 0 of fft Timing for : fft Elapsed time = 212.251 seconds SWAP time = 0.690 seconds reclaim time = 122.149 seconds net compute time = 89.412 seconds Page faults = 53 Storage allocated: 942640 floatp Iteration 1 of fft Timing for : fft Elapsed time = 210.515 seconds reclaim time = 121.406 seconds net compute time = 89.109 seconds Storage allocated: 942640 floatp \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/byte-5-24.benchmarks b/internal/gabriel/Results/Lyric/byte-5-24.benchmarks new file mode 100644 index 00000000..47374591 --- /dev/null +++ b/internal/gabriel/Results/Lyric/byte-5-24.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.542 seconds net compute time = 1.542 seconds Iteration 1 of tak Timing for : tak Elapsed time = 1.542 seconds net compute time = 1.542 seconds ***** takr Benchmark *** TakR Iteration 0 of takr Timing for : takr Elapsed time = 1.615 seconds net compute time = 1.615 seconds Iteration 1 of takr Timing for : takr Elapsed time = 1.625 seconds net compute time = 1.625 seconds ***** takl Benchmark *** TakL Iteration 0 of takl Timing for : takl Elapsed time = 12.616 seconds net compute time = 12.616 seconds Iteration 1 of takl Timing for : takl Elapsed time = 12.607 seconds net compute time = 12.607 seconds ***** stak Benchmark *** STak Iteration 0 of stak Timing for : stak Elapsed time = 4.200 seconds net compute time = 4.200 seconds Iteration 1 of stak Timing for : stak Elapsed time = 4.201 seconds net compute time = 4.201 seconds ***** ctak Benchmark *** CTak Iteration 0 of ctak Timing for : ctak Elapsed time = 51.508 seconds net compute time = 51.508 seconds Iteration 1 of ctak Timing for : ctak Elapsed time = 51.516 seconds net compute time = 51.516 seconds ***** div2-2 Benchmark *** Div2, Recursive Iteration 0 of div2-2 Timing for : div2-2 Elapsed time = 37.165 seconds reclaim time = 22.406 seconds net compute time = 14.759 seconds Storage allocated: 120000 listp Iteration 1 of div2-2 Timing for : div2-2 Elapsed time = 38.029 seconds reclaim time = 23.105 seconds net compute time = 14.924 seconds Storage allocated: 120000 listp ***** div2-1 Benchmark *** Div2, Iterative Iteration 0 of div2-1 Timing for : div2-1 Elapsed time = 33.897 seconds reclaim time = 22.271 seconds net compute time = 11.626 seconds Storage allocated: 120000 listp Iteration 1 of div2-1 Timing for : div2-1 Elapsed time = 33.616 seconds reclaim time = 22.146 seconds net compute time = 11.470 seconds Storage allocated: 120000 listp ***** destru Benchmark *** Destruct Iteration 0 of destru Timing for : destru Elapsed time = 21.738 seconds reclaim time = 6.288 seconds net compute time = 15.450 seconds Storage allocated: 43105 listp Iteration 1 of destru Timing for : destru Elapsed time = 21.909 seconds reclaim time = 6.424 seconds net compute time = 15.485 seconds Storage allocated: 43105 listp ***** deriv Benchmark *** Deriv Iteration 0 of deriv Timing for : deriv Elapsed time = 73.590 seconds reclaim time = 45.848 seconds net compute time = 27.742 seconds Storage allocated: 245000 listp Iteration 1 of deriv Timing for : deriv Elapsed time = 71.742 seconds reclaim time = 44.862 seconds net compute time = 26.880 seconds Storage allocated: 245000 listp ***** dderiv Benchmark *** DDeriv Evaluating setup for dderiv Iteration 0 of dderiv Timing for : dderiv Elapsed time = 87.394 seconds reclaim time = 52.176 seconds net compute time = 35.218 seconds Storage allocated: 260000 listp Iteration 1 of dderiv Timing for : dderiv Elapsed time = 86.842 seconds reclaim time = 51.964 seconds net compute time = 34.878 seconds Storage allocated: 260000 listp ***** boyer Benchmark *** Boyer Evaluating setup for boyer Iteration 0 of boyer Timing for : boyer Elapsed time = 132.341 seconds reclaim time = 36.743 seconds net compute time = 95.598 seconds Page faults = 84 Storage allocated: 226464 listp, 272 compiled-closure Iteration 1 of boyer Timing for : boyer Elapsed time = 132.809 seconds reclaim time = 37.172 seconds net compute time = 95.637 seconds Page faults = 2 Storage allocated: 226464 listp, 272 compiled-closure ***** browse Benchmark *** Browse Iteration 0 of browse Timing for : browse Elapsed time = 682.320 seconds reclaim time = 313.476 seconds net compute time = 368.844 seconds Page faults = 64 Storage allocated: 488945 listp, 229002 oned-array Iteration 1 of browse Timing for : browse Elapsed time = 688.178 seconds reclaim time = 316.493 seconds net compute time = 371.685 seconds Page faults = 48 Storage allocated: 488945 listp, 229002 oned-array ***** browse* Benchmark *** Browse Iteration 0 of browse* Timing for : browse* Elapsed time = 330.890 seconds reclaim time = 130.621 seconds net compute time = 200.269 seconds Page faults = 53 Storage allocated: 488945 listp, 2202 oned-array Iteration 1 of browse* Timing for : browse* Elapsed time = 331.777 seconds reclaim time = 131.059 seconds net compute time = 200.718 seconds Page faults = 50 Storage allocated: 488945 listp, 2202 oned-array ***** triang Benchmark *** Triang Iteration 0 of triang Timing for : triang Elapsed time = 705.730 seconds reclaim time = 0.425 seconds net compute time = 705.305 seconds Storage allocated: 11626 listp Iteration 1 of triang Timing for : triang Elapsed time = 705.706 seconds reclaim time = 0.412 seconds net compute time = 705.294 seconds Storage allocated: 11626 listp ***** puzzle Benchmark *** Puzzle Iteration 0 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 43.563 seconds net compute time = 43.563 seconds Storage allocated: 10 listp, 4 oned-array Iteration 1 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 43.570 seconds net compute time = 43.570 seconds Storage allocated: 10 listp, 4 oned-array ***** fft Benchmark *** FFT Iteration 0 of fft Timing for : fft Elapsed time = 170.840 seconds reclaim time = 95.205 seconds net compute time = 75.635 seconds Storage allocated: 942640 floatp Iteration 1 of fft Timing for : fft Elapsed time = 170.828 seconds reclaim time = 95.273 seconds net compute time = 75.555 seconds Storage allocated: 942640 floatp ***** fprint Benchmark *** FPrint Iteration 0 of fprint Timing for : fprint Elapsed time = 12.330 seconds SWAP time = 0.604 seconds reclaim time = 0.329 seconds net compute time = 11.397 seconds Page faults = 4 Storage allocated: 64 fixp, 548 listp, 1 vmempagep, 2 stream, 1 bitmap, 68 oned-array, 2 process, 1 pilotbbt, 1 \displaydata, 1 pathname, 1 window, 49 pagegroup, 1 filedescriptor, 1 fw-ofd Iteration 1 of fprint Timing for : fprint Elapsed time = 12.257 seconds reclaim time = 0.501 seconds net compute time = 11.756 seconds Storage allocated: 64 fixp, 582 listp, 1 vmempagep, 2 stream, 1 bitmap, 89 oned-array, 3 etherpacket, 1 pilotbbt, 1 \displaydata, 2 pathname, 1 window, 48 pagegroup, 1 filedescriptor, 1 fw-ofd ***** fread Benchmark *** FRead Iteration 0 of fread Timing for : fread Elapsed time = 10.613 seconds reclaim time = 0.631 seconds net compute time = 9.982 seconds Storage allocated: 23 fixp, 6240 listp, 1 vmempagep, 1 stream, 79 oned-array, 2 pathname, 37 pagegroup, 1 filedescriptor Iteration 1 of fread Timing for : fread Elapsed time = 10.509 seconds reclaim time = 0.625 seconds net compute time = 9.884 seconds Storage allocated: 23 fixp, 6240 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.605 seconds reclaim time = 0.153 seconds net compute time = 28.452 seconds Storage allocated: 11 fixp, 79 listp, 24 pagegroup Iteration 1 of tprint Timing for : tprint Elapsed time = 28.894 seconds reclaim time = 0.277 seconds net compute time = 28.617 seconds Storage allocated: 17 fixp, 148 listp, 1 etherpacket, 27 pagegroup ***** traverse* Benchmark *** Traverse, Traverse Evaluating setup for traverse* Iteration 0 of traverse* Timing for : traverse* Elapsed time = 143.090 seconds net compute time = 143.090 seconds Iteration 1 of traverse* Timing for : traverse* Elapsed time = 143.089 seconds net compute time = 143.089 seconds Evaluating after function for traverse* ***** traverse-init* Benchmark *** Traverse, Initialize Iteration 0 of traverse-init* Timing for : traverse-init* Elapsed time = 115.618 seconds reclaim time = 32.918 seconds net compute time = 82.700 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 = 82.951 seconds reclaim time = 1.367 seconds net compute time = 81.584 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.212 seconds net compute time = 0.212 seconds Storage allocated: 448 floatp, 966 listp Iteration 1 of frpoly5r3 Timing for : frpoly5r3 Elapsed time = 0.213 seconds net compute time = 0.213 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.742 seconds SWAP time = 0.189 seconds reclaim time = 4.119 seconds net compute time = 8.434 seconds Page faults = 6 Storage allocated: 1684 fixp, 15346 listp, 1190 bignum Iteration 1 of frpoly5r2 Timing for : frpoly5r2 Elapsed time = 12.562 seconds reclaim time = 4.171 seconds net compute time = 8.391 seconds 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.164 seconds net compute time = 0.164 seconds Storage allocated: 966 listp Iteration 1 of frpoly5r Timing for : frpoly5r Elapsed time = 0.177 seconds net compute time = 0.177 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.019 seconds net compute time = 0.019 seconds Storage allocated: 33 floatp, 102 listp Iteration 1 of frpoly2r3 Timing for : frpoly2r3 Elapsed time = 0.024 seconds net compute time = 0.024 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.276 seconds net compute time = 0.276 seconds Storage allocated: 48 fixp, 654 listp, 74 bignum Iteration 1 of frpoly2r2 Timing for : frpoly2r2 Elapsed time = 0.278 seconds net compute time = 0.278 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.019 seconds net compute time = 0.019 seconds Storage allocated: 102 listp Iteration 1 of frpoly2r Timing for : frpoly2r Elapsed time = 0.013 seconds net compute time = 0.013 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 = 31.362 seconds reclaim time = 13.763 seconds net compute time = 17.599 seconds Storage allocated: 53297 floatp, 48892 listp Iteration 1 of frpoly15r3 Timing for : frpoly15r3 Elapsed time = 31.065 seconds SWAP time = 0.071 seconds reclaim time = 13.439 seconds net compute time = 17.555 seconds Page faults = 3 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 = 7371.437 seconds SWAP time = 0.136 seconds reclaim time = 2371.725 seconds net compute time = 4999.576 seconds Page faults = 13 Storage allocated: 1049024 fixp, 7404396 listp, 129648 bignum Iteration 1 of frpoly15r2 Timing for : frpoly15r2 Elapsed time = 7436.748 seconds SWAP time = 0.078 seconds reclaim time = 2397.182 seconds net compute time = 5039.488 seconds Page faults = 1 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 = 24.774 seconds reclaim time = 11.028 seconds net compute time = 13.746 seconds Page faults = 12 Storage allocated: 31789 fixp, 48892 listp Iteration 1 of frpoly15r Timing for : frpoly15r Elapsed time = 24.171 seconds reclaim time = 10.672 seconds net compute time = 13.499 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 = 3.844 seconds reclaim time = 1.480 seconds net compute time = 2.364 seconds Storage allocated: 6393 floatp, 9236 listp Iteration 1 of frpoly10r3 Timing for : frpoly10r3 Elapsed time = 3.796 seconds reclaim time = 1.454 seconds net compute time = 2.342 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 = 399.255 seconds reclaim time = 129.259 seconds net compute time = 269.996 seconds Storage allocated: 55634 fixp, 443694 listp, 17227 bignum Iteration 1 of frpoly10r2 Timing for : frpoly10r2 Elapsed time = 402.020 seconds reclaim time = 130.051 seconds net compute time = 271.969 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 = 2.794 seconds reclaim time = 1.140 seconds net compute time = 1.654 seconds Storage allocated: 69 fixp, 9236 listp Iteration 1 of frpoly10r Timing for : frpoly10r Elapsed time = 2.608 seconds reclaim time = 0.962 seconds net compute time = 1.646 seconds Storage allocated: 69 fixp, 9236 listp \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/byte-5-26.benchmarks b/internal/gabriel/Results/Lyric/byte-5-26.benchmarks new file mode 100644 index 00000000..2e307b14 --- /dev/null +++ b/internal/gabriel/Results/Lyric/byte-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.515 seconds net compute time = 1.537 seconds Iteration 1 of tak Timing for : tak Elapsed time = 1.539 seconds net compute time = 1.539 seconds ***** takr Benchmark *** TakR Iteration 0 of takr Timing for : takr Elapsed time = 1.621 seconds net compute time = 1.621 seconds Iteration 1 of takr Timing for : takr Elapsed time = 1.621 seconds net compute time = 1.621 seconds ***** takl Benchmark *** TakL Iteration 0 of takl Timing for : takl Elapsed time = 12.629 seconds net compute time = 12.629 seconds Iteration 1 of takl Timing for : takl Elapsed time = 12.630 seconds net compute time = 12.630 seconds ***** stak Benchmark *** STak Iteration 0 of stak Timing for : stak Elapsed time = 4.209 seconds net compute time = 4.209 seconds Iteration 1 of stak Timing for : stak Elapsed time = 4.202 seconds net compute time = 4.202 seconds ***** ctak Benchmark *** CTak Iteration 0 of ctak Timing for : ctak Elapsed time = 51.456 seconds net compute time = 51.456 seconds Iteration 1 of ctak Timing for : ctak Elapsed time = 51.447 seconds net compute time = 51.447 seconds ***** div2-1 Benchmark *** Div2, Iterative Iteration 0 of div2-1 Timing for : div2-1 Elapsed time = 33.479 seconds reclaim time = 22.464 seconds net compute time = 11.015 seconds Page faults = 36 Storage allocated: 120000 listp Iteration 1 of div2-1 Timing for : div2-1 Elapsed time = 33.642 seconds reclaim time = 22.466 seconds net compute time = 11.176 seconds Storage allocated: 120000 listp ***** div2-2 Benchmark *** Div2, Recursive Iteration 0 of div2-2 Timing for : div2-2 Elapsed time = 38.253 seconds reclaim time = 23.845 seconds net compute time = 14.408 seconds Storage allocated: 120000 listp Iteration 1 of div2-2 Timing for : div2-2 Elapsed time = 37.697 seconds reclaim time = 22.986 seconds net compute time = 14.711 seconds Storage allocated: 120000 listp ***** destru Benchmark *** Destruct Iteration 0 of destru Timing for : destru Elapsed time = 21.629 seconds reclaim time = 6.435 seconds net compute time = 15.194 seconds Storage allocated: 43105 listp Iteration 1 of destru Timing for : destru Elapsed time = 21.578 seconds reclaim time = 6.435 seconds net compute time = 15.143 seconds Storage allocated: 43105 listp ***** deriv Benchmark *** Deriv Iteration 0 of deriv Timing for : deriv Elapsed time = 69.356 seconds reclaim time = 44.784 seconds net compute time = 24.572 seconds Storage allocated: 245000 listp Iteration 1 of deriv Timing for : deriv Elapsed time = 68.728 seconds reclaim time = 44.940 seconds net compute time = 23.788 seconds Storage allocated: 245000 listp ***** dderiv Benchmark *** DDeriv Evaluating setup for dderiv Iteration 0 of dderiv Timing for : dderiv Elapsed time = 84.556 seconds reclaim time = 52.331 seconds net compute time = 32.225 seconds Storage allocated: 260000 listp Iteration 1 of dderiv Timing for : dderiv Elapsed time = 84.406 seconds reclaim time = 52.214 seconds net compute time = 32.192 seconds Storage allocated: 260000 listp ***** boyer Benchmark *** Boyer Evaluating setup for boyer Iteration 0 of boyer Timing for : boyer Elapsed time = 137.293 seconds SWAP time = 0.060 seconds reclaim time = 37.971 seconds net compute time = 99.262 seconds Page faults = 516 Storage allocated: 226464 listp, 272 compiled-closure Iteration 1 of boyer Timing for : boyer Elapsed time = 132.925 seconds reclaim time = 38.305 seconds net compute time = 94.620 seconds Storage allocated: 226464 listp, 272 compiled-closure ***** browse Benchmark *** Browse Iteration 0 of browse Timing for : browse Elapsed time = 509.854 seconds SWAP time = 0.135 seconds reclaim time = 230.500 seconds net compute time = 279.219 seconds Page faults = 83 Storage allocated: 488945 listp, 229002 oned-array Iteration 1 of browse Timing for : browse Elapsed time = 568.228 seconds SWAP time = 0.071 seconds reclaim time = 255.835 seconds net compute time = 312.322 seconds Page faults = 52 Storage allocated: 488945 listp, 229002 oned-array ***** browse* Benchmark *** Browse Iteration 0 of browse* Timing for : browse* Elapsed time = 292.516 seconds reclaim time = 114.387 seconds net compute time = 178.129 seconds Page faults = 49 Storage allocated: 488945 listp, 2202 oned-array Iteration 1 of browse* Timing for : browse* Elapsed time = 299.062 seconds reclaim time = 117.020 seconds net compute time = 182.042 seconds Page faults = 50 Storage allocated: 488945 listp, 2202 oned-array ***** triang Benchmark *** Triang Iteration 0 of triang Timing for : triang Elapsed time = 707.005 seconds SWAP time = 0.073 seconds reclaim time = 0.670 seconds net compute time = 706.262 seconds Page faults = 1 Storage allocated: 11626 listp Iteration 1 of triang Timing for : triang Elapsed time = 706.755 seconds reclaim time = 0.504 seconds net compute time = 706.251 seconds Storage allocated: 11626 listp ***** puzzle Benchmark *** Puzzle Iteration 0 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 43.930 seconds net compute time = 43.930 seconds Storage allocated: 10 listp, 4 oned-array Iteration 1 of puzzle Success in 2005 trials.Timing for : puzzle Elapsed time = 43.931 seconds net compute time = 43.931 seconds Storage allocated: 10 listp, 4 oned-array ***** fft Benchmark *** FFT Iteration 0 of fft Timing for : fft Elapsed time = 177.646 seconds SWAP time = 0.154 seconds reclaim time = 103.517 seconds net compute time = 73.975 seconds Page faults = 31 Storage allocated: 942640 floatp Iteration 1 of fft Timing for : fft Elapsed time = 177.378 seconds reclaim time = 103.680 seconds net compute time = 73.698 seconds Storage allocated: 942640 floatp ***** fprint Benchmark *** FPrint Iteration 0 of fprint Timing for : fprint Elapsed time = 11.925 seconds SWAP time = 0.295 seconds reclaim time = 0.371 seconds net compute time = 11.259 seconds Page faults = 6 Storage allocated: 76 fixp, 492 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 = 11.943 seconds reclaim time = 0.552 seconds net compute time = 11.391 seconds Storage allocated: 75 fixp, 522 listp, 1 vmempagep, 1 stream, 89 oned-array, 7 etherpacket, 2 pathname, 48 pagegroup, 1 filedescriptor ***** fread Benchmark *** FRead Iteration 0 of fread Timing for : fread Elapsed time = 10.563 seconds reclaim time = 0.714 seconds net compute time = 9.849 seconds Storage allocated: 25 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.555 seconds reclaim time = 0.678 seconds net compute time = 9.877 seconds Storage allocated: 25 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 = 25.046 seconds net compute time = 25.046 seconds Storage allocated: 4 listp Evaluating after every function for tprint Iteration 1 of tprint Timing for : tprint Elapsed time = 25.043 seconds net compute time = 25.043 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 = 71.183 seconds reclaim time = 1.921 seconds net compute time = 69.262 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 = 70.651 seconds reclaim time = 1.787 seconds net compute time = 68.864 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 = 142.624 seconds net compute time = 142.624 seconds Iteration 1 of traverse* Timing for : traverse* Elapsed time = 142.624 seconds net compute time = 142.624 seconds Evaluating after function for traverse* \ No newline at end of file diff --git a/internal/gabriel/Results/Lyric/lyric-results.tedit b/internal/gabriel/Results/Lyric/lyric-results.tedit new file mode 100644 index 00000000..ddae1c45 Binary files /dev/null and b/internal/gabriel/Results/Lyric/lyric-results.tedit differ 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 00000000..1c552d3d Binary files /dev/null and b/internal/gabriel/Results/Lyric/summary.tedit differ diff --git a/internal/gabriel/Results/Maiko-Pav-06-14-88.benchmarks b/internal/gabriel/Results/Maiko-Pav-06-14-88.benchmarks new file mode 100644 index 00000000..64a68184 --- /dev/null +++ b/internal/gabriel/Results/Maiko-Pav-06-14-88.benchmarks @@ -0,0 +1 @@ +Lisp Type: Xerox Lisp Lisp Version: Lispcore sysout of 7-Jun-88 01:23:36 Software Type: Xerox AIE Software Version: Lispcore sysout of 7-Jun-88 01:23:36, Make-init dates: 7-Jun-88 00:26:43, 7-Jun-88 00:36:27 Machine Type: MAIKO Machine Version: Microcode version: 5682, memory size: 16384 Machine Instance: ACobra = 200004000066660# Site: Unknown Features: (:INTERLISP :XEROX :COMMON :IEEE-FLOATING-POINT) ***** TAKR Benchmark *** TakR Iteration 0 of TAKR Timing for : TAKR Elapsed time = 3.520 seconds net compute time = 3.520 seconds Iteration 1 of TAKR Timing for : TAKR Elapsed time = 3.520 seconds net compute time = 3.520 seconds ***** TAKL Benchmark *** TakL Iteration 0 of TAKL Timing for : TAKL Elapsed time = 29.420 seconds SWAP time = 0.040 seconds net compute time = 29.380 seconds Iteration 1 of TAKL Timing for : TAKL Elapsed time = 29.400 seconds SWAP time = 0.020 seconds net compute time = 29.380 seconds ***** TAK Benchmark *** Tak Iteration 0 of TAK Timing for : TAK Elapsed time = 3.180 seconds net compute time = 3.180 seconds Iteration 1 of TAK Timing for : TAK Elapsed time = 3.200 seconds net compute time = 3.200 seconds ***** STAK Benchmark *** STak Iteration 0 of STAK Timing for : STAK Elapsed time = 17.320 seconds net compute time = 17.320 seconds Iteration 1 of STAK Timing for : STAK Elapsed time = 17.320 seconds net compute time = 17.320 seconds ***** CTAK Benchmark *** CTak Iteration 0 of CTAK Timing for : CTAK Elapsed time = 110.200 seconds SWAP time = 0.120 seconds reclaim time = 28.080 seconds net compute time = 82.000 seconds Iteration 1 of CTAK Timing for : CTAK Elapsed time = 110.160 seconds SWAP time = 0.160 seconds reclaim time = 27.920 seconds net compute time = 82.080 seconds Storage allocated: 47707 LISTP ***** TRAVERSE-INIT Benchmark *** Traverse, Initialize Iteration 0 of TRAVERSE-INIT Timing for : TRAVERSE-INIT Elapsed time = 223.080 seconds SWAP time = 0.220 seconds reclaim time = 3.560 seconds net compute time = 219.300 seconds Storage allocated: 100 TNODE Iteration 1 of TRAVERSE-INIT Timing for : TRAVERSE-INIT Elapsed time = 228.080 seconds SWAP time = 0.180 seconds reclaim time = 3.580 seconds net compute time = 224.320 seconds Storage allocated: 36796 LISTP, 100 TNODE ***** TRAVERSE Benchmark *** Traverse, Traverse Iteration 0 of TRAVERSE Timing for : TRAVERSE Elapsed time = 322.020 seconds SWAP time = 0.120 seconds net compute time = 321.900 seconds Storage allocated: 3 FIXP, 12 LISTP Iteration 1 of TRAVERSE Timing for : TRAVERSE Elapsed time = 321.600 seconds SWAP time = 0.180 seconds net compute time = 321.420 seconds ***** TPRINT Benchmark *** TPrint Evaluating setup for TPRINT Iteration 0 of TPRINT Timing for : TPRINT Elapsed time = 54.820 seconds SWAP time = 0.040 seconds net compute time = 54.780 seconds Storage allocated: 160 FIXP, 4 LISTP Evaluating after every function for TPRINT Iteration 1 of TPRINT Timing for : TPRINT Elapsed time = 54.780 seconds SWAP time = 0.020 seconds net compute time = 54.760 seconds Storage allocated: 160 FIXP, 4 LISTP Evaluating after every function for TPRINT Evaluating after function for TPRINT ***** PUZZLE Benchmark *** Puzzle Iteration 0 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 474.440 seconds SWAP time = 0.900 seconds net compute time = 473.540 seconds Storage allocated: 1 FIXP, 10 LISTP, 1 ONED-ARRAY Iteration 1 of PUZZLE Success in 2005 trials.Timing for : PUZZLE Elapsed time = 470.440 seconds SWAP time = 0.540 seconds net compute time = 469.900 seconds Storage allocated: 1 FIXP, 10 LISTP, 1 ONED-ARRAY ***** FREAD Benchmark *** FRead Iteration 0 of FREAD In OPEN: File not found: #.(PATHNAME "{dsk}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 00000000..7eb773cc Binary files /dev/null and b/internal/gabriel/Results/SUMMARY-TIME-SERIES2.tedit differ diff --git a/internal/gabriel/Results/SUMMARY-TIME-SERIES3.tedit b/internal/gabriel/Results/SUMMARY-TIME-SERIES3.tedit new file mode 100644 index 00000000..742859f9 Binary files /dev/null and b/internal/gabriel/Results/SUMMARY-TIME-SERIES3.tedit differ diff --git a/internal/gabriel/Results/SUMMARY-TIME-SERIES4.Tedit b/internal/gabriel/Results/SUMMARY-TIME-SERIES4.Tedit new file mode 100644 index 00000000..7e030b23 Binary files /dev/null and b/internal/gabriel/Results/SUMMARY-TIME-SERIES4.Tedit differ diff --git a/internal/gabriel/Results/Summary-Time-Series.TEdit b/internal/gabriel/Results/Summary-Time-Series.TEdit new file mode 100644 index 00000000..d7b98d6c Binary files /dev/null and b/internal/gabriel/Results/Summary-Time-Series.TEdit differ diff --git a/internal/gabriel/Results/koto-1108.benchmarks b/internal/gabriel/Results/koto-1108.benchmarks new file mode 100644 index 00000000..faddb97f --- /dev/null +++ b/internal/gabriel/Results/koto-1108.benchmarks @@ -0,0 +1 @@ + MACHINETYPE = DANDELION MAKESYSNAME = KOTO MAKESYSDATE = 17-Oct-85 19:19:58 DATE = 17-Nov-85 15:40:40 USERNAME = PEDERSEN ************ TAK BENCHMARK ************** Starting the TAK run: (TIMEALL (TAK 18 12 6)) Elapsed Time = 1.99 seconds SWAP time = .138 seconds CPU Time = 1.85 seconds PAGEFAULTS = 2 SWAPWRITES = 1 Value = 7 Repeating the TIMEALL Elapsed Time = 1.9 seconds CPU Time = 1.9 seconds Value = 7 TAK finished ************ STAK BENCHMARK ************** Starting the STAK run: (TIMEALL (STAK)) Elapsed Time = 4.91 seconds SWAP time = .013 seconds CPU Time = 4.9 seconds PAGEFAULTS = 1 SWAPWRITES = 1 Value = 7 Repeating the TIMEALL Elapsed Time = 4.92 seconds CPU Time = 4.92 seconds STAK finished ************ CTAK BENCHMARK ************** Starting the CTAK run: (TIMEALL (CTAK 18 12 6)) Elapsed Time = 59.9 seconds SWAP time = .196 seconds CPU Time = 59.7 seconds PAGEFAULTS = 6 SWAPWRITES = 1 Value = 7 Repeating the TIMEALL Elapsed Time = 59.7 seconds CPU Time = 59.7 seconds Value = 7 CTAK finished ************ TAKL BENCHMARK ************** Starting the TAKL run: (TIMEALL (TAKL 18L 12L 6L)) Elapsed Time = 14.1 seconds SWAP time = .06 seconds CPU Time = 14.1 seconds PAGEFAULTS = 3 Value = (7 6 5 4 3 2 1) Repeating the TIMEALL Elapsed Time = 14.1 seconds CPU Time = 14.1 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.38 seconds SWAP time = .38 seconds CPU Time = 2.0 seconds PAGEFAULTS = 18 SWAPWRITES = 1 Value = 7 Repeating the TIMEALL Elapsed Time = 1.99 seconds CPU Time = 1.99 seconds Value = 7 TAKR finished ********* BOYER BENCHMARK *********** Initializing BOYER run: (TIMEALL (SETUP)) Elapsed Time = 2.98 seconds SWAP time = 2.74 seconds CPU Time = .237 seconds PAGEFAULTS = 61 SWAPWRITES = 4 LISTP 224 starting BOYER run: (TIMEALL (TEST-BOYER)) Elapsed Time = 150.0 seconds SWAP time = .585 seconds GC time = 42.1 seconds CPU Time = 107.0 seconds PAGEFAULTS = 552 SWAPWRITES = 44 FIXP LISTP 7 226469 Repeating the TIMEALL Elapsed Time = 140.0 seconds GC time = 41.6 seconds CPU Time = 98.8 seconds PAGEFAULTS = 4 FIXP LISTP 7 226469 BOYER finished ********* BROWSE BENCHMARK *********** starting BROWSE run: (TIMEALL (BROWSE)) Elapsed Time = 453.0 seconds SWAP time = 51.5 seconds GC time = 156.0 seconds CPU Time = 246.0 seconds PAGEFAULTS = 934 SWAPWRITES = 274 LISTP 488945 Repeating the TIMEALL Elapsed Time = 442.0 seconds SWAP time = 30.4 seconds GC time = 158.0 seconds CPU Time = 254.0 seconds PAGEFAULTS = 320 SWAPWRITES = 298 LISTP 488945 BROWSE finished *********** THE DESTRUCTIVE BENCHMARK ************ Starting the DESTRUCTIVE run: (TIMEALL (DESTRUCTIVE 600 50)) Elapsed Time = 27.6 seconds SWAP time = .1 seconds GC time = 6.84 seconds CPU Time = 20.7 seconds PAGEFAULTS = 1 SWAPWRITES = 1 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 = 27.3 seconds GC time = 6.63 seconds CPU Time = 20.7 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 = 107.0 seconds SWAP time = 21.3 seconds GC time = 1.35 seconds CPU Time = 84.7 seconds PAGEFAULTS = 404 SWAPWRITES = 173 LISTP NODE 36796 100 Starting the TRAVERSE run: (TIMEALL (RUN-TRAVERSE)) Elapsed Time = 163.0 seconds SWAP time = .509 seconds CPU Time = 163.0 seconds PAGEFAULTS = 4 SWAPWRITES = 4 Repeating the TIMEALL Elapsed Time = 163.0 seconds CPU Time = 163.0 seconds TRAVERSE finished ******* Derivative Benchmark ********** Starting the DERIV run: (TIMEALL (RUN-DERIV)) Elapsed Time = 81.4 seconds SWAP time = 3.46 seconds GC time = 44.3 seconds CPU Time = 33.7 seconds PAGEFAULTS = 52 SWAPWRITES = 23 LISTP 245000 Value = NIL Repeating the TIMEALL Elapsed Time = 79.4 seconds GC time = 45.1 seconds CPU Time = 34.3 seconds LISTP 245000 Value = NIL DERIV finished ******* Data-Driven Derivative Benchmark ********** Starting the DDERIV run: (TIMEALL (RUN-DDERIV)) Elapsed Time = 98.7 seconds SWAP time = .463 seconds GC time = 54.3 seconds CPU Time = 44.0 seconds PAGEFAULTS = 11 SWAPWRITES = 1 LISTP 260000 Value = NIL Repeating the TIMEALL Elapsed Time = 98.9 seconds GC time = 55.0 seconds CPU Time = 43.9 seconds LISTP 260000 Value = NIL DDERIV finished ******* DIVIDE BY TWO BENCHMARK ********** Starting the iterative DIV2 run: (TIMEALL (TEST1 L)) Elapsed Time = 34.0 seconds SWAP time = .263 seconds GC time = 23.2 seconds CPU Time = 10.6 seconds PAGEFAULTS = 6 SWAPWRITES = 1 LISTP 120000 Repeating the TIMEALL Elapsed Time = 33.6 seconds GC time = 22.8 seconds CPU Time = 10.8 seconds LISTP 120000 Starting the recursive DIV2 run: (TIMEALL (TEST2 L)) Elapsed Time = 39.1 seconds GC time = 23.7 seconds CPU Time = 15.4 seconds LISTP 120000 Repeating the TIMEALL Elapsed Time = 38.7 seconds GC time = 23.4 seconds CPU Time = 15.2 seconds LISTP 120000 DIV2 finished *************** THE FFT BENCHMARK *********** Starting FFT run: (TIMEALL (FFT-BENCH)) Elapsed Time = 1110.0 seconds SWAP time = 1.34 seconds GC time = 220.0 seconds CPU Time = 890.0 seconds PAGEFAULTS = 61 SWAPWRITES = 12 FLOATP 1010220 Repeating the TIMEALL Elapsed Time = 1110.0 seconds GC time = 220.0 seconds CPU Time = 888.0 seconds FLOATP 1010220 FFT finished *************** THE PUZZLE BENCHMARK *********** Starting PUZZLE run: (TIMEALL (START)) Success in 2005 trials. Elapsed Time = 129.0 seconds SWAP time = .72 seconds CPU Time = 128.0 seconds PAGEFAULTS = 11 SWAPWRITES = 4 Value = NIL Repeating the TIMEALL Success in 2005 trials. Elapsed Time = 128.0 seconds CPU Time = 128.0 seconds Value = NIL PUZZLE finished *************** THE TRIANGLE BENCHMARK *********** Starting TRIANG run: (TIMEALL (GOGOGO 22)) Elapsed Time = 2410.0 seconds SWAP time = 1.35 seconds GC time = .479 seconds CPU Time = 2400.0 seconds PAGEFAULTS = 51 SWAPWRITES = 2 LISTP 11626 Value = NIL Repeating the TIMEALL Elapsed Time = 2410.0 seconds GC time = .493 seconds CPU Time = 2410.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 = 32.6 seconds SWAP time = 21.3 seconds GC time = .422 seconds CPU Time = 10.9 seconds PAGEFAULTS = 285 SWAPWRITES = 115 FIXP LISTP STRINGP VMEMPAGEP STREAM PROCESS PageGroup FileDescriptor 50 711 38 1 1 2 50 1 Repeating the TIMEALL Elapsed Time = 12.4 seconds SWAP time = 2.4 seconds GC time = .39 seconds CPU Time = 9.6 seconds PAGEFAULTS = 20 SWAPWRITES = 20 FIXP LISTP STRINGP VMEMPAGEP STREAM ETHERPACKET PageGroup FileDescriptor 43 578 37 1 1 1 48 1 FPRINT finished Starting the FREAD run: (TIMEALL (FREAD)) Elapsed Time = 14.3 seconds SWAP time = 5.66 seconds GC time = .265 seconds CPU Time = 8.41 seconds PAGEFAULTS = 43 SWAPWRITES = 43 FIXP LISTP STRINGP VMEMPAGEP STREAM PageGroup FileDescriptor 44 2510 19 1 1 37 1 Repeating the TIMEALL Elapsed Time = 8.2 seconds GC time = .262 seconds CPU Time = 7.94 seconds FIXP LISTP STRINGP VMEMPAGEP STREAM PageGroup FileDescriptor 44 2510 19 1 1 37 1 FREAD finished Starting the TPRINT run: (TPRINT) Elapsed Time = 27.9 seconds CPU Time = 27.9 seconds Repeating the TIMEALL Elapsed Time = 27.9 seconds CPU Time = 27.9 seconds TPRINT finished *************** THE POLYNOMIAL BENCHMARK *********** Starting POLY 2 run: (TIMEALL (BENCH 2)) Elapsed Time = 1.23 seconds SWAP time = .69 seconds CPU Time = .537 seconds PAGEFAULTS = 13 SWAPWRITES = 5 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 = .523 seconds CPU Time = .523 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 = 19.4 seconds SWAP time = 1.32 seconds GC time = 4.45 seconds CPU Time = 13.7 seconds PAGEFAULTS = 13 SWAPWRITES = 13 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 = 17.4 seconds GC time = 3.74 seconds CPU Time = 13.6 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 = 546.0 seconds SWAP time = .747 seconds GC time = 135.0 seconds CPU Time = 410.0 seconds PAGEFAULTS = 55 SWAPWRITES = 41 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 = 548.0 seconds SWAP time = .349 seconds GC time = 136.0 seconds CPU Time = 412.0 seconds PAGEFAULTS = 14 SWAPWRITES = 14 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 = 10000.0 seconds SWAP time = 1.44 seconds GC time = 2470.0 seconds CPU Time = 7530.0 seconds PAGEFAULTS = 187 SWAPWRITES = 45 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 = 9990.0 seconds GC time = 2470.0 seconds CPU Time = 7520.0 seconds PAGEFAULTS = 14 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/admin/Result-Log-Form.TEdit b/internal/gabriel/admin/Result-Log-Form.TEdit new file mode 100644 index 00000000..e27396e6 Binary files /dev/null and b/internal/gabriel/admin/Result-Log-Form.TEdit differ diff --git a/internal/gabriel/aux/1000-SYMBOLS b/internal/gabriel/aux/1000-SYMBOLS new file mode 100644 index 00000000..53ea3c23 --- /dev/null +++ b/internal/gabriel/aux/1000-SYMBOLS @@ -0,0 +1 @@ +(\INTERPRETER SMALLP FIXP FLOATP LITATOM LISTP ARRAYP STRINGP STACKP \RECLAIMSTACKP CHARACTER VMEMPAGEP RELEASINGVMEMPAGE STREAM BITMAP COMPILED-CLOSURE ONED-ARRAY TWOD-ARRAY GENERAL-ARRAY \PTRHUNK2 \PTRHUNK4 \PTRHUNK5 \PTRHUNK6 \PTRHUNK7 \PTRHUNK8 \PTRHUNK10 \PTRHUNK12 \PTRHUNK16 \PTRHUNK24 \PTRHUNK32 \PTRHUNK42 \PTRHUNK64 \UNBOXEDHUNK1 \UNBOXEDHUNK2 \UNBOXEDHUNK3 \UNBOXEDHUNK4 \UNBOXEDHUNK5 \UNBOXEDHUNK6 \UNBOXEDHUNK7 \UNBOXEDHUNK8 \UNBOXEDHUNK9 \UNBOXEDHUNK10 \UNBOXEDHUNK12 \UNBOXEDHUNK14 \UNBOXEDHUNK16 \UNBOXEDHUNK20 \UNBOXEDHUNK24 \UNBOXEDHUNK28 \UNBOXEDHUNK32 \UNBOXEDHUNK40 \UNBOXEDHUNK48 \UNBOXEDHUNK64 \CODEHUNK12 \RECLAIMCODEBLOCK \CODEHUNK16 \CODEHUNK20 \CODEHUNK24 \CODEHUNK28 \CODEHUNK32 \CODEHUNK36 \CODEHUNK42 \CODEHUNK50 \CODEHUNK64 \RECLAIMARRAYBLOCK \UNKNOWN.UFN \CAR.UFN \CDR.UFN NTYPX \TYPEP.UFN \UNWIND.UFN \CHECKAPPLY* \HARDRETURN \RPLPTR.UFN \HTFIND ASSOC \SETGLOBALVAL.UFN \RPLACA.UFN \RPLACD.UFN \CONS.UFN FMEMB \FINDKEY.UFN \CREATECELL \BIN \POPDISP.UFN \RESTLIST.UFN \RPLCONS LISTGET \EVAL \TYPECHECK.UFN \STKSCAN \BUSBLT.UFN \MISC8.UFN \UNBOXFLOAT3 \TYPEMASK.UFN RAID \MISC7.UFN EQL \DRAWLINE.UFN \STORE.N.UFN \COPY.N.UFN \RETURN \ARG0 \MYARGCOUNT \READFLAGS \READRP \WRITEMAP \READPRINTERPORT.UFN \WRITEPRINTERPORT.UFN \PILOTBITBLT \RCLKSUBR \MISC1.UFN \MISC2.UFN \GCRECLAIMCELL \GCSCAN1 \GCSCAN2 \CONTEXTSWITCH \RETCALL %%AREF1 %%ASET1 \POP.N.UFN \ATOMCELL \GETBASEBYTE \INSTANCEP.UFN \BLT \MISC10.UFN \PUTBASEBYTE \PUTBASE.UFN \PUTBASEPTR.UFN \PUTBITS.UFN \ADDBASE \VAG2 \SLOWPLUS2 \SLOWDIFFERENCE \SLOWTIMES2 \SLOWQUOTIENT \SLOWIPLUS2 \SLOWIDIFFERENCE \SLOWITIMES2 \SLOWIQUOTIENT IREMAINDER \SLOWLLSH1 \SLOWLLSH8 \SLOWLRSH1 \SLOWLRSH8 \SLOWLOGOR2 \SLOWLOGAND2 \SLOWLOGXOR2 LSH \SLOWFPLUS2 \SLOWFDIFFERENCE \SLOWFTIMES2 \SLOWFQUOTIENT \UNBOXFLOAT2 \UNBOXFLOAT1 %%AREF2 %%ASET2 \SLOWIGREATERP \SLOWFGREATERP GREATERP EQUAL \BOXIPLUS \BOXIDIFFERENCE \FLOATBLT \FFTSTEP \MISC3.UFN \MISC4.UFN NILL %%= CDRCODING \SMALLP \FIXP \FLOATP \LITATOM \LISTP \ARRAYP \STRINGP \STACKP \CHARACTERP \VMEMPAGEP \STREAM \TT.TYPEMASK \TT.NOREF \TT.LISPREF \TT.FIXP \TT.NUMBERP \TT.ATOM \PMblockSize \STATSsize \NumPMTpages \EmptyPMTEntry \FirstVmemBlock \MAXVMPAGE \MAXVMSEGMENT \IFPValidKey \FirstMDSPage \MaxMDSPage \DefaultSecondMDSPage \MDSIncrement \PagesPerMDSUnit \ARRAYSPACE \FirstArraySegment \FirstArrayPage \ARRAYSPACE2 \DefaultSecondArrayPage \StackMask \FxtnBlock \GuardBlock \BFBlock \FreeStackBlock \NotStackBlock \MinExtraStackWords ERASECHARCODE \HT1CNT \HTSTKBIT \HTCNTMASK \HTMAINSIZE \HTCOLLSIZE \HTENDFREE \HTFREEPTR \ATOMSPACE \AtomHI \CHARHI \AtomHashTable \AtomHTpages \LastAtomPage \MaxAtomFrLst \SMALLPOSPSPACE \SmallPosHi \SMALLNEGSPACE \SmallNegHi \NumSmallPages \PNPSPACE \PNAME.HI \DEFSPACE \DEF.HI \VALSPACE \VAL.HI \PLISTSPACE \PLIST.HI \PAGEMAP \NumPageMapPages \PageMapTBL \InterfacePage \IOPAGE \DoveIORegion \IOCBPAGE \FPTOVP \MDSTypeTable \MDSTTsize \MISCSTATS \UFNTable \UFNTableSize \DTDSpaceBase \DTDSize \LISTPDTD \EndTypeNumber \LOCKEDPAGETABLE \NumLPTPages \STACKSPACE \GuardStackAddr \LastStackAddr \STACKHI \HTMAIN \HTMAINnpages \HTOVERFLOW \HTBIGCOUNT \HTCOLL \DISPLAYREGION \D1BCPLspace \D0BCPLspace \CurrentFXP \ResetFXP \SubovFXP \KbdFXP \HardReturnFXP \GCFXP \FAULTFXP \MiscFXP \TeleRaidFXP DCB.EM DISPINTERRUPT.EM CURSORBITMAP.EM KBDAD0.EM KBDAD1.EM KBDAD2.EM KBDAD3.EM UTILIN.EM CURSORX.EM CURSORY.EM MOUSEX.EM MOUSEY.EM \LispKeyMask \BcplKeyMask \DOLPHIN \DORADO \DANDELION \DAYBREAK \VP.DISPLAY \NP.DISPLAY \NP.WIDEDOVEDISPLAY \WIDEDOVEDISPLAYWIDTH \RP.AFTERDISPLAY \RP.AFTERDOVEDISPLAY \RP.DISPLAY \RP.TEMPDISPLAY \RP.MISCLOCKED \RP.STACK \VP.STACK \RP.MAP \NP.MAP \RP.IOPAGE \RP.DOVEIOCBPAGE \RP.DOVEIORGN \VP.DOVEIORGN \DOVEIORGNSIZE \VP.IOPAGE \VP.IFPAGE \VP.FPTOVP \NP.FPTOVP \RP.FPTOVP \RP.STARTBUFFERS \VP.TYPETABLE \NP.TYPETABLE \RP.TYPETABLE \VP.GCTABLE \NP.GCTABLE \RP.GCTABLE \VP.GCOVERFLOW \NP.GCOVERFLOW \RP.GCOVERFLOW \FP.IFPAGE \VP.IOCBS \VP.PRIMARYMAP \VP.SECONDARYMAP \VP.LPT \VP.INITSCRATCH \VP.RPT \VP.BUFFERS \DL.PROCESSORBUSY \DL.SETTOD \DL.READTOD \DL.READPID \DL.BOOTBUTTON \FAULTINIT \MAKEFRAME \SET.VMEM.FULL.STATE \SETIOPOINTERS \D01.FAULTINIT \DOVE.FAULTINIT \DL.FAULTINIT \MP.ERROR \MISCSTACKBASE \DOMISCAPPLY \KBDSTACKBASE \DUMMYKEYHANDLER \KEYHANDLER \DOFAULTINIT \GUARDVMEMFULL \LASTVMEMFILEPAGE \MACHINETYPE \LASTDIRTYSCANPTR \D01.ASSIGNBUFFERS \CHAIN.UP.RPT \RCLKSECOND \RCLKMILLISECOND \RPTSIZE \RPOFFSET \REALPAGETABLE \VMEMACCESSFN \M44ACTONVMEMFILE NPAGES EXTRALEN EMLEN EMBUF \INITBFS \EMUBUFFERS \EMUSWAPBUFFERS \EMUDISKBUFEND \#DISKBUFFERS \EMUDISKBUFFERS \#SWAPBUFFERS \#EMUBUFFERS \MAXSWAPBUFFERS \TELERAIDBUFFER \EMBUFRP \EMBUFVP \EMBUFBASE \DoveDisplay.TurnOn SETMAINTPANEL \DoveDisk.Init \DoveMisc.ReadHostID \DoveMisc.ReadGMT \DL.NEWFAULTINIT \VMEM.FULL.STATE \DOVE.ACTONVMEMFILE \DL.DISKINIT \DL.ACTONVMEMFILE NBUFFERS LASTREALPAGE RPTBASE FPBASE FIRSTVP RPSIZE NEXTBANK0 NDISPLAYPAGES FIRSTRP RPTPAGES VP IOCBRP IFPAGERP FIRSTUSEFULRP SCRATCHBASE SCRATCHVP FIRSTBUFFERRP NREALPAGES \DL.ASSIGNBUFFERS \DL.MARK.PAGES.UNAVAILABLE \CLEARWORDS \DL.UNMAPPAGES \DoveDisplay.ScreenWidth \DoveIO.InitializeIORegionPtrs \LOCKEDPAGEP \MaxScreenPage FP LASTFP FIRSTFP LASTRP BASE FIRSTUSED LASTUSED LASTEMPTY \RPTLAST \FAULTHANDLER \PAGEFAULT FILEPAGE FLAGS PTR \CLOCK0 \ASSURE.FPTOVP.PAGE \LOADVMEMPAGE \INVALIDADDR \LOOKUPPAGEMAP \NEWVMEMPAGEADDED ADDR \INVALIDVP IFVP NEWFP RPTR FROMFLUSHVM RPTINDEX \FLUSHPAGE \TRANSFERPAGE \DIRTYPAGEHINT \VMEM.PURE.LIMIT SRPTR SRINDEX SPECIALRP DONTMOVETOPFLG LOCK? NEWPAGEFLG VPAGE \MOVEREALPAGE \SPECIALRP \SELECTREALPAGE \UPDATECHAIN \PAGEFAULTCOUNTER \UPDATECHAINFREQ SOURCEFLAGS SOURCEVP DESTRPT DESTINDEX SOURCERPT SOURCEINDEX \VALIDADDRESSP TEMP LLSH PREVINDEX PREVRPT DISTANCE CNTR TRIES REMOVE \VMEM.INHIBIT.WRITE \MAXSHORTSEEK NEW \MINSHORTSEEK \MAXCLEANPROBES NEWFLAGS NEWPAGE? WRITE? FLIPCURSORBAR \LASTACCESSEDVMEMPAGE HEAD1 CHAIN1 CHAIN0 \DIRTYPAGECOUNTER \INTERRUPTABLE NOERROR \NEWPAGE \LOCKPAGES \DONEWPAGE ERRCODE NEXTPM LOCKBASE MAPBASE INTERNALFLG \MAKESPACEFORLOCKEDPAGE OLDVP DESIREDFP \MOVEVMEMFILEPAGE RP OLDFP \NEWEPHEMERALPAGE \DONEWEPHEMERALPAGE PREVRP \DOLOCKPAGES NEWRPT NEWINDEX MASK RPINDEX \TEMPLOCKPAGES \DOTEMPLOCKPAGES \TEMPUNLOCKPAGES HELP \UNLOCKPAGES VAR \FLUSHVM SET \FLUSHVMOK? \SYSTEMCACHEVARS \DOFLUSHVM FAST \LOGOUT0 \LISPFINISH \DoveMisc.BootButton IFPRPT SCRATCHBUF IFPVP \DOCOMPRESSVMEM VMEM.COMPRESS.FLG \RELEASEWORKINGSET CNT NUMDIRTY MINDIRTY \WRITEDIRTYPAGE \DIRTYSEEKMAX \WRITEDIRTYPAGE1 \LASTDIRTYCNT \LASTDIRTYFOUND RESULT FLAGBITS TYPE \COUNTREALPAGES \ILLEGAL.ARG OCCUPIED LOCKED DIRTY REF OLDVIW EMPTYFP FLG VMEM.PURE.STATE 32MBADDRESSABLE \PENDINGINTERRUPT \INTERRUPTSTATE \SET.LASTVMEMFILEPAGE HELPFLAG SI::*CLEANUP-FORMS* SI::*UNWIND-PROTECT* CL:CERROR CONCAT \M44EXTENDVMEMFILE BREAK! \EXTENDINGVMEMFILE \DOVMEMFULLINTERRUPTA0001 SI::*RESETFORMS* \DOVMEMFULLINTERRUPT CL:VALUES-LIST SI::RESETUNWIND \MVLIST MSG ERROR LOGOUT ARG2 ARG1 STRING CODE WRITEFLAG BUFFER \ACTONVMEMFILE LASTONE FIRSTONE STATE OUTSTREAM *PRINT-BASE* FILE MODE \SHOWPAGETABLE TERPRI PRIN1 SPACES PRINTNUM TAB \PRINTVP GETSTREAM CHAIN OUTPUT FIX CHAINLOCKED CHAINOCCUPIED NUMLOCKED NUMOCCUPIED CHECKPAGEMAP CHECKFPTOVP1 CHECKFPTOVP FP2 NEXTTYPE NEXTLOCKED LOCKEDP NEXTVP NEXTFP LASTVP VPRAWFLG TYPEFLG NWORDS FIRSTPAGE \PRINTFPTOVP TYPENAME FN \LOCKFN \LOCKCODE \LOCKCELL CODEBLOCK \LOCKWORDS \#BLOCKDATACELLS \LOCKVAR NPGS DUMMY \uCodeCheck was\StackOverflow \NWWInterrupt was\PageFault \StatsOverflow NOOPSUBR \BACKGROUNDSUBR CL:VECTOR PASS \CHECKBCPLPASSWORD DISKPARTITION \DFSCurrentVolume MACHINETYPE DOVE DANDELION DOLPHIN DORADO CHARCODE DSPBOUT AC2 AC1 AC0 \DSPRATE FID \GATHERSTATS \GETPACKETBUFFER \MOREVMEMFILE MESS2 MESS1 \READRAWPBI PBI \WRITERAWPBI SETSCREENCOLOR RASTERWIDTH SHOWDISPLAY \PUPLEVEL1STATE X10 X9 X8 X7 X6 X5 X4 X3 X2 X1 \WRITESTATS \COPYSYS0SUBR DD CB CBSTART DSK AFTER \M44DOEXTENDVMEMFILE \SWAPREQUESTBLOCK \ISFMAP \ISFCHUNKSIZE \ISFSCRATCHCAS \ISFSCRATCHDAS \MAXDISKDAs \EMUSCRATCH \SYSDISK \SPAREDISKWRITEBUFFER \MAINDISK HERE NUM \TESTPARTITION BUF CA FIXEDBUF REQUEST LASTNC EMFIXEDCA EMFID EMDAs EMCAs EMBUFS EMBLOCK CAs HINTLASTPAGE ReturnOnCheckError LASTACTION LASTNUMCHARSCONS ACTION LASTPAGE DAorigin DAs BUFFERS \ACTONDISKPAGES \DISKERROR \CLEARBYTES \DOACTONDISKPAGES \DISKREQUESTBLOCK LASTNUMCHARS \WRITEDISKPAGES \OPENDISKDESCRIPTOR \DOWRITEDISKPAGES M44.SIGNAL.DISK.ERROR EC FILENAME \LISPERROR OK \ACTONVMEMPAGES \WRITEVMEMPAGES PAGENO THISACTION NEXTCB CURRENTPAGE RETURNONCHECKERROR DAS CAS CLEANUPFN \DODISKCOMMAND \GETDISKCB \CLEANUPDISKQUEUE LAB LASTVDA NEXTNEWPAGE FIRSTNEWPAGE \REALDISKDA \M44MARKPAGEFREE \ASSIGNDISKPAGE \CHECKFREEPAGE STATUS LASTCB NEXT LA SHORTCB VDA \CLEARCB LVDA LABEL FREE \VIRTUALDISKDA \DISKDEBUG REALDA CHUNK PAGE WRITEFLG \LOOKUPFMAP OLDLASTPAGE ADD.PROCESS \M44FLUSHDISKDESCRIPTOR \M44.READY \M44VMEMEXTENDED P1 LASTPAGEOFFSET LASTPAGEADDR LASTPAGEWRITTEN LASTPAGEREAD NP FIRSTDA LASTFULLPAGE LASTNEEDEDPAGE \EXTENDISFMAP DA NPIECES FLASHWINDOW CREATEW \M44VMEMFRAGMENTS \FRAGMENTATIONWARNED CL:ERROR \FIXP.FROM.FLOATP :MESSAGE :VALUE :NAME :EXPECTED-TYPE XCL:TYPE-MISMATCH RATIO COMPLEX NOT CL:NUMBER AND \GETBASE \PUTBASE N.FD BYTE DISP EVENP \GETBASEPTR \PUTBASEPTR \HILOC \LOLOC EQ FEQP VAL OFFSET OBJ \RPLPTR LOC VAG \LONUM \HINUM \NEW4PAGE CONS \NEXTCONSPAGE \DORECLAIM \RECLAIM.COUNTDOWN CAR CDR CAR/CDRERR RPLACA RPLACD LST ITEM DOCOLLECT ENDCOLLECT LINK \INITCONSPAGE \ALLOCMDSPAGE FIRSTN LASTN TAIL ARGN KEY CHECKCONSPAGES \MAPMDS \CHECKCONSPAGE PN NXT WORDSPERCELL of CDRCODE fetch SETQ NEQ NEXTCELL CONSPAGE STREAMPROP GETSTREAMPROP PUTSTREAMPROP PROP OLDVALUE VALUE LISTPUT STREAMP *READTABLE* \STREAM.DEFPRINT \GETACCESS OCTALSTRING BOTH INPUT READTABLEP SHOULDNT APPEND ACCESS \SETACCESS FDEV \STREAM.NOT.OPEN DEV NAME \DEFINEDEVICE U-CASE DREMOVE \DEVICENAMETODEVICE \FILEDEVICENAMES \FILEDEVICES DONTCREATE \GETDEVICEFROMNAME \GETDEVICEFROMHOSTNAME FILENAMEFIELD HOST HOSTN \REMOVEDEVICE NAMES \REMOVEDEVICE.NAMES \CLOSEFILE IMAGEOPS \DELETEFILE \ADD.CONNECTED.DIR INTERLISP-NAMESTRING PATHNAME \DEVICEEVENTA0001 EVENT \DEVICEEVENT REVERSE \MAP-OPEN-STREAMS BEFORESAVEVM BEFORESYSOUT BEFOREMAKESYS BEFORELOGOUT OPTIONS DESIREDPROPS PATTERN \GENERATEFILES NAMEONLY GENOBJ \GENERATENEXTFILE ATTRIBUTE \GENERATEFILEINFO RECOG \GETFILENAME \GETFILENAME.OR.STREAM \GENERIC.OUTFILEP PACKFILENAME BODY VERSION OLD PARAMETERS \OPENFILE \DO.PARAMS.AT.OPEN \IOMODEP CHARSET SETFILEINFO ENDOFSTREAMOP NEWFILE OLDFILE \RENAMEFILE \REVALIDATEFILE CHANGED DELETED DEVICE \PAGED.REVALIDATEFILELST \PRINT-REVALIDATION-RESULT FORGETPAGES RESTOREMAP \PAGED.REVALIDATEFILE AFTERCLOSE LIST \PAGED.REVALIDATEFILES COPY \BUFFERED.REVALIDATEFILE \BUFFERED.REVALIDATEFILELST LASTOFFSET \TRUNCATEFILE \FILE-CONFLICT \GENERATENOFILES \NULLFILEGENERATOR STRPOS NTHCHARCODE STAR NOSTAR \NOFILESINFOFN \NOFILESNEXTFILEFN ESC CONSTANT GENFILESTATE INFILEP PACKFILENAME.STRING FULLNAME OLDEST DONE GENSTATE GETFILEINFO \FILE.NOT.OPEN \FILE.WONT.OPEN \ILLEGAL.DEVICEOP \IS.NOT.RANDACCESSP \FDEVINSTANCEA0002 ATTRIB \FDEVINSTANCEA0005 OTHERINFO CDNAME \FDEVINSTANCEA0008 BUFFERLIST \FDEVINSTANCEA0011 \FDEVINSTANCEA0014 \FDEVINSTANCEA0017 \FDEVINSTANCEA0020 OLDSTREAM \FDEVINSTANCEA0023 \FDEVINSTANCEA0026) \ No newline at end of file diff --git a/internal/gabriel/aux/2000-FLOATS-TO-READ b/internal/gabriel/aux/2000-FLOATS-TO-READ new file mode 100644 index 00000000..23848d43 --- /dev/null +++ b/internal/gabriel/aux/2000-FLOATS-TO-READ @@ -0,0 +1 @@ +(89955.03 48956.06 68030.08 41964.414 13708.356 54283.04 52747.215 21308.031 73458.164 98603.19 55239.08 17591.092 33091.242 68570.25 41383.46 52817.05 30803.367 4514.145 29520.025 37694.04 57228.336 43578.047 62744.406 72768.07 7180.015 50824.145 82025.234 24087.127 52167.043 47802.28 18962.111 91771.234 38398.09 49776.484 10382.261 92014.164 36335.066 76775.39 58134.15 937.1107 51552.15 40650.086 10354.196 77993.49 67213.11 22800.055 70197.05 82508.24 16435.021 20218.28 29090.11 94286.484 968.00507 93461.0 22278.393 68819.04 37932.06 62935.035 98236.195 24356.043 7494.19 1926.0354 72596.26 10403.017 60833.426 5143.2476 59728.367 95272.49 42229.305 78528.0 3228.0398 58648.453 108.05118 22057.236 37148.45 92174.12 65194.05 51352.137 49961.082 93120.34 40886.387 14310.119 90661.27 94418.414 62080.266 46392.04 77651.48 87168.016 82727.11 61850.13 38977.19 7492.1235 70110.03 54631.297 24791.33 58332.113 23434.422 25782.174 69115.34 31302.127 65521.445 97074.03 78551.016 45590.07 91673.43 59690.0 54676.023 25433.443 93303.45 2956.3086 98637.15 22634.285 39768.453 36848.49 11910.428 62125.15 44567.06 50120.02 65113.15 64921.07 12774.242 30195.053 80922.125 22509.484 75553.09 51619.414 41609.027 4324.1846 92077.086 70657.12 73910.39 4885.1353 67637.18 40726.098 5305.146 81671.16 90077.22 13329.377 93037.21 11386.096 67358.1 93607.13 70069.01 32313.426 8961.004 97908.44 28336.13 34630.42 14882.027 11273.309 43749.035 44122.03 81642.11 18566.11 78139.39 49646.04 68243.05 21601.309 45973.22 67137.27 57001.33 49898.29 42455.074 72392.35 63238.023 72875.43 98559.21 1188.0908 9355.398 45094.008 43284.46 38786.08 90666.086 74197.13 65584.4 17529.463 59700.15 11558.136 13814.019 20801.139 56432.402 22639.117 95907.48 49077.11 85407.23 10749.004 22458.006 65179.063 83354.055 45997.05 18354.172 391.01755 16770.248 6448.044 203.47803 35697.137 61443.117 72950.13 80100.12 5807.011 66971.24 19311.201 2467.0674 73796.49 46788.06 78779.086 35180.23 75172.41 14468.424 38893.26 49481.12 78665.055 81103.35 5280.0063 57620.027 40297.227 55237.32 1644.0497 51212.36 11721.066 36897.258 73535.09 82326.43 91302.11 45624.06 19827.35 13181.263 62776.188 56939.18 10260.01 25135.205 35286.19 94379.05 80922.35 59288.098 58866.063 19607.09 20992.213 35347.227 55759.043 75917.25 28955.08 27424.322 11321.074 29678.002 97695.266 69102.15 73100.02 44467.457 33577.016 32216.088 58484.426 14709.119 50825.098 42017.47 52701.145 44124.406 93558.32 52294.133 23822.025 63851.13 32065.443 21395.418 32748.094 3404.3384 41161.33 40069.11 17440.3 68260.06 66778.01 12068.083 19302.092 51523.33 99372.11 16605.385 16917.033 33993.184 96240.12 12621.094 470.09772 20695.492 64931.164 32556.02 86591.48 99074.34 69251.46 29148.33 69575.07 24736.188 71192.06 25477.06 18362.002 9014.275 1957.4098 55345.113 58237.355 49892.016 16179.008 71641.414 64175.18 76793.04 38965.105 16431.46 57128.363 17121.438 36125.074 33159.023 12385.04 90779.29 31882.451 97816.28 10321.053 66811.39 12752.105 2992.1255 55494.434 23630.076 62278.453 9463.316 33462.066 58008.355 1288.1459 34043.08 42373.188 57153.004 81431.35 24318.191 53152.15 62445.098 40037.047 91971.336 54775.01 66250.266 99486.22 97317.164 2037.0662 99816.336 32544.238 45944.402 90559.1 71160.47 40384.043 98991.26 61133.43 46065.406 86889.08 94522.1 59476.117 52656.02 4151.027 85226.14 94757.26 1245.0309 18699.3 22574.29 57776.008 46480.12 82473.48 72152.1 13049.122 12029.087 20280.07 25537.434 51977.32 8135.3926 30461.047 91952.21 83845.01 14531.345 34519.28 99631.34 8602.15 54790.043 28684.06 8516.109 39159.363 96415.38 11389.13 69185.336 74264.39 3611.0771 65684.23 78833.1 2213.4924 60957.01 30223.426 51548.04 48489.465 70498.49 72803.16 37701.49 43443.035 13898.498 88613.15 4276.307 55239.145 45909.11 13182.008 21167.441 94019.27 91872.42 40258.184 44138.035 93541.375 27680.135 93451.125 884.0607 2271.4587 67504.1 80029.4 88739.4 56477.016 86918.195 85282.13 68820.06 47066.348 12083.152 82193.33 33291.453 63885.066 44013.035 6493.366 15015.122 21154.455 6624.0283 72245.07 11300.256 1950.3064 5576.1016 56127.082 88279.17 10413.373 85865.09 93929.14 86929.17 47408.188 95879.18 29268.129 86350.24 31622.188 83429.09 48651.32 7941.3755 16708.203 15792.456 53625.273 72515.28 89907.36 40295.4 75191.05 50007.066 34138.492 58140.074 56181.438 22624.072 96137.05 26505.064 31153.129 27611.262 42257.484 18368.242 90501.164 35974.344 77081.086 39591.18 58749.016 92646.32 15305.115 90838.29 3429.0103 89670.28 39425.188 24717.5 10076.067 75337.26 40393.223 73222.49 45690.438 39101.406 55887.227 1524.0836 95922.18 48292.184 24118.457 1264.1555 89280.02 45767.133 17679.377 66073.09 90368.266 6143.2275 20248.18 3947.2527 95897.31 89804.05 80826.44 10719.037 70353.27 78287.25 72151.4 67400.01 16042.446 87996.11 15117.127 93085.07 58381.12 20422.018 65704.18 33089.32 17030.209 81731.5 83305.164 75052.01 73532.03 47487.23 33608.023 12999.009 55266.38 94776.24 7503.43 67597.445 1404.0088 54610.02 10770.274 48705.1 33928.063 39587.023 67237.01 58584.355 87687.3 27676.045 69990.16 37964.113 21586.105 93311.336 56069.203 33441.27 48174.3 82266.49 59868.24 88089.02 26682.404 31419.045 30614.39 77238.22 15790.427 5155.152 17032.404 64836.098 4448.39 16828.004 73580.375 63140.113 89808.195 23675.236 52207.004 49916.082 22152.115 37035.25 36924.043 85981.09 51055.27 80312.1 59350.266 20677.246 91846.055 6466.029 96345.19 52514.21 56076.016 76424.016 19364.006 20717.057 2210.131 59796.15 31099.043 8102.003 11284.027 36047.14 18180.014 9958.016 60486.45 67740.19 34391.477 70136.055 65235.44 35081.12 84212.06 6682.483 11815.455 79794.09 99473.04 93893.266 20700.313 27405.283 25634.191 87404.4 73368.21 48637.027 63186.285 91771.28 35495.113 8882.224 16648.207 15739.414 8631.22 45480.426 62538.074 19171.248 88384.414 40248.25 11804.351 89277.375 14950.124 29148.195 27923.104 75512.12 75983.32 73492.3 42793.156 73217.06 72899.02 75422.02 39093.44 3337.3528 62072.074 19162.375 26712.154 29841.027 82976.31 45679.074 44520.19 61691.066 13818.419 86219.36 98939.04 38672.004 75817.13 76415.2 48566.176 50806.137 5138.0117 83619.086 12413.366 33248.438 35748.367 22600.021 99657.45 86987.26 19511.469 38281.418 41769.07 45874.117 14113.149 53401.203 16068.15 53339.383 18608.31 59137.03 30601.463 26672.14 62702.383 97630.0 17400.227 95811.04 66911.086 85343.12 85007.31 67682.09 86328.016 37849.32 50261.098 42140.14 63913.375 65521.063 13621.051 12977.086 733.0269 65913.18 59607.203 52182.26 86572.39 78084.445 64152.48 22734.05 90738.13 62022.188 35661.47 91711.13 98425.12 54823.44 64824.13 69076.22 15870.152 3745.442 22054.002 73069.5 54078.11 99242.02 27449.072 20372.447 56.49764 70667.32 7981.139 87498.26 80989.016 88727.234 95134.09 42902.45 69016.06 31108.14 31681.377 69990.16 88558.07 39173.11 95442.33 36036.184 30774.473 77099.02 80343.07 84602.21 50804.484 82918.03 38620.46 92656.3 42282.156 16156.22 41485.023 88474.09 46052.246 84965.336 37592.37 67834.03 77075.13 27856.041 4717.3984 96463.43 5453.0356 95416.0 72545.36 45435.066 97946.03 90638.3 77194.02 69308.016 42983.277 3710.1472 27262.379 93034.21 58370.11 67656.03 1516.1195 96773.33 482.1418 70809.41 79990.13 31112.498 76953.06 6512.2363 30322.467 6385.4873 83582.34 287.05667 2266.0269 56250.484 33168.047 62850.125 2004.4001 54340.055 30606.14 68496.086 64563.09 87905.13 5865.1143 48536.445 18476.105 24931.252 34319.29 13807.104 49446.14 55749.16 51378.152 12816.151 40599.28 13412.019 46573.27 79289.08 13597.486 68928.234 91714.12 92457.03 56280.47 79449.44 14326.427 61534.34 29605.385 24631.44 14519.302 94382.32 32853.184 97383.06 2667.2087 26542.209 67844.266 70970.29 63793.254 68384.02 5580.3315 73591.47 12891.1465 44989.043 22464.393 80277.28 4898.2456 14846.192 3078.4639 48811.313 980.42065 78861.25 84428.195 85741.11 50261.418 80774.4 1988.3198 12288.286 82851.11 33000.145 87253.02 1389.0554 36079.16 21703.45 46291.145 56656.395 24281.371 4805.11 96946.086 48927.164 64055.49 12152.032 52435.5 44769.258 63954.125 2682.4878 12101.117 34202.234 91801.13 10962.189 38944.176 69134.47 72387.33 98132.06 53892.457 82408.414 71746.39 39240.113 2811.0872 51337.23 5584.4165 99940.14 48109.008 13604.274 82325.01 8088.022 81767.36 16403.074 89593.234 79230.07 8454.068 4103.4067 18079.11 61591.2 32727.02 92149.47 99433.13 71551.305 89982.16 30646.047 66143.49 4847.298 12194.058 61660.18 97619.44 87473.12 8197.115 5666.356 17242.11 72227.27 21321.06 98852.445 782.17444 90276.35 96027.125 42159.387 82883.164 47452.035 737.2839 83890.02 24851.121 46120.316 85189.02 20109.084 76960.07 30099.123 44913.047 92964.086 70489.27 82934.1 18507.396 61619.344 18866.096 96873.45 33763.117 66956.195 41115.137 30137.227 23917.133 17059.193 7844.0845 44837.082 15120.306 42664.16 43536.027 23896.104 75018.49 98660.07 12751.065 30769.053 20794.313 36525.438 28485.045 79920.21 87063.05 34797.113 35166.316 50386.082 57058.066 53485.004 4726.0747 22608.121 89774.195 76595.08 59714.316 93315.21 53863.277 29976.307 57498.13 63578.297 70230.195 65734.12 49568.418 50815.098 88322.5 18458.04 415.1374 18935.113 76542.34 5557.391 14743.066 90406.01 88763.055 76684.016 25000.207 40977.074 34192.14 11321.453 47965.242 7592.3276 8564.437 46275.04 78797.445 87112.18 72048.39 8480.056 40239.066 53799.22 44899.13 24888.018 22784.494 71406.38 27930.3 36104.066 41246.47 7720.4595 60394.395 81643.14 41608.277 74790.31 42039.297 3426.0298 28107.2 68929.11 25623.49 52028.434 33588.04 6353.4087 10623.072 76065.086 13497.443 37638.477 47439.41 90219.08 14119.057 35407.195 34291.07 54856.47 56525.184 48848.313 74586.28 68260.45 42985.027 33809.258 11905.073 29704.096 78890.06 74808.48 80162.016 847.0066 88626.02 24969.06 51697.26 10727.49 66701.13 6621.1177 63126.383 28486.066 69768.36 2123.3203 998.3156 67678.234 86906.29 29102.094 22490.004 52126.063 79214.42 33862.164 14202.027 90905.03 34777.32 5196.0005 85920.45 82522.14 47399.02 84198.086 25349.293 1163.181 32142.234 94629.5 9478.491 94660.01 14405.267 37120.066 95567.414 96277.07 78608.24 91454.4 24533.45 76104.05 85936.055 63567.027 44136.11 49273.04 71887.234 2844.022 47205.344 71933.0 83520.18 89523.45 77441.05 27695.389 36625.086 88565.06 74843.49 18199.045 2390.385 39567.2 84979.34 70341.14 92156.05 96877.125 72448.055 29258.186 24618.484 42886.02 87271.33 94251.03 45162.164 29467.05 36014.258 37100.086 66867.29 47829.383 99413.16 85201.04 16865.06 80827.4 22020.305 1105.075 96062.01 606.12445 52459.156 18575.158 62385.023 37134.336 21473.104 42988.316 40528.395 6675.1494 49817.34 34835.45 12454.258 58102.145 90351.11 85552.23 71540.16 31869.006 68334.23 79312.414 28081.13 11506.312 73400.3 12559.111 6927.0576 12077.175 19296.352 583.17566 6698.389 43829.07 83306.02 39546.16 4239.0864 54196.13 53845.33 47225.457 22328.107 23249.166 67667.375 68176.09 1850.3787 33251.39 21202.38 51999.08 49545.26 20898.375 5660.002 29944.111 20521.365 58525.223 87527.03 7680.0107 22037.06 53704.406 74352.43 18382.078 86956.13 34149.08 36104.33 57607.188 28197.031 86325.086 9320.047 48612.047 26532.13 27513.37 88306.14 66955.29 86587.1 42120.227 29721.217 39297.184 77682.1 70346.15 20029.129 21158.059 98878.414 48939.023 20812.416 10463.296 26759.15 80939.35 47746.145 24576.06 43535.387 35242.3 14550.399 84743.07 2954.4443 73446.016 65221.105 36462.07 21783.332 22499.322 2781.1147 35996.094 12866.314 6239.3276 5554.0723 78708.02 85663.02 21771.396 94708.195 19763.342 81460.06 59260.1 12008.085 60221.285 70643.11 92459.37 84065.445 64101.164 63529.445 74021.125 66648.1 16637.174 685.4814 23108.176 78181.04 73923.16 51180.473 94713.4 43238.33 42989.363 64829.13 20553.139 7621.437 33975.473 84201.1 78945.164 15512.294 27844.36 16900.299 87646.04 73013.43 28714.258 53772.043 74450.086 77371.05 28421.1 70437.08 61576.086 52901.35 82798.45 25638.193 73535.03 72694.305 34462.09 24203.46 82694.016 64074.15 33475.426 44228.066 7249.073 89893.484 9089.474 48245.45 30927.143 75395.15 96510.03 9961.069 66238.484 23848.22 86383.086 81105.016 78931.25 75970.03 48480.008 88418.38 34397.12 49030.273 42038.063 89306.32 27093.078 86245.12 23361.105 96298.4 4102.3677 61033.0 39068.26 88770.46 67180.055 24636.066 94001.15 55249.465 54058.145 14230.236 6289.3423 25622.203 54266.27 55151.02 62792.38 34474.12 58014.434 58687.4 1288.0579 38195.063 14817.39 48984.24 18864.088 1320.1527 36516.39 97593.016 2353.4443 83900.05 60518.113 14251.421 61787.117 58880.46 90577.37 54970.074 78400.055 89677.49 46831.195 53940.387 59579.035 77624.07 15653.109 97985.016 2844.4001 2680.0422 69688.48 89679.42 14936.131 83953.43 17888.133 50094.137 74320.305 78203.12 51495.117 73578.18 19430.057 21288.049 69421.09 12271.483 82352.414 44843.14 9025.281 8399.366 71461.02 35343.375 49893.184 67947.42 49971.14 89312.24 2331.1492 69513.016 76233.16 55191.14 27022.096 99120.04 31490.088 50973.367 43643.125 38133.086 62465.07 699.30316 28763.344 75806.01 90483.23 3044.2903 50790.258 22526.215 2942.2227 94133.18 30190.186 93641.125 74520.305 30279.1 30144.047 49220.176 42741.133 73657.48 89988.12 36395.184 12750.059 87146.29 57066.223 7316.023 44700.32 65085.105 16543.072 67190.46 5373.1514 28890.365 61842.477 96731.27 56885.457 17399.04 62478.473 4185.0205 34315.086 88324.01 51393.375 25339.207 35287.07 56771.21 25266.21 12694.248 79207.125 50182.13 20614.445 29435.102 97812.22 38875.055 45013.277 67477.414 27935.223 88459.08 47924.203 15749.038 11948.126 38335.004 54419.12 21359.328 81730.35 76350.43 96719.27 39703.207 95608.4 59655.355 41672.496 96478.25 97763.2 65800.09 51372.004 69895.02 13669.163 18536.102 50315.11 73740.445 96111.02 39425.09 82872.01 757.1098 51449.004 80486.125 89458.04 34404.12 67490.1 8743.2295 97388.47 35922.188 27015.467 45871.105 15003.323 72105.41 87743.31 82357.42 12133.399 79508.5 78423.14 68990.02 87929.42 86804.08 1651.3765 29561.113 16612.137 25624.314 38300.023 1499.0695 88966.195 31162.266 58409.453 8161.4194 97403.07 93894.05 30077.365 34244.23 32136.027 73601.43 80581.445 29958.406 56317.266 6226.08 67336.0 312.38785 10899.002 16883.38 83160.31 1072.4198 45870.355 65162.082 31319.137 62409.42 45233.027 16520.06 19449.393 76568.12 60306.387 99955.086 7416.049 22744.205 17138.164 26019.135 79042.06 77658.03 32656.32 66549.11 75498.14 20529.03 84369.4 77507.28 13493.054 44506.03 51311.426 12159.404 98345.03 91949.1 36247.094 55101.043 15991.445 76146.375 55094.05 10500.058 56665.46 95758.125 32108.121 76246.01 57744.08 98647.3 4158.0156 63481.176 38155.063 97046.33 79318.06 31909.373 34102.06 75487.086 5774.341 28856.102 28710.35 29291.123 64438.152 43022.145 14932.149 72082.086 34807.313 53316.477 97568.35 26375.277 43541.39 55356.11 8204.174 60109.055 75744.19 21721.41 89537.13 71397.02 26224.08 38040.035 77585.164 21191.135 7501.249 84619.02 36056.016 87100.15 83771.01 84252.34 96388.02 79069.484 41460.465 71726.49 68955.45 64071.297 88377.2 85597.086 63298.02 2207.202 34714.43 40232.445 25594.338 63063.164 59956.227 39113.027 72358.19 3115.0024 39405.34 39025.016 17600.14 28159.023 31927.396 97044.16 84519.086 71827.06 21973.21 2381.1477 87480.01 14946.058 54645.438 27229.436 68045.0 21258.064 40521.18 38698.4 94496.34 60472.43 92067.11 24004.371 47636.387 89965.07 31799.14 85491.15 72513.445 15683.127 54982.156 72784.38 67293.41 28794.43 11364.222 77566.5 38293.12 45125.184 20475.445 38342.063 27118.04 93157.305 4056.3777 72615.1 57451.41 50901.496 88939.38 51160.13 57175.063 4232.3477 27439.088 18166.494 29012.453 51270.21 55625.434 97229.13 80999.04 64182.27 1006.08594 92758.23 57923.492 49277.313 99225.125 22521.287 80433.01 93510.12 21822.014 20555.248 93843.27 70612.09 9355.118 45881.11 13486.386 15761.037 54667.3 66804.09 67588.02 96365.195 34324.348 26577.043 8610.43 92021.234 65907.16 18172.137 93540.18 35450.313 44184.094 54080.426 2501.0935 38750.035 81733.28 99437.45 7656.1787 1660.2938 73358.445 31899.242 77041.33 6021.2275 76246.47 92139.266 77513.26 23508.434 49076.23 22110.492 94292.03 24684.098 56425.043 43691.117 57411.305 97824.08 13968.018 98957.42 15636.077 71986.1 22174.313 95931.086 13538.0625 79688.414 86605.04 41825.21 32535.154 56011.035 70417.164 99280.125 16860.492 81504.25 81022.01 61127.42 32869.152 36994.26 69212.125 25140.465 396.10852 22879.064 77686.05 24316.463 61243.152 69501.28 27549.307 31437.125 10820.385 10706.445 94428.375 44886.15 16339.183 64900.395 8133.2524 39385.11 41536.465 60107.117 61120.113 91221.15 1411.1528 40797.063 40202.055 44746.02 87108.12 21168.016 78505.13 29516.158 49466.406 5646.2783 23665.074 37708.367 95541.375 51664.402 23273.197 53346.1 41016.105 40179.125 63596.074 71392.04 93934.12 16847.219 70908.04 45023.496 14628.035 88245.414 9325.073 35377.453 4609.001 46717.047 27905.35 97256.484 92644.055 88879.4 55709.24 93986.47 32933.16 18548.035 19276.137 67611.055 95678.08 28160.096 81095.13 50460.074 73419.25 11560.298 45913.105 93751.41 42062.08 35816.387 21488.37 85564.46 4403.474 62402.125 56927.3 46972.297 21556.18 76835.02 47622.113 33.2782 27287.068 67626.016 81903.42 78697.055 85190.11 8389.14 12753.16 36952.258 58441.473 78912.01 9096.357 57954.05 14178.265 27901.012 95791.1 17333.047 36545.355 28097.291 58755.0 60681.04 43862.055 74562.375 8834.203 92501.12 14142.331 73261.32 83174.13 62699.316 48987.293 24684.23 69517.37 74560.06 46694.0 28567.02 98205.12 35177.496 8537.133 7139.36 73000.016 20449.293 98667.02 2624.0898 99232.016 43424.477 1771.0555 38454.3 154.01141 4869.159 38021.297 88900.12 33111.06 88823.016 76713.46 16460.385 23019.111 3326.185 79214.016 62285.492 30943.225 10726.299 55843.027 96515.2 50770.215 11975.403 19770.295 71360.234 84114.375 63666.15 38887.055 13729.199 16754.266 77463.09 39579.45 63989.414 94361.086 6619.12 87499.125 46922.1 52844.133 37452.355 69137.12 32792.47 33245.434 68736.22 31868.418 38334.453 46419.047 28914.05 64501.332 30058.328 71386.27 15006.124 7262.2417 13431.297 88141.08 49957.418 97314.46 73053.13 45527.44 74680.04 9041.365 84507.08 50252.332 73639.125 52347.387 69647.2 18923.24 23815.094 48611.152 17311.13 73688.1 60590.223 87695.14 22884.383 17599.115 13990.061 36524.383 54071.066 44066.09 33007.164 97273.414 15843.05 35764.08 36825.05 326.05963 49128.383 44785.387 73192.336 43091.027 52127.313 88913.43 41945.117 21748.055 74593.195 19671.48 18564.041 98756.43 74835.12 76220.38 89991.45 9895.437 79466.12 72364.45 26825.178 34025.38 80672.29 68657.195 71050.29 69877.04 19380.033 17245.096 86455.4 70856.02 8385.203 57144.12 59856.02 53404.086 39512.063 84447.13 71540.04 18013.064 41410.223 27122.053 99875.086 96532.31 50863.426 74833.23 44746.09 63528.16 47371.023 58026.14 86827.15 71507.086 30293.246 88699.05 42925.273 39252.094 98140.03 33960.152 53143.086 89194.19 4793.0825 67977.14 39423.31 86688.09 80048.08 87231.45 47960.195 10367.007 67325.06 34937.09 679.0118 67752.49 81789.13 12956.078 13745.038 35138.25 30382.07 22690.156 79645.01 28759.432 14971.496 49410.21 69624.37 44996.156 4713.0855 7118.03 647.1456 86289.195 49090.484 89388.31 56864.39 9994.087 89646.15 27003.164 56983.105) \ No newline at end of file diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS b/internal/gabriel/benchmarks/ARITH-BENCHMARKS new file mode 100644 index 00000000..2a4d63ea --- /dev/null +++ b/internal/gabriel/benchmarks/ARITH-BENCHMARKS @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "29-Jun-88 18:01:48" "{ERIS}Gabriel>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 00000000..0c9c6c1d Binary files /dev/null and b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL differ diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~1~ b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~1~ new file mode 100644 index 00000000..1cf1692b Binary files /dev/null and b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~1~ differ diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~2~ b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~2~ new file mode 100644 index 00000000..34ce95aa Binary files /dev/null and b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~2~ differ diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~3~ b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~3~ new file mode 100644 index 00000000..06d099ab Binary files /dev/null and b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~3~ differ diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~4~ b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~4~ new file mode 100644 index 00000000..7d9d720f Binary files /dev/null and b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~4~ differ diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~5~ b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~5~ new file mode 100644 index 00000000..0c9c6c1d Binary files /dev/null and b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.DFASL.~5~ differ diff --git a/internal/gabriel/benchmarks/ARITH-BENCHMARKS.LCOM b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.LCOM new file mode 100644 index 00000000..dadbb4b6 Binary files /dev/null and b/internal/gabriel/benchmarks/ARITH-BENCHMARKS.LCOM differ 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 00000000..d5201f3e Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-OTHER.LCOM differ diff --git a/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl new file mode 100644 index 00000000..c12d5629 Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl differ diff --git a/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~1~ b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~1~ new file mode 100644 index 00000000..d573d517 Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~1~ differ diff --git a/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~2~ b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~2~ new file mode 100644 index 00000000..38fa53c6 Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~2~ differ diff --git a/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~3~ b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~3~ new file mode 100644 index 00000000..abeddcd6 Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~3~ differ diff --git a/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~4~ b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~4~ new file mode 100644 index 00000000..c12d5629 Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-OTHER.dfasl.~4~ differ 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 00000000..cdb406b7 Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-TAK.LCOM differ diff --git a/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl new file mode 100644 index 00000000..03a84f7a Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl differ diff --git a/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~1~ b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~1~ new file mode 100644 index 00000000..a09c5be3 Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~1~ differ diff --git a/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~2~ b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~2~ new file mode 100644 index 00000000..f4d44ad5 Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~2~ differ diff --git a/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~3~ b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~3~ new file mode 100644 index 00000000..bc0d34a2 Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~3~ differ diff --git a/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~4~ b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~4~ new file mode 100644 index 00000000..03a84f7a Binary files /dev/null and b/internal/gabriel/benchmarks/GABRIEL-TAK.dfasl.~4~ differ 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 00000000..ae0a6d96 Binary files /dev/null and b/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL differ diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~1~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~1~ new file mode 100644 index 00000000..e0509938 Binary files /dev/null and b/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~1~ differ diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~2~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~2~ new file mode 100644 index 00000000..ae0a6d96 Binary files /dev/null and b/internal/gabriel/benchmarks/IO-BENCHMARKS.DFASL.~2~ differ 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 00000000..ea517892 Binary files /dev/null and b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~1~ differ diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~2~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~2~ new file mode 100644 index 00000000..79ce4214 Binary files /dev/null and b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~2~ differ diff --git a/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~3~ b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~3~ new file mode 100644 index 00000000..f7a6c16d Binary files /dev/null and b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~3~ differ 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 00000000..6fecd5dd Binary files /dev/null and b/internal/gabriel/benchmarks/IO-BENCHMARKS.LCOM.~6~ differ 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 00000000..ec8e03ce Binary files /dev/null and b/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL differ diff --git a/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~1~ b/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~1~ new file mode 100644 index 00000000..d24f5bc5 Binary files /dev/null and b/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~1~ differ diff --git a/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~2~ b/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~2~ new file mode 100644 index 00000000..cf1659a8 Binary files /dev/null and b/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~2~ differ diff --git a/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~3~ b/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~3~ new file mode 100644 index 00000000..ec8e03ce Binary files /dev/null and b/internal/gabriel/benchmarks/MISC-BENCHMARKS.DFASL.~3~ differ diff --git a/internal/gabriel/benchmarks/MISC-BENCHMARKS.LCOM b/internal/gabriel/benchmarks/MISC-BENCHMARKS.LCOM new file mode 100644 index 00000000..b98119cc --- /dev/null +++ b/internal/gabriel/benchmarks/MISC-BENCHMARKS.LCOM @@ -0,0 +1,22 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") +(FILECREATED "30-Jun-88 13:27:51" ("compiled on " +"{ERIS}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 00000000..ef08934b Binary files /dev/null and b/internal/gabriel/benchmarks/Medley/GABRIEL-OTHER.DFASL differ diff --git a/internal/gabriel/benchmarks/Medley/GABRIEL-OTHER.LCOM b/internal/gabriel/benchmarks/Medley/GABRIEL-OTHER.LCOM new file mode 100644 index 00000000..80f1dfb9 Binary files /dev/null and b/internal/gabriel/benchmarks/Medley/GABRIEL-OTHER.LCOM differ diff --git a/internal/gabriel/benchmarks/Medley/GABRIEL-TAK.DFASL b/internal/gabriel/benchmarks/Medley/GABRIEL-TAK.DFASL new file mode 100644 index 00000000..a09c5be3 Binary files /dev/null and b/internal/gabriel/benchmarks/Medley/GABRIEL-TAK.DFASL differ diff --git a/internal/gabriel/benchmarks/Medley/GABRIEL-TAK.LCOM b/internal/gabriel/benchmarks/Medley/GABRIEL-TAK.LCOM new file mode 100644 index 00000000..cdb406b7 Binary files /dev/null and b/internal/gabriel/benchmarks/Medley/GABRIEL-TAK.LCOM differ diff --git a/internal/gabriel/benchmarks/Medley/GABRIEL-TIMERS.LCOM b/internal/gabriel/benchmarks/Medley/GABRIEL-TIMERS.LCOM new file mode 100644 index 00000000..dcb5d18f Binary files /dev/null and b/internal/gabriel/benchmarks/Medley/GABRIEL-TIMERS.LCOM differ 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/ttUU4hU.U4hUC.4 +uUU/457toUU4hUi))U-t/յ4 +uUU7?t/ttUUMhUUMhUw7UMhU4 +uUU7?t/ttUuw7UUMhU) (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$XlO?%'*), +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 00000000..ae57ee8f Binary files /dev/null and b/internal/gabriel/interlisp/DERIV.LCOM differ diff --git a/internal/gabriel/interlisp/DESTRUCTIVE b/internal/gabriel/interlisp/DESTRUCTIVE new file mode 100644 index 00000000..682c5688 --- /dev/null +++ b/internal/gabriel/interlisp/DESTRUCTIVE @@ -0,0 +1 @@ +(FILECREATED " 7-Nov-85 00:50:55" {QV}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 00000000..b409b8d0 Binary files /dev/null and b/internal/gabriel/interlisp/DESTRUCTIVE.LCOM differ 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 00000000..da793caa Binary files /dev/null and b/internal/gabriel/interlisp/DIV2.LCOM differ diff --git a/internal/gabriel/interlisp/FFT b/internal/gabriel/interlisp/FFT new file mode 100644 index 00000000..bfaf1bc6 --- /dev/null +++ b/internal/gabriel/interlisp/FFT @@ -0,0 +1 @@ +(FILECREATED "15-Nov-85 17:41:43" {QV}BENCHMARKS>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 00000000..05568c97 Binary files /dev/null and b/internal/gabriel/interlisp/TRAVERSE.LCOM differ 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 00000000..3552ce68 Binary files /dev/null and b/internal/gabriel/interlisp/benchmarkmemo.tedit differ diff --git a/internal/gabriel/interlisp/dderiv.lcom b/internal/gabriel/interlisp/dderiv.lcom new file mode 100644 index 00000000..96a4dc4b Binary files /dev/null and b/internal/gabriel/interlisp/dderiv.lcom differ diff --git a/internal/gabriel/tools/BENCH-1 b/internal/gabriel/tools/BENCH-1 new file mode 100644 index 00000000..6a1073d2 --- /dev/null +++ b/internal/gabriel/tools/BENCH-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 {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 00000000..dcb5d18f Binary files /dev/null and b/internal/gabriel/tools/GABRIEL-TIMERS.LCOM.~1~ differ 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 00000000..a1f70e99 Binary files /dev/null and b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl differ diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~1~ b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~1~ new file mode 100644 index 00000000..de3f95f8 Binary files /dev/null and b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~1~ differ diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~2~ b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~2~ new file mode 100644 index 00000000..1b850727 Binary files /dev/null and b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~2~ differ diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~3~ b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~3~ new file mode 100644 index 00000000..f78a8ae5 Binary files /dev/null and b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~3~ differ diff --git a/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~4~ b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~4~ new file mode 100644 index 00000000..a1f70e99 Binary files /dev/null and b/internal/gabriel/tools/GABRIEL-TIMERS.dfasl.~4~ differ 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 00000000..ec17ca3a Binary files /dev/null and b/internal/test/.read-me-first differ diff --git a/internal/test/4045/Hand-Aux/Justification-TEst.TEdit b/internal/test/4045/Hand-Aux/Justification-TEst.TEdit new file mode 100644 index 00000000..005e8d4f Binary files /dev/null and b/internal/test/4045/Hand-Aux/Justification-TEst.TEdit differ diff --git a/internal/test/ARs/.read-me-first b/internal/test/ARs/.read-me-first new file mode 100644 index 00000000..367d0e4a Binary files /dev/null and b/internal/test/ARs/.read-me-first differ diff --git a/internal/test/ARs/.read-me-first.~1~ b/internal/test/ARs/.read-me-first.~1~ new file mode 100644 index 00000000..1ad7c1e7 Binary files /dev/null and b/internal/test/ARs/.read-me-first.~1~ differ diff --git a/internal/test/ARs/.read-me-first.~2~ b/internal/test/ARs/.read-me-first.~2~ new file mode 100644 index 00000000..367d0e4a Binary files /dev/null and b/internal/test/ARs/.read-me-first.~2~ differ diff --git a/internal/test/ARs/AR-Test-Case-Summary-Template.TEdit b/internal/test/ARs/AR-Test-Case-Summary-Template.TEdit new file mode 100644 index 00000000..9332c398 Binary files /dev/null and b/internal/test/ARs/AR-Test-Case-Summary-Template.TEdit differ 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 00000000..4e139f2e Binary files /dev/null and b/internal/test/GC/HAND-AUX/ADVDICT-N-Z.TEDIT differ 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 00000000..f7a00dde Binary files /dev/null and b/internal/test/GC/HAND-AUX/DANCER10-C0.DISPLAYFONT differ 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 00000000..9ae49c75 Binary files /dev/null and b/internal/test/GC/HAND-AUX/Dancer12-C0.DisplayFont differ 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 00000000..89a31583 Binary files /dev/null and b/internal/test/GC/HAND-AUX/dancer10-C0.WD differ 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 00000000..87a92132 Binary files /dev/null and b/internal/test/GC/HAND-AUX/dancer12-c0.wd differ 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 00000000..6f1a3a31 Binary files /dev/null and b/internal/test/GC/Hand/DANCEROBJ.LCOM differ diff --git a/internal/test/GC/Hand/MAIKO-GC-TESTS b/internal/test/GC/Hand/MAIKO-GC-TESTS new file mode 100644 index 00000000..d8df862f --- /dev/null +++ b/internal/test/GC/Hand/MAIKO-GC-TESTS @@ -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.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 00000000..ad86f35d Binary files /dev/null and b/internal/test/GC/Hand/MAIKO-GC-TESTS.LCOM differ 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 00000000..490f0d8c Binary files /dev/null and b/internal/test/IO/Auto/IO-REGRESSION.TEST differ diff --git a/internal/test/IO/Auto/MSPF.TEST b/internal/test/IO/Auto/MSPF.TEST new file mode 100644 index 00000000..12ecfaea Binary files /dev/null and b/internal/test/IO/Auto/MSPF.TEST differ 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 00000000..9255877f Binary files /dev/null and b/internal/test/IO/Hand-Aux/AR11004-Arith-OFlow.IP differ diff --git a/internal/test/LANGUAGE/AUTO/.read-me-first b/internal/test/LANGUAGE/AUTO/.read-me-first new file mode 100644 index 00000000..d5281f83 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/.read-me-first @@ -0,0 +1 @@ +This file obsolete, see: {ERIS}.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 00000000..c3012707 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/.read-me-first.~1~ differ 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 00000000..bc20495e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.DFASL differ 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 00000000..8190a18d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-1-GET.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/10-1-GET.TEST b/internal/test/LANGUAGE/AUTO/10-1-GET.TEST new file mode 100644 index 00000000..959cdc6e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/10-1-GETF.DFASL b/internal/test/LANGUAGE/AUTO/10-1-GETF.DFASL new file mode 100644 index 00000000..a64b46f2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-1-GETF.DFASL differ 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 00000000..d48beabb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-1-REMF.DFASL differ 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 00000000..99dfb0ce Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-1-REMPROP.DFASL differ 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 00000000..2a4f746c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.TEST b/internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.TEST new file mode 100644 index 00000000..1f97d9cb --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/10-2-SYMBOL-NAME.DFASL b/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.DFASL new file mode 100644 index 00000000..df5817be Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.DFASL differ 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 00000000..72776bb3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.DFASL differ 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 00000000..f58e197d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-3-GENSYM.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/10-3-GENSYM.TEST b/internal/test/LANGUAGE/AUTO/10-3-GENSYM.TEST new file mode 100644 index 00000000..4f1ab42a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-3-GENSYM.TEST differ 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 00000000..91fcafb4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-3-GENTEMP.DFASL differ 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 00000000..10a0b242 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.DFASL differ 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 00000000..425dc7d4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.DFASL differ 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 00000000..1ac880d5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.DFASL differ 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 00000000..28d8969a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-6-IMPORT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-6-IMPORT.TEST b/internal/test/LANGUAGE/AUTO/11-6-IMPORT.TEST new file mode 100644 index 00000000..e15c3909 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/11-7-DO-ALL-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.DFASL new file mode 100644 index 00000000..662895b8 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.DFASL differ 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 00000000..d46292b0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.DFASL differ 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 00000000..24700b43 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.DFASL differ 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 00000000..fb742032 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-EXPORT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-7-EXPORT.TEST b/internal/test/LANGUAGE/AUTO/11-7-EXPORT.TEST new file mode 100644 index 00000000..a3e1e450 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/11-7-FIND-ALL-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.DFASL new file mode 100644 index 00000000..1c29266f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.TEST b/internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.TEST new file mode 100644 index 00000000..3ff17cad --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/11-7-FIND-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.DFASL new file mode 100644 index 00000000..fe0896f3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.TEST b/internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.TEST new file mode 100644 index 00000000..f229d7df --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/11-7-FIND-SYMBOL.DFASL b/internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.DFASL new file mode 100644 index 00000000..e185e8c8 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.TEST b/internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.TEST new file mode 100644 index 00000000..cee00adc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/11-7-IMPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-7-IMPORT.DFASL new file mode 100644 index 00000000..cab7952b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-IMPORT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-7-IMPORT.TEST b/internal/test/LANGUAGE/AUTO/11-7-IMPORT.TEST new file mode 100644 index 00000000..d9287be0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/11-7-IN-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.DFASL new file mode 100644 index 00000000..6127e649 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.DFASL differ 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 00000000..c10ba974 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-INTERN.DFASL differ 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 00000000..5e155506 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.TEST b/internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.TEST new file mode 100644 index 00000000..7db42315 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/11-7-MAKE-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.DFASL new file mode 100644 index 00000000..88070d30 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.DFASL differ 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 00000000..a64c827e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.DFASL differ 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 00000000..33ad1be1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.DFASL differ 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 00000000..cd484fc1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.TEST b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.TEST new file mode 100644 index 00000000..97f76cce --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/11-7-PACKAGE-USE-LIST.DFASL b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.DFASL new file mode 100644 index 00000000..ed56cc99 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.TEST b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.TEST new file mode 100644 index 00000000..6427cb03 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..d44cbb36 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USED-BY-LIST.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USED-BY-LIST.TEST b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USED-BY-LIST.TEST new file mode 100644 index 00000000..b35e8100 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/11-7-RENAME-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.DFASL new file mode 100644 index 00000000..a0450ce7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.TEST b/internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.TEST new file mode 100644 index 00000000..16f94ec3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/11-7-SHADOW.DFASL b/internal/test/LANGUAGE/AUTO/11-7-SHADOW.DFASL new file mode 100644 index 00000000..f75aa46c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-SHADOW.DFASL differ 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 00000000..b020270d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.TEST b/internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.TEST new file mode 100644 index 00000000..0ccbff6a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/11-7-UNEXPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.DFASL new file mode 100644 index 00000000..b249238a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.DFASL differ 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 00000000..8f9c0e12 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-UNINTERN.DFASL differ 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 00000000..f796c55c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.DFASL differ 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 00000000..3af07b5c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.DFASL differ 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 00000000..9c4b403e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/11-8-PROVIDE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/11-8-PROVIDE.TEST b/internal/test/LANGUAGE/AUTO/11-8-PROVIDE.TEST new file mode 100644 index 00000000..ac656502 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-10-IMPLEMENTATION-PARAMETERS.DFASL b/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.DFASL new file mode 100644 index 00000000..e6ebcf6c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.DFASL differ 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 00000000..6c263796 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-2-EVENP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-2-EVENP.TEST b/internal/test/LANGUAGE/AUTO/12-2-EVENP.TEST new file mode 100644 index 00000000..46401116 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-2-EVENP.TST b/internal/test/LANGUAGE/AUTO/12-2-EVENP.TST new file mode 100644 index 00000000..968e3cb9 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-2-EVENP.TST differ diff --git a/internal/test/LANGUAGE/AUTO/12-2-MINUSP.DFASL b/internal/test/LANGUAGE/AUTO/12-2-MINUSP.DFASL new file mode 100644 index 00000000..87636c1c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-2-MINUSP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-2-MINUSP.TEST b/internal/test/LANGUAGE/AUTO/12-2-MINUSP.TEST new file mode 100644 index 00000000..fcc37363 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-2-MINUSP.TST b/internal/test/LANGUAGE/AUTO/12-2-MINUSP.TST new file mode 100644 index 00000000..0fbea9ab Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-2-MINUSP.TST differ diff --git a/internal/test/LANGUAGE/AUTO/12-2-ODDP.DFASL b/internal/test/LANGUAGE/AUTO/12-2-ODDP.DFASL new file mode 100644 index 00000000..0677139e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-2-ODDP.DFASL differ 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 00000000..06fc9b89 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-2-ODDP.TST differ 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 00000000..fd398704 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-2-PLUSP.DFASL differ 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 00000000..3a8decc7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-2-PLUSP.TST differ 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 00000000..96004e1e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-2-ZEROP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-2-ZEROP.TEST b/internal/test/LANGUAGE/AUTO/12-2-ZEROP.TEST new file mode 100644 index 00000000..87266fe5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-2-ZEROP.TXT b/internal/test/LANGUAGE/AUTO/12-2-ZEROP.TXT new file mode 100644 index 00000000..d2c36234 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-2-ZEROP.TXT differ diff --git a/internal/test/LANGUAGE/AUTO/12-3-EQP.DFASL b/internal/test/LANGUAGE/AUTO/12-3-EQP.DFASL new file mode 100644 index 00000000..1f323114 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-3-EQP.DFASL differ 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 00000000..af8b8189 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-3-GEQ.DFASL differ 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 00000000..d315d2f4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-3-GREATERP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-3-GREATERP.TEST b/internal/test/LANGUAGE/AUTO/12-3-GREATERP.TEST new file mode 100644 index 00000000..dc22e12c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-3-LEQ.DFASL b/internal/test/LANGUAGE/AUTO/12-3-LEQ.DFASL new file mode 100644 index 00000000..04fddfc1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-3-LEQ.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-3-LEQ.TEST b/internal/test/LANGUAGE/AUTO/12-3-LEQ.TEST new file mode 100644 index 00000000..622be6e2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-3-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/12-3-LESSP.DFASL new file mode 100644 index 00000000..7d272754 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-3-LESSP.DFASL differ 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 00000000..b0c4dc13 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-3-MAX.DFASL differ 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 00000000..d6ea5edf Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-3-MIN.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-3-MIN.TEST b/internal/test/LANGUAGE/AUTO/12-3-MIN.TEST new file mode 100644 index 00000000..c918592c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-3-MONOTONIC-NONDECREASE.TEST b/internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONDECREASE.TEST new file mode 100644 index 00000000..cc70f120 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONDECREASE.TEST differ 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 00000000..11e6c5cb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONINCREASE.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/12-3-NEQP.DFASL b/internal/test/LANGUAGE/AUTO/12-3-NEQP.DFASL new file mode 100644 index 00000000..d2727e0c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-3-NEQP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-3-NEQP.TEST b/internal/test/LANGUAGE/AUTO/12-3-NEQP.TEST new file mode 100644 index 00000000..5af4e7c1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-4-+.DFASL b/internal/test/LANGUAGE/AUTO/12-4-+.DFASL new file mode 100644 index 00000000..7bb06066 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4-+.DFASL differ 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 00000000..9a86d40c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4--.DFASL differ 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 00000000..26a3b123 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4-1+.DFASL differ 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 00000000..d291e91a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4-1-.DFASL differ 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..c134f6a1 --- /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 ;; ;; 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/AUTO/12-4-CONJUGATE.DFASL b/internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.DFASL new file mode 100644 index 00000000..b1af9267 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.TEST b/internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.TEST new file mode 100644 index 00000000..9973e736 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-4-DECF.DFASL b/internal/test/LANGUAGE/AUTO/12-4-DECF.DFASL new file mode 100644 index 00000000..639240c2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4-DECF.DFASL differ 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 00000000..1a7d2aac Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4-GCD.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-4-GCD.TEST b/internal/test/LANGUAGE/AUTO/12-4-GCD.TEST new file mode 100644 index 00000000..26848e4a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-4-INCF.DFASL b/internal/test/LANGUAGE/AUTO/12-4-INCF.DFASL new file mode 100644 index 00000000..645e96c5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4-INCF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-4-INCF.TEST b/internal/test/LANGUAGE/AUTO/12-4-INCF.TEST new file mode 100644 index 00000000..85a1ab44 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-4-LCM.DFASL b/internal/test/LANGUAGE/AUTO/12-4-LCM.DFASL new file mode 100644 index 00000000..8406d795 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4-LCM.DFASL differ 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 00000000..1330a09d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.DFASL differ 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 00000000..bbcf662e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.TEST differ 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 00000000..5d0f26f6 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-4-TIMES.DFASL differ 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 00000000..134ccfa5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-1-EXP.DFASL differ 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 00000000..97023147 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-1-EXPT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-EXPT.TEST b/internal/test/LANGUAGE/AUTO/12-5-1-EXPT.TEST new file mode 100644 index 00000000..c3be36f7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-5-1-ISQRT.DFASL b/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.DFASL new file mode 100644 index 00000000..31064a09 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.DFASL differ 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 00000000..52cb5ad4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-1-LOG.DFASL differ 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 00000000..5d9bef85 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-1-SQRT.DFASL differ 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 00000000..a85443eb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-ABS.DFASL differ 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 00000000..af7bfde0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-ACOS.DFASL differ 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 00000000..0babd097 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.DFASL differ 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 00000000..c127ce2a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-ASIN.DFASL differ 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 00000000..56d9b955 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-ASINH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ASINH.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-ASINH.TEST new file mode 100644 index 00000000..7e9d9eee --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-5-2-ATAN.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ATAN.DFASL new file mode 100644 index 00000000..7d003a92 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-ATAN.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ATAN.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-ATAN.TEST new file mode 100644 index 00000000..f38d1e37 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-5-2-ATANH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ATANH.DFASL new file mode 100644 index 00000000..7a4bd970 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-ATANH.DFASL differ 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 00000000..2e4e2164 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-CIS.DFASL differ 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 00000000..1500e6ca Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-COS.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-COS.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-COS.TEST new file mode 100644 index 00000000..043e71bf --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-5-2-COSH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-COSH.DFASL new file mode 100644 index 00000000..5d7190ef Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-COSH.DFASL differ 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 00000000..4695723c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-PHASE.DFASL differ 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 00000000..866665fb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.DFASL differ 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 00000000..2bf84756 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-SIN.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-SIN.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-SIN.TEST new file mode 100644 index 00000000..c829d0ee --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-5-2-SINH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-SINH.DFASL new file mode 100644 index 00000000..70a98602 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-SINH.DFASL differ 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 00000000..5f9aab29 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-TAN.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-TAN.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-TAN.TEST new file mode 100644 index 00000000..2f679949 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-5-2-TANH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-TANH.DFASL new file mode 100644 index 00000000..1cfaf94f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-5-2-TANH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-TANH.TEST b/internal/test/LANGUAGE/AUTO/12-5-2-TANH.TEST new file mode 100644 index 00000000..0a13db09 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-6-CEILING.DFASL b/internal/test/LANGUAGE/AUTO/12-6-CEILING.DFASL new file mode 100644 index 00000000..27798b65 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-CEILING.DFASL differ 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 00000000..861ea10f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-COMPLEX.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-6-COMPLEX.TEST b/internal/test/LANGUAGE/AUTO/12-6-COMPLEX.TEST new file mode 100644 index 00000000..1b6d4e9a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-6-DECODE-FLOAT.DFASL b/internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.DFASL new file mode 100644 index 00000000..3fcbb3d5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.TEST b/internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.TEST new file mode 100644 index 00000000..92e82a1d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-6-DENOMINATOR.DFASL b/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.DFASL new file mode 100644 index 00000000..c709c252 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.DFASL differ 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 00000000..0bd76882 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-FCEILING.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-6-FCEILING.TEST b/internal/test/LANGUAGE/AUTO/12-6-FCEILING.TEST new file mode 100644 index 00000000..dac989fd --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-6-FFLOOR.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.DFASL new file mode 100644 index 00000000..82b5029b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.DFASL differ 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 00000000..c74fc801 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.TEST b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.TEST new file mode 100644 index 00000000..626a9b2e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-6-FLOAT-PRECISION.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.DFASL new file mode 100644 index 00000000..052268f2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.DFASL differ 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 00000000..fbb1a041 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.TEST b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.TEST new file mode 100644 index 00000000..a2d85fbf --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-6-FLOAT-SIGN.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.DFASL new file mode 100644 index 00000000..a282844d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.DFASL differ 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 00000000..d79f7f56 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-FLOAT.DFASL differ 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 00000000..55806686 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-FLOOR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOOR.TEST b/internal/test/LANGUAGE/AUTO/12-6-FLOOR.TEST new file mode 100644 index 00000000..0ed5c8cc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-6-FROUND.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FROUND.DFASL new file mode 100644 index 00000000..92698194 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-FROUND.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-6-FROUND.TEST b/internal/test/LANGUAGE/AUTO/12-6-FROUND.TEST new file mode 100644 index 00000000..b3da9296 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-6-FTRUNCATE.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.DFASL new file mode 100644 index 00000000..48cbc0ca Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.DFASL differ 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 00000000..e5b3fe50 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-IMAGPART.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-6-IMAGPART.TEST b/internal/test/LANGUAGE/AUTO/12-6-IMAGPART.TEST new file mode 100644 index 00000000..ac90f5b1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-6-INTEGER-DECODE-FLOAT.DFASL b/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.DFASL new file mode 100644 index 00000000..eb99080e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.DFASL differ 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 00000000..ebd1d962 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-MOD.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-6-MOD.TEST b/internal/test/LANGUAGE/AUTO/12-6-MOD.TEST new file mode 100644 index 00000000..4486d09b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-6-NUMERATOR.DFASL b/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.DFASL new file mode 100644 index 00000000..fa5a2d8a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.DFASL differ 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 00000000..62b206bf Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-RATIONAL.DFASL differ 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 00000000..863ee24d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.DFASL differ 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 00000000..859b2eb7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-REALPART.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-6-REALPART.TEST b/internal/test/LANGUAGE/AUTO/12-6-REALPART.TEST new file mode 100644 index 00000000..25b2565d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-6-REM.DFASL b/internal/test/LANGUAGE/AUTO/12-6-REM.DFASL new file mode 100644 index 00000000..48f2c106 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-REM.DFASL differ 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 00000000..28ebef26 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-ROUND.DFASL differ 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 00000000..3cea44d2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.DFASL differ 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 00000000..28b199e4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.DFASL differ 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 00000000..96059e25 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-ASH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-7-ASH.TEST b/internal/test/LANGUAGE/AUTO/12-7-ASH.TEST new file mode 100644 index 00000000..03564f3e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-7-BOOLE.DFASL b/internal/test/LANGUAGE/AUTO/12-7-BOOLE.DFASL new file mode 100644 index 00000000..ce2efeda Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-BOOLE.DFASL differ 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 00000000..18eed64a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-BOOLE.TEST differ 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 00000000..d75fa05a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-INTEGER-LENGTH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-7-INTEGER-LENGTH.TEST b/internal/test/LANGUAGE/AUTO/12-7-INTEGER-LENGTH.TEST new file mode 100644 index 00000000..68be6c66 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-7-LOGAND.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGAND.DFASL new file mode 100644 index 00000000..46f2f8e2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGAND.DFASL differ 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 00000000..9c2eebf5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.DFASL differ 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 00000000..1a2bae27 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.DFASL differ 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 00000000..a6e264ac Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGBITP.DFASL differ 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 00000000..8d0954bb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.DFASL differ 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 00000000..4337e12f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGEQV.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGEQV.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGEQV.TEST new file mode 100644 index 00000000..4526257d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-7-LOGIOR.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.DFASL new file mode 100644 index 00000000..619ef08f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.DFASL differ 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 00000000..25334118 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGNAND.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGNAND.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGNAND.TEST new file mode 100644 index 00000000..2407940c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-7-LOGNOR.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.DFASL new file mode 100644 index 00000000..8adb2160 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.DFASL differ 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 00000000..e04679d5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGNOT.DFASL differ 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 00000000..49ebbbd3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGORC1.DFASL differ 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 00000000..4c730c3f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGORC2.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGORC2.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGORC2.TEST new file mode 100644 index 00000000..6ec7ba6f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-7-LOGTEST.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGTEST.DFASL new file mode 100644 index 00000000..fd316cb1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGTEST.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGTEST.TEST b/internal/test/LANGUAGE/AUTO/12-7-LOGTEST.TEST new file mode 100644 index 00000000..6e5e5322 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-7-LOGXOR.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.DFASL new file mode 100644 index 00000000..e0ac9086 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.DFASL differ 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 00000000..5ccd5880 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.TEST b/internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.TEST new file mode 100644 index 00000000..9b76c040 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-8-BYTE-SIZE.DFASL b/internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.DFASL new file mode 100644 index 00000000..fe485a64 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.TEST b/internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.TEST new file mode 100644 index 00000000..1e9e2800 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-8-BYTE.DFASL b/internal/test/LANGUAGE/AUTO/12-8-BYTE.DFASL new file mode 100644 index 00000000..da67d003 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-8-BYTE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-8-BYTE.TEST b/internal/test/LANGUAGE/AUTO/12-8-BYTE.TEST new file mode 100644 index 00000000..c0b37625 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-8-DEPOSIT-FIELD.DFASL b/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.DFASL new file mode 100644 index 00000000..31f50c26 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.DFASL differ 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 00000000..fed7ff8d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-8-DPB.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-8-DPB.TEST b/internal/test/LANGUAGE/AUTO/12-8-DPB.TEST new file mode 100644 index 00000000..7249888e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-8-LDB-TEST.DFASL b/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.DFASL new file mode 100644 index 00000000..b4ef2a98 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.DFASL differ 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 00000000..957524c6 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-8-LDB.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-8-LDB.TEST b/internal/test/LANGUAGE/AUTO/12-8-LDB.TEST new file mode 100644 index 00000000..319c5d00 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-8-MASK-FIELD.DFASL b/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.DFASL new file mode 100644 index 00000000..fab175e1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.DFASL differ 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 00000000..9ee211fa Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.TEST b/internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.TEST new file mode 100644 index 00000000..52fe7bf1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-9-RANDOM-STATE-P.DFASL b/internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.DFASL new file mode 100644 index 00000000..11ca6a9d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.TEST b/internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.TEST new file mode 100644 index 00000000..05f7a3e0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/12-9-RANDOM.DFASL b/internal/test/LANGUAGE/AUTO/12-9-RANDOM.DFASL new file mode 100644 index 00000000..f0da6bfd Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/12-9-RANDOM.DFASL differ 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 00000000..6c3868e5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.DFASL differ 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 00000000..1c17bc96 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.DFASL differ 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 00000000..03f20fe7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.DFASL differ 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 00000000..7460aa14 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.TEST b/internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.TEST new file mode 100644 index 00000000..0700beb3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-2-CHAR-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.DFASL new file mode 100644 index 00000000..ee9d8667 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.TEST new file mode 100644 index 00000000..24d1d0b1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-2-CHAR-GE.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.DFASL new file mode 100644 index 00000000..0af83b52 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.TEST new file mode 100644 index 00000000..2bac3b1c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-2-CHAR-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.DFASL new file mode 100644 index 00000000..004d2407 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.DFASL differ 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 00000000..61e24482 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.DFASL differ 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 00000000..fffa1b05 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.TEST new file mode 100644 index 00000000..8e96b430 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-2-CHAR-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.DFASL new file mode 100644 index 00000000..4ff95024 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.DFASL differ 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 00000000..518f8fb7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.DFASL differ 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 00000000..af782908 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-EQUAL.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-EQUAL.TEST new file mode 100644 index 00000000..985e335e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-2-CHAR-NOT-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.DFASL new file mode 100644 index 00000000..4d8353bc Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.TEST new file mode 100644 index 00000000..ee495066 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-2-CHAR-NOT-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.DFASL new file mode 100644 index 00000000..c54248ef Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.TEST new file mode 100644 index 00000000..05d2709c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-2-CHAREQ.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.DFASL new file mode 100644 index 00000000..9afb4d4b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.DFASL differ 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 00000000..b5f19e2b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.TEST b/internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.TEST new file mode 100644 index 00000000..34e231f9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-2-DIGIT-CHAR-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.DFASL new file mode 100644 index 00000000..fd9cb597 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.DFASL differ 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 00000000..09672706 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.DFASL differ 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 00000000..d44f218c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.DFASL differ 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 00000000..2fe40eb4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.DFASL differ 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 00000000..4883752b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.DFASL differ 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 00000000..c7e6f071 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.DFASL differ 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 00000000..08ec313d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.DFASL differ 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 00000000..cd743c45 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.DFASL differ 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 00000000..9c5db677 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.DFASL differ 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 00000000..e2b1f7f3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.TEST b/internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.TEST new file mode 100644 index 00000000..54459050 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-3-MAKE-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.DFASL new file mode 100644 index 00000000..53298896 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.TEST b/internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.TEST new file mode 100644 index 00000000..75c49c63 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-4-CHAR-DOWNCASE.DFASL b/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.DFASL new file mode 100644 index 00000000..17376176 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.DFASL differ 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 00000000..30fed284 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.DFASL differ 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 00000000..673ff432 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.TEST b/internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.TEST new file mode 100644 index 00000000..402a040e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.TEST differ 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 00000000..b602c632 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.DFASL differ 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 00000000..bfa3a3f3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-4-CHARACTER.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHARACTER.TEST b/internal/test/LANGUAGE/AUTO/13-4-CHARACTER.TEST new file mode 100644 index 00000000..c8557934 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-4-DIGIT-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.DFASL new file mode 100644 index 00000000..c52b48f7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.DFASL differ 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 00000000..2c13d0e5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.TEST b/internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.TEST new file mode 100644 index 00000000..3d8b8ca8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-4-NAME-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.DFASL new file mode 100644 index 00000000..b270db6f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.DFASL differ 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 00000000..5281db2d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.TEST b/internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.TEST new file mode 100644 index 00000000..31e39e3f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/13-5-SET-CHAR-BIT.DFASL b/internal/test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.DFASL new file mode 100644 index 00000000..1fe2e865 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.TEST b/internal/test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.TEST new file mode 100644 index 00000000..d8c11c42 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-1-COPY-SEQ.DFASL b/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.DFASL new file mode 100644 index 00000000..ae17143b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.DFASL differ 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 00000000..e965aa7c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-1-ELT.DFASL differ 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 00000000..bdc81e2f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-1-LENGTH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-1-LENGTH.TEST b/internal/test/LANGUAGE/AUTO/14-1-LENGTH.TEST new file mode 100644 index 00000000..898c347c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-1-MAKE-SEQUENCE.DFASL b/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.DFASL new file mode 100644 index 00000000..d3b90b60 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.DFASL differ 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 00000000..3ffc5f5e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-1-NREVERSE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-1-NREVERSE.TEST b/internal/test/LANGUAGE/AUTO/14-1-NREVERSE.TEST new file mode 100644 index 00000000..75aa0b76 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-1-REVERSE.DFASL b/internal/test/LANGUAGE/AUTO/14-1-REVERSE.DFASL new file mode 100644 index 00000000..7df65acf Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-1-REVERSE.DFASL differ 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 00000000..d3673a22 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.TEST b/internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.TEST new file mode 100644 index 00000000..702c210f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-2-CONCATENATE.DFASL b/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.DFASL new file mode 100644 index 00000000..08352fa3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.DFASL differ 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 00000000..2bb6ef00 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-2-EVERY.DFASL differ 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 00000000..61fe2602 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-2-MAP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-2-MAP.TEST b/internal/test/LANGUAGE/AUTO/14-2-MAP.TEST new file mode 100644 index 00000000..14a6add4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-2-NOTANY.DFASL b/internal/test/LANGUAGE/AUTO/14-2-NOTANY.DFASL new file mode 100644 index 00000000..91a6e80c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-2-NOTANY.DFASL differ 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 00000000..2345bddc Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.DFASL differ 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 00000000..296f84e8 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-2-REDUCE.DFASL differ 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 00000000..77aa73b1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-2-SOME.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-2-SOME.TEST b/internal/test/LANGUAGE/AUTO/14-2-SOME.TEST new file mode 100644 index 00000000..2170078f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-3-DELETE-DUPLICATES.DFASL b/internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.DFASL new file mode 100644 index 00000000..8cc60703 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.DFASL differ 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 00000000..3cbc8a1e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.TEST new file mode 100644 index 00000000..0a7b32a2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-3-DELETE-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.DFASL new file mode 100644 index 00000000..94bb6452 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.DFASL differ 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 00000000..970cc9cd Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/14-3-DELETE.DFASL b/internal/test/LANGUAGE/AUTO/14-3-DELETE.DFASL new file mode 100644 index 00000000..4e0a3089 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-DELETE.DFASL differ 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 00000000..e121b4fe Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-DELETE.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/14-3-FILL.DFASL b/internal/test/LANGUAGE/AUTO/14-3-FILL.DFASL new file mode 100644 index 00000000..5ff39112 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-FILL.DFASL differ 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 00000000..0d298644 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.DFASL differ 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 00000000..a2f7c4b9 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-FIND-IF.DFASL differ 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 00000000..8f806d47 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-FIND.DFASL differ 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 00000000..6e5737c1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.TEST new file mode 100644 index 00000000..b0ece777 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-3-NSUBSTITUTE-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.DFASL new file mode 100644 index 00000000..6c69f9ae Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.TEST b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.TEST new file mode 100644 index 00000000..21c5bed5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-3-NSUBSTITUTE.DFASL b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.DFASL new file mode 100644 index 00000000..83ed1a49 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.DFASL differ 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 00000000..13ed8013 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.DFASL differ 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 00000000..9c87410c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.DFASL differ 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 00000000..adaca5a2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-POSITION.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-3-POSITION.TEST b/internal/test/LANGUAGE/AUTO/14-3-POSITION.TEST new file mode 100644 index 00000000..13a09b16 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-3-REMOVE-DUPLICATES.DFASL b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.DFASL new file mode 100644 index 00000000..893d50d6 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.DFASL differ 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 00000000..35a1777e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.DFASL differ 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 00000000..84483dd3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.TEST b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.TEST new file mode 100644 index 00000000..d01873f3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-3-REMOVE.DFASL b/internal/test/LANGUAGE/AUTO/14-3-REMOVE.DFASL new file mode 100644 index 00000000..b311a9a2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-REMOVE.DFASL differ 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 00000000..3fe3649e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.DFASL differ 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 00000000..0e383f7f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.TEST b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.TEST new file mode 100644 index 00000000..322124da --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-3-SUBSTITUTE.DFASL b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.DFASL new file mode 100644 index 00000000..b472e39f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.DFASL differ 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 00000000..fb21e499 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.TEST b/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.TEST new file mode 100644 index 00000000..dbf5f110 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-4-COUNT-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF.DFASL new file mode 100644 index 00000000..f8f63656 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF.DFASL differ 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 00000000..0b107f52 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-4-COUNT.DFASL differ 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 00000000..8b06e578 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-4-MISMATCH.DFASL differ 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 00000000..f090eb3e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-5-MERGE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-5-MERGE.TEST b/internal/test/LANGUAGE/AUTO/14-5-MERGE.TEST new file mode 100644 index 00000000..99fa3c5b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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 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 00000000..32004db0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-5-SORT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/14-5-SORT.TEST b/internal/test/LANGUAGE/AUTO/14-5-SORT.TEST new file mode 100644 index 00000000..56d3bdfb --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/14-5-STABLE-SORT.DFASL b/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.DFASL new file mode 100644 index 00000000..785ac9f0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.DFASL differ 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 00000000..2f483266 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CAAAAR.DFASL differ 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 00000000..ddc25ddb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CAAADR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAADR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CAAADR.TEST new file mode 100644 index 00000000..26a19832 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-1-CAAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAAAR.DFASL new file mode 100644 index 00000000..9ecac730 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CAAAR.DFASL differ 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 00000000..59157e15 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CAADAR.DFASL differ 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 00000000..2b69dbc1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CAADDR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAADDR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CAADDR.TEST new file mode 100644 index 00000000..c00f9de0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-1-CAADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAADR.DFASL new file mode 100644 index 00000000..70078129 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CAADR.DFASL differ 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 00000000..82e127bc Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CAAR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CAAR.TEST new file mode 100644 index 00000000..d45459f5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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 ;; (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 00000000..2fe9cd5d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CADAA.DFASL differ 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 00000000..06be23f3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CADAA.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADAAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CADAAR.TEST new file mode 100644 index 00000000..a9bb5f4c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CADAAR.TEST differ 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 00000000..79c60435 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CADADR.DFASL differ 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 00000000..36270493 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CADAR.DFASL differ 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 00000000..a79e5440 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CADDAR.DFASL differ 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 00000000..e3be0ee9 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.DFASL differ 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 00000000..6258cff0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.DFASL differ 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 00000000..fb67df9d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.TEST b/internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.TEST new file mode 100644 index 00000000..9a047fe4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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" (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 00000000..07dffbd6 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.DFASL differ 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 00000000..10945608 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDAAAR.DFASL differ 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 00000000..d5ecead4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDAADR.DFASL differ 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 00000000..b3292959 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDAAR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDAAR.TEST new file mode 100644 index 00000000..3bcdfb95 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-1-CDADAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDADAR.DFASL new file mode 100644 index 00000000..61bcf3d3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDADAR.DFASL differ 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 00000000..811d414d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDADDR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDADDR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDADDR.TEST new file mode 100644 index 00000000..0423da6c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-1-CDADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDADR.DFASL new file mode 100644 index 00000000..30251c7f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDADR.DFASL differ 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 00000000..d3d29282 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDAR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDAR.TEST new file mode 100644 index 00000000..4441d256 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-1-CDDAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDAAR.DFASL new file mode 100644 index 00000000..c4b575c1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDDAAR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDAAR.TEST b/internal/test/LANGUAGE/AUTO/15-1-CDDAAR.TEST new file mode 100644 index 00000000..b7c4faa1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-1-CDDADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDADR.DFASL new file mode 100644 index 00000000..aebb80ca Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDDADR.DFASL differ 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 00000000..c1a41d87 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDDAR.DFASL differ 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 00000000..94ed026d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDDDAR.DFASL differ 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 00000000..12022832 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDDDDR.DFASL differ 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 00000000..b254f2b2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDDDR.DFASL differ 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 00000000..9c734942 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDDR.DFASL differ 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 00000000..cd3c2746 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.DFASL differ 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 00000000..3e912be7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-CONS.DFASL differ 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 00000000..cbd39569 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-1-TREE-EQUAL.DFASL differ 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 00000000..b131ffc7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-APPEND.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-APPEND.TEST b/internal/test/LANGUAGE/AUTO/15-2-APPEND.TEST new file mode 100644 index 00000000..d5d9ff6c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-BUTLAST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-BUTLAST.DFASL new file mode 100644 index 00000000..a1f1295f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-BUTLAST.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-BUTLAST.TEST b/internal/test/LANGUAGE/AUTO/15-2-BUTLAST.TEST new file mode 100644 index 00000000..64972995 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-COPY-ALIST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.DFASL new file mode 100644 index 00000000..6a20c9c8 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.DFASL differ 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 00000000..0799dcbf Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.DFASL differ 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 00000000..693e62e3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.TEST b/internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.TEST new file mode 100644 index 00000000..8266135c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-EIGHTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.DFASL new file mode 100644 index 00000000..811b59c5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.DFASL differ 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 00000000..70daa331 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-ENDP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-ENDP.TEST b/internal/test/LANGUAGE/AUTO/15-2-ENDP.TEST new file mode 100644 index 00000000..db9ef8a2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-FIFTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-FIFTH.DFASL new file mode 100644 index 00000000..6018e168 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-FIFTH.DFASL differ 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 00000000..061c0e61 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-FIRST.DFASL differ 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 00000000..15ebd05e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-FOURTH.DFASL differ 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 00000000..83a50e00 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-LAST.DFASL differ 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 00000000..24ff19c7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-LDIFF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-LDIFF.TEST b/internal/test/LANGUAGE/AUTO/15-2-LDIFF.TEST new file mode 100644 index 00000000..39fdab24 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-LIST-LENGTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.DFASL new file mode 100644 index 00000000..3c7f9b64 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.DFASL differ 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 00000000..278b2db7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-LIST.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-LIST.TEST b/internal/test/LANGUAGE/AUTO/15-2-LIST.TEST new file mode 100644 index 00000000..9fded9c0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-LISTSTAR.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.DFASL new file mode 100644 index 00000000..62c279a7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.TEST b/internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.TEST new file mode 100644 index 00000000..0d749cc5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-MAKE-LIST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.DFASL new file mode 100644 index 00000000..a8a1cc2c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.DFASL differ 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 00000000..cfa91506 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.TEST b/internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.TEST new file mode 100644 index 00000000..d39ec692 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-NCONC.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NCONC.DFASL new file mode 100644 index 00000000..48332cb2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-NCONC.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-NCONC.TEST b/internal/test/LANGUAGE/AUTO/15-2-NCONC.TEST new file mode 100644 index 00000000..27d75656 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-NINTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NINTH.DFASL new file mode 100644 index 00000000..63b52607 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-NINTH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-NINTH.TEST b/internal/test/LANGUAGE/AUTO/15-2-NINTH.TEST new file mode 100644 index 00000000..910353f4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-NRECONC.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NRECONC.DFASL new file mode 100644 index 00000000..d2c53b6e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-NRECONC.DFASL differ 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 00000000..94b9fbeb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-NTH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-NTH.TEST b/internal/test/LANGUAGE/AUTO/15-2-NTH.TEST new file mode 100644 index 00000000..5446f229 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-NTH.TEST differ 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 00000000..fc4147d3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-NTHCDR.DFASL differ 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 00000000..3ffff2ad Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-POP.DFASL differ 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 00000000..28997814 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-PUSH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-PUSH.TEST b/internal/test/LANGUAGE/AUTO/15-2-PUSH.TEST new file mode 100644 index 00000000..544f85db --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-PUSHNEW.DFASL b/internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.DFASL new file mode 100644 index 00000000..9fa449b0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.DFASL differ 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 00000000..1451af98 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-REST.DFASL differ 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 00000000..cec96f52 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.TEST b/internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.TEST new file mode 100644 index 00000000..699a1689 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-SECOND.DFASL b/internal/test/LANGUAGE/AUTO/15-2-SECOND.DFASL new file mode 100644 index 00000000..f0ee10ca Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-SECOND.DFASL differ 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 00000000..322d19ff Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-SEVENTH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-SEVENTH.TEST b/internal/test/LANGUAGE/AUTO/15-2-SEVENTH.TEST new file mode 100644 index 00000000..65935dd9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-2-SIXTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-SIXTH.DFASL new file mode 100644 index 00000000..4b588856 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-SIXTH.DFASL differ 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 00000000..c8779109 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-TENTH.DFASL differ 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 00000000..b4471332 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-2-THIRD.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-2-THIRD.TEST b/internal/test/LANGUAGE/AUTO/15-2-THIRD.TEST new file mode 100644 index 00000000..35544af1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-3-RPLACA.DFASL b/internal/test/LANGUAGE/AUTO/15-3-RPLACA.DFASL new file mode 100644 index 00000000..285a517f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-3-RPLACA.DFASL differ 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 00000000..c6b9d939 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-3-RPLACD.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-3-RPLACD.TEST b/internal/test/LANGUAGE/AUTO/15-3-RPLACD.TEST new file mode 100644 index 00000000..108c1aec --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-4-NSUBLIS.DFASL b/internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.DFASL new file mode 100644 index 00000000..2017879c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.TEST b/internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.TEST new file mode 100644 index 00000000..6f10300b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-4-NSUBST-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.DFASL new file mode 100644 index 00000000..5caf36f5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.DFASL differ 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 00000000..c3b81427 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.TEST b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.TEST new file mode 100644 index 00000000..a9e158bc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-4-NSUBST.DFASL b/internal/test/LANGUAGE/AUTO/15-4-NSUBST.DFASL new file mode 100644 index 00000000..8ad40d9c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-4-NSUBST.DFASL differ 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 00000000..f1744803 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-4-SUBLIS.DFASL differ 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 00000000..4d136c38 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.DFASL differ 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 00000000..d1a16712 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF.TEST b/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF.TEST new file mode 100644 index 00000000..bae6a2c8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-4-SUBST.DFASL b/internal/test/LANGUAGE/AUTO/15-4-SUBST.DFASL new file mode 100644 index 00000000..bb44393c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-4-SUBST.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-4-SUBST.TEST b/internal/test/LANGUAGE/AUTO/15-4-SUBST.TEST new file mode 100644 index 00000000..a89e7d9b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-5-ADJOIN.DFASL b/internal/test/LANGUAGE/AUTO/15-5-ADJOIN.DFASL new file mode 100644 index 00000000..041094fb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-ADJOIN.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-5-ADJOIN.TEST b/internal/test/LANGUAGE/AUTO/15-5-ADJOIN.TEST new file mode 100644 index 00000000..1ffecac0 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-5-INTERSECTION.DFASL b/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.DFASL new file mode 100644 index 00000000..076afc56 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.DFASL differ 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 00000000..7e72823e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.DFASL differ 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 00000000..39132cd0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.DFASL differ 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 00000000..e8bce7a8 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-MEMBER.DFASL differ 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 00000000..028f1516 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.DFASL differ 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 00000000..ea73eaec Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.TEST b/internal/test/LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.TEST new file mode 100644 index 00000000..f2e3cd0d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-5-NSET-EXCLUSIVE-OR.DFASL b/internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.DFASL new file mode 100644 index 00000000..5e89174e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.TEST b/internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.TEST new file mode 100644 index 00000000..d82c3e71 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-5-NUNION.DFASL b/internal/test/LANGUAGE/AUTO/15-5-NUNION.DFASL new file mode 100644 index 00000000..20f59342 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-NUNION.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-5-NUNION.TEST b/internal/test/LANGUAGE/AUTO/15-5-NUNION.TEST new file mode 100644 index 00000000..f61c1bf5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-5-SET-DIFFERENCE.DFASL b/internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.DFASL new file mode 100644 index 00000000..f5e38556 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.TEST b/internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.TEST new file mode 100644 index 00000000..c5a83454 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-5-SET-EXCLUSIVE-OR.DFASL b/internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.DFASL new file mode 100644 index 00000000..cf4cb82d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.TEST b/internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.TEST new file mode 100644 index 00000000..25d653dc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-5-SUBSETP.DFASL b/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.DFASL new file mode 100644 index 00000000..26fff79b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.DFASL differ 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 00000000..3e6f228e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-TAILP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-5-TAILP.TEST b/internal/test/LANGUAGE/AUTO/15-5-TAILP.TEST new file mode 100644 index 00000000..2e0cd1c1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-5-UNION.DFASL b/internal/test/LANGUAGE/AUTO/15-5-UNION.DFASL new file mode 100644 index 00000000..85bcc9db Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-5-UNION.DFASL differ 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 00000000..3ea747c5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-6-ACONS.DFASL differ 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 00000000..8f9a90c1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.DFASL differ 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 00000000..08d5bc71 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.TEST b/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.TEST new file mode 100644 index 00000000..4e5c903a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-6-ASSOC.DFASL b/internal/test/LANGUAGE/AUTO/15-6-ASSOC.DFASL new file mode 100644 index 00000000..64006e24 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-6-ASSOC.DFASL differ 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 00000000..57e879c7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.TEST b/internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.TEST new file mode 100644 index 00000000..f7354cc2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/15-6-RASSOC-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.DFASL new file mode 100644 index 00000000..e2c0db5b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.DFASL differ 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 00000000..aad11bf8 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.DFASL differ 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 00000000..c5609923 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/15-6-RASSOC.DFASL differ 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 00000000..8de3af0b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/16-1-CLRHASH.DFASL differ 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 00000000..5a3d0137 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/16-1-GETHASH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/16-1-GETHASH.TEST b/internal/test/LANGUAGE/AUTO/16-1-GETHASH.TEST new file mode 100644 index 00000000..bccc0f21 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/16-1-HASH-TABLE-COUNT.DFASL b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.DFASL new file mode 100644 index 00000000..486fef64 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.DFASL differ 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 00000000..498bbcb8 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.DFASL differ 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 00000000..d3ad9392 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.TEST b/internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.TEST new file mode 100644 index 00000000..af990a4e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/16-1-MAPHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-1-MAPHASH.DFASL new file mode 100644 index 00000000..1bb34f08 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/16-1-MAPHASH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/16-1-MAPHASH.TEST b/internal/test/LANGUAGE/AUTO/16-1-MAPHASH.TEST new file mode 100644 index 00000000..ef3f10b9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/16-1-REMHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-1-REMHASH.DFASL new file mode 100644 index 00000000..37b7b36b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/16-1-REMHASH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/16-1-REMHASH.TEST b/internal/test/LANGUAGE/AUTO/16-1-REMHASH.TEST new file mode 100644 index 00000000..f88d638a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/16-2-SXHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-2-SXHASH.DFASL new file mode 100644 index 00000000..5fb1d339 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/16-2-SXHASH.DFASL differ 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 00000000..675f7c6e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.DFASL differ 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 00000000..d1e80647 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-1-VECTOR.DFASL differ 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 00000000..fe350ac3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-2-AREF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-2-AREF.TEST b/internal/test/LANGUAGE/AUTO/17-2-AREF.TEST new file mode 100644 index 00000000..ffa81763 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-2-SVREF.DFASL b/internal/test/LANGUAGE/AUTO/17-2-SVREF.DFASL new file mode 100644 index 00000000..0bff00f8 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-2-SVREF.DFASL differ 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 00000000..7160a5bd Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-3-ADJUSTABLE-ARRAY-P.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-3-ADJUSTABLE-ARRAY-P.TEST b/internal/test/LANGUAGE/AUTO/17-3-ADJUSTABLE-ARRAY-P.TEST new file mode 100644 index 00000000..9847736a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-3-ARRAY-DIMENSION.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.DFASL new file mode 100644 index 00000000..a7da2773 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.DFASL differ 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 00000000..3f22f31a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.TEST b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.TEST new file mode 100644 index 00000000..c129f905 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-3-ARRAY-ELEMENT-TYPE.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ELEMENT-TYPE.DFASL new file mode 100644 index 00000000..f64e73b3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ELEMENT-TYPE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ELEMENT-TYPE.TEST b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ELEMENT-TYPE.TEST new file mode 100644 index 00000000..c7d6edc2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..620c9c30 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.DFASL differ 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 00000000..ab325979 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-RANK.DFASL differ 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 00000000..9e3211ef Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.TEST b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.TEST new file mode 100644 index 00000000..f4826b1f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-3-ARRAY-TOTAL-SIZE.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.DFASL new file mode 100644 index 00000000..0101ba7d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.DFASL differ 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 00000000..019b065d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT-AND.DFASL differ 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 00000000..5788b48f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.TEST new file mode 100644 index 00000000..b7df0b8c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-4-BIT-ANDC2.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.DFASL new file mode 100644 index 00000000..258b779c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.TEST new file mode 100644 index 00000000..5db40ae8 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-4-BIT-EQV.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.DFASL new file mode 100644 index 00000000..9ea46e53 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.TEST new file mode 100644 index 00000000..53e3384f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-4-BIT-IOR.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.DFASL new file mode 100644 index 00000000..50cbd1c7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.DFASL differ 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 00000000..97c5aa7f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.DFASL differ 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 00000000..348e3021 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.DFASL differ 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 00000000..a72ccd2b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.TEST new file mode 100644 index 00000000..a7888845 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-4-BIT-ORC1.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.DFASL new file mode 100644 index 00000000..676f4ac6 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.DFASL differ 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 00000000..3ae1a89c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.TEST new file mode 100644 index 00000000..22c576a6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-4-BIT-XOR.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.DFASL new file mode 100644 index 00000000..b9d23795 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.DFASL differ 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 00000000..2025ec2a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-BIT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT.TEST b/internal/test/LANGUAGE/AUTO/17-4-BIT.TEST new file mode 100644 index 00000000..fb0bf382 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-4-SBIT.DFASL b/internal/test/LANGUAGE/AUTO/17-4-SBIT.DFASL new file mode 100644 index 00000000..6b8ee2cb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-4-SBIT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-4-SBIT.TEST b/internal/test/LANGUAGE/AUTO/17-4-SBIT.TEST new file mode 100644 index 00000000..be82d0ed --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..b5f4a714 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-5-ARRAY-HAS-FILL-POINTER-P.DFASL differ 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 00000000..9bedb1f7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-5-FILL-POINTER.DFASL differ 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 00000000..0511c4e5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-POP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-POP.TEST b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-POP.TEST new file mode 100644 index 00000000..3260d089 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-5-VECTOR-PUSH-EXTEND.DFASL b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.DFASL new file mode 100644 index 00000000..761ec79b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.TEST b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.TEST new file mode 100644 index 00000000..d1604cb6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/17-5-VECTOR-PUSH.DFASL b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.DFASL new file mode 100644 index 00000000..b1a05adf Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.DFASL differ 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 00000000..78d1b3d1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.DFASL differ 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 00000000..9f6a81ea Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-1-CHAR.DFASL differ 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 00000000..415202ab Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-1-SCHAR.DFASL differ 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 00000000..b691b9b3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.TEST new file mode 100644 index 00000000..a876b91f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/18-2-STRING-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.DFASL new file mode 100644 index 00000000..f09e785c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.DFASL differ 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 00000000..81e063ec Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-GE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-GE.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-GE.TEST new file mode 100644 index 00000000..8da811e9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/18-2-STRING-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.DFASL new file mode 100644 index 00000000..24196377 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.TEST new file mode 100644 index 00000000..3d4ee62e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/18-2-STRING-GT.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.DFASL new file mode 100644 index 00000000..9321bb41 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.DFASL differ 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 00000000..047a9221 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-LE.DFASL differ 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 00000000..0a0e017b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.DFASL differ 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 00000000..5a7c32b4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-LT.DFASL differ 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 00000000..6fbcf3e4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.TEST b/internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.TEST new file mode 100644 index 00000000..a0072a97 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/18-2-STRING-NOT-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.DFASL new file mode 100644 index 00000000..d28f1f91 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.DFASL differ 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 00000000..615c8a7b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.DFASL differ 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 00000000..b7ecdd94 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.DFASL differ 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 00000000..11c9bff8 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.DFASL differ 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 00000000..402fe0c0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.TEST b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.TEST new file mode 100644 index 00000000..b99edf24 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/18-3-NSTRING-DOWNCASE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.DFASL new file mode 100644 index 00000000..aef1aced Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.DFASL differ 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 00000000..870d016a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.DFASL differ 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 00000000..57f962a0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.TEST b/internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.TEST new file mode 100644 index 00000000..054552f4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/18-3-STRING-DOWNCASE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.DFASL new file mode 100644 index 00000000..fc979a19 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.DFASL differ 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 00000000..d3edceb4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.TEST b/internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.TEST new file mode 100644 index 00000000..7452492e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/18-3-STRING-RIGHT-TRIM.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.DFASL new file mode 100644 index 00000000..73ec7291 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.DFASL differ 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 00000000..86f0308b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.TEST b/internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.TEST new file mode 100644 index 00000000..8c606cf4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/18-3-STRING-UPCASE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.DFASL new file mode 100644 index 00000000..9a59a064 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.DFASL differ 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 00000000..1880be5d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/18-3-STRING.DFASL differ 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 00000000..3b46f054 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/19-DEFSTRUCT.TEST differ 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 00000000..9da2986b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/20-1-APPLYHOOK.DFASL differ 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 00000000..2991f22d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/20-1-CONSTANTP.DFASL differ 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 00000000..da2e3e87 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/20-1-EVAL.DFASL differ 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 HELVETICAJJJJ *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(JJNJJJNJJJJ:JJ'JJ*I..@-I/.D-I/.D7,+-JQJJJ@JJJJ!JJ(JJOJJJ5JJJJJJ'JJJIJJbJJ&JJ JJI**)I%H5G#GF?GGGF?G)GGGJ=JJJ@JJJJ!JJ&JJLJJJfJJ1JJ2J>J>JJ9JJ(I,..(I*HHK'& +I-.C%;$#-J=JJJ@JJJJ!JJ&JJKJJJXJJJJIJJ`JJ'I+H GF!#'I-H G3"!! +! I.H G3"!! +! $4J3JJJ@JJJJ!JJ&JJMJJJJFJJ-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(JJIJJJIJJJJ,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(JJFJJJFJJJJ,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;JJJ3JJJJJ"JJJ#JhJJI*H*G;+F#F35 +2IH(G;+FG F 36F2JJJJ%J=JJJJ"JJ&JJEJJJ@JJJJJJJJJJI(H9#& $II(JI(9#II(JI(H9#& $I I(wz \ 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 00000000..73f41b07 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.TEST b/internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.TEST new file mode 100644 index 00000000..513115bf --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..5d093244 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL differ 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 00000000..49061ee0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-1-5-GET-MACRO-CHARACTER.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-GET-MACRO-CHARACTER.TEST b/internal/test/LANGUAGE/AUTO/22-1-5-GET-MACRO-CHARACTER.TEST new file mode 100644 index 00000000..7d55ddf2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..572b506f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL differ 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 00000000..e7a29899 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.DFASL differ 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 00000000..bf369439 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-SET-DISPATCH-MACRO-CHARACTER.TEST b/internal/test/LANGUAGE/AUTO/22-1-5-SET-DISPATCH-MACRO-CHARACTER.TEST new file mode 100644 index 00000000..7d82235d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..9b3e2743 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-1-5-SET-MACRO-CHARACTER.DFASL differ 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 00000000..861d7759 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.DFASL differ 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 00000000..a68478a3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-LISTEN.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-LISTEN.DFASL new file mode 100644 index 00000000..356b0dac Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-LISTEN.DFASL differ 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 00000000..ac3bbeea Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-LISTEN.TEST differ 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 00000000..64b1c42f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.DFASL differ 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 00000000..c9b0a42f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.TEST differ 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 00000000..b528233b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.TEST b/internal/test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.TEST new file mode 100644 index 00000000..2f81f947 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR-NO-HANG.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR-NO-HANG.DFASL new file mode 100644 index 00000000..a603cd0d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR-NO-HANG.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR-NO-HANG.TEST b/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR-NO-HANG.TEST new file mode 100644 index 00000000..d635b077 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR-NO-HANG.TEST differ 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 00000000..d5edee26 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR.DFASL differ 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 00000000..e9ada3b3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-READ-DELIMITED-LIST.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ-DELIMITED-LIST.TEST b/internal/test/LANGUAGE/AUTO/22-2-1-READ-DELIMITED-LIST.TEST new file mode 100644 index 00000000..ce9528ca --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..aaf6ce39 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-READ-FROM-STRING.TEST differ 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 00000000..fa5ea2b4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-READ-PRESERVING-WHITESPACE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ-PRESERVING-WHITESPACE.TEST b/internal/test/LANGUAGE/AUTO/22-2-1-READ-PRESERVING-WHITESPACE.TEST new file mode 100644 index 00000000..84631a1d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/22-2-1-READ.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-READ.DFASL new file mode 100644 index 00000000..ef6a5aff Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-READ.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ.TEST b/internal/test/LANGUAGE/AUTO/22-2-1-READ.TEST new file mode 100644 index 00000000..df83a9ce --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/22-2-1-UNREAD-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.DFASL new file mode 100644 index 00000000..6024e6d7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.DFASL differ 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 00000000..7ae5cdc1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.DFASL differ 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 00000000..7e5e6648 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-FRESH-LINE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-FRESH-LINE.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-FRESH-LINE.TEST new file mode 100644 index 00000000..2ab4ad5a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/22-3-1-PPRINT.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.DFASL new file mode 100644 index 00000000..182ad503 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.DFASL differ 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 00000000..87392812 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1-TO-STRING.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1-TO-STRING.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1-TO-STRING.TEST new file mode 100644 index 00000000..c9ffe3a3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/22-3-1-PRIN1.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.DFASL new file mode 100644 index 00000000..506b2308 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.DFASL differ 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 00000000..733874a1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.DFASL differ 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 00000000..b01ccf24 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-PRINC.DFASL differ 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 00000000..a01fe223 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-PRINT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRINT.TEST b/internal/test/LANGUAGE/AUTO/22-3-1-PRINT.TEST new file mode 100644 index 00000000..bfb6eb2f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/22-3-1-TERPRI.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.DFASL new file mode 100644 index 00000000..3576b03a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.DFASL differ 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 00000000..3c021f9c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.DFASL differ 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 00000000..a49afc60 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.DFASL differ 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 00000000..026dd632 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.DFASL differ 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 00000000..e0b92d1b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.TEST b/internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.TEST new file mode 100644 index 00000000..6c480bde --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..b152cd21 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DFASL differ 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 00000000..19d14e50 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/24-1-BREAK.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/24-1-BREAK.TEST b/internal/test/LANGUAGE/AUTO/24-1-BREAK.TEST new file mode 100644 index 00000000..ecedf8b4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/24-1-CERROR.DFASL b/internal/test/LANGUAGE/AUTO/24-1-CERROR.DFASL new file mode 100644 index 00000000..305bee87 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/24-1-CERROR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/24-1-CERROR.TEST b/internal/test/LANGUAGE/AUTO/24-1-CERROR.TEST new file mode 100644 index 00000000..685963ab --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..e2872f60 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/24-1-ERROR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/24-1-ERROR.TEST b/internal/test/LANGUAGE/AUTO/24-1-ERROR.TEST new file mode 100644 index 00000000..2b3299b9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/24-1-WARN.DFASL b/internal/test/LANGUAGE/AUTO/24-1-WARN.DFASL new file mode 100644 index 00000000..b8223d41 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/24-1-WARN.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/24-1-WARN.TEST b/internal/test/LANGUAGE/AUTO/24-1-WARN.TEST new file mode 100644 index 00000000..d44b458a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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-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 00000000..373d67f9 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/24-2-ASSERT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/24-2-ASSERT.TEST b/internal/test/LANGUAGE/AUTO/24-2-ASSERT.TEST new file mode 100644 index 00000000..951a7605 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/24-3-CCASE.DFASL b/internal/test/LANGUAGE/AUTO/24-3-CCASE.DFASL new file mode 100644 index 00000000..4809f1cc Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/24-3-CCASE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/24-3-CCASE.TEST b/internal/test/LANGUAGE/AUTO/24-3-CCASE.TEST new file mode 100644 index 00000000..32af5748 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/24-3-CTYPECASE.DFASL b/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.DFASL new file mode 100644 index 00000000..ecaae617 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.DFASL differ 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 00000000..4733e3fc Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/24-3-ECASE.DFASL differ 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 00000000..c623a3bf Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.DFASL differ 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 00000000..21330442 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-1-COMPILE-FILE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/25-1-COMPILE-FILE.TEST b/internal/test/LANGUAGE/AUTO/25-1-COMPILE-FILE.TEST new file mode 100644 index 00000000..f361e8e2 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/25-1-COMPILE.DFASL b/internal/test/LANGUAGE/AUTO/25-1-COMPILE.DFASL new file mode 100644 index 00000000..7d0335ee Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-1-COMPILE.DFASL differ 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 00000000..2652bbce Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.DFASL differ 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 00000000..05156ceb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.TEST b/internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.TEST new file mode 100644 index 00000000..eab61a6f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/25-3-APROPOS-LIST.DFASL b/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.DFASL new file mode 100644 index 00000000..407fc391 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.DFASL differ 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 00000000..3c468513 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-3-APROPOS.DFASL differ 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 00000000..30effa98 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.TEST b/internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.TEST new file mode 100644 index 00000000..0f9e585a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/25-3-DRIBBLE.DFASL b/internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.DFASL new file mode 100644 index 00000000..9a610f4a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.TEST b/internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.TEST new file mode 100644 index 00000000..6729c282 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/25-3-ED.DFASL b/internal/test/LANGUAGE/AUTO/25-3-ED.DFASL new file mode 100644 index 00000000..11c0d959 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-3-ED.DFASL differ 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 00000000..55d58378 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-3-INSPECT.DFASL differ 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 00000000..23117622 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-3-ROOM.DFASL differ 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 00000000..da40ef37 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-3-TIME.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/25-3-TIME.TEST b/internal/test/LANGUAGE/AUTO/25-3-TIME.TEST new file mode 100644 index 00000000..9dea99cd --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/25-4-DECODE-UNIVERSAL-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.DFASL new file mode 100644 index 00000000..c57c6332 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.DFASL differ 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 00000000..c81b0630 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.TEST b/internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.TEST new file mode 100644 index 00000000..9a881b11 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/25-4-GET-DECODED-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.DFASL new file mode 100644 index 00000000..eec97a32 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.DFASL differ 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 00000000..3fe1009c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-REAL-TIME.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-REAL-TIME.TEST b/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-REAL-TIME.TEST new file mode 100644 index 00000000..33546de1 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..1384490c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-RUN-TIME.DFASL differ 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 00000000..390df6d3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.TEST b/internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.TEST new file mode 100644 index 00000000..9b31f148 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.DFASL b/internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.DFASL new file mode 100644 index 00000000..9e2225e3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.TEST b/internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.TEST new file mode 100644 index 00000000..3210deb3 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/25-4-LONG-SITE-NAME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.DFASL new file mode 100644 index 00000000..8181e2c4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.DFASL differ 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 00000000..424df4b3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.DFASL differ 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 00000000..a0734874 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.DFASL differ 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 00000000..402dccbe Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.DFASL differ 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 00000000..7ff05ef3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.DFASL differ 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 00000000..a9a7c508 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-SLEEP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/25-4-SLEEP.TEST b/internal/test/LANGUAGE/AUTO/25-4-SLEEP.TEST new file mode 100644 index 00000000..9b8c2bf7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/25-4-SOFTWARE-TYPE.DFASL b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.DFASL new file mode 100644 index 00000000..c1449780 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.TEST b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.TEST new file mode 100644 index 00000000..796b84db --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/25-4-SOFTWARE-VERSION.DFASL b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.DFASL new file mode 100644 index 00000000..f56800aa Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.DFASL differ 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 00000000..9f5bf905 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/25-5-IDENTITY.DFASL differ 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 00000000..28ae008b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/4-8-COERCE.DFASL differ 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 00000000..c1ede303 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.TEST b/internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.TEST new file mode 100644 index 00000000..c02a3ecf --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/5-2-2-LAMBDA-EXPRESSIONS.DFASL b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.DFASL new file mode 100644 index 00000000..11384d54 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.DFASL differ 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 00000000..807f1de5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.TEST b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.TEST new file mode 100644 index 00000000..9b933fec --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL new file mode 100644 index 00000000..acb6eb2b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.TEST b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.TEST new file mode 100644 index 00000000..782fc1ea --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/5-3-1-DEFUN.DFASL b/internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.DFASL new file mode 100644 index 00000000..af2275b2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.DFASL differ 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 00000000..39ad15ba Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.DFASL differ 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 00000000..c4ed2745 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.TEST b/internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.TEST new file mode 100644 index 00000000..2aa62a74 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/5-3-2-DEFVAR.DFASL b/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.DFASL new file mode 100644 index 00000000..0384a4b4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.DFASL differ 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 00000000..b451ee23 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.DFASL differ 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 00000000..50d7da4a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.TEST b/internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.TEST new file mode 100644 index 00000000..572c22a6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/6-2-1-TYPEP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.DFASL new file mode 100644 index 00000000..7d08bf8f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.TEST b/internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.TEST new file mode 100644 index 00000000..455bfd53 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/6-2-2-ARRAYP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.DFASL new file mode 100644 index 00000000..2a6f6f03 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.DFASL differ 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 00000000..8a1a73cf Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-ATOM.DFASL differ 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 00000000..68e20a7f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.TEST new file mode 100644 index 00000000..265b4530 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/6-2-2-CHARACTERP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.DFASL new file mode 100644 index 00000000..ca66bf3d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.DFASL differ 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 00000000..36f6dd3c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.DFASL differ 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 00000000..a950f0ee Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-COMPILED-FUNCTION-P.DFASL differ 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 00000000..c5a98ea5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.TEST new file mode 100644 index 00000000..316f9ded --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/6-2-2-CONSP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-CONSP.DFASL new file mode 100644 index 00000000..ef5b15fa Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-CONSP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-CONSP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-CONSP.TEST new file mode 100644 index 00000000..1c6aae22 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/6-2-2-FLOATP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.DFASL new file mode 100644 index 00000000..3d4d31e4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.TEST new file mode 100644 index 00000000..f2f9ac82 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/6-2-2-FUNCTIONP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.DFASL new file mode 100644 index 00000000..a4b52c1a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.DFASL differ 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 00000000..fa0a9055 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.DFASL differ 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 00000000..401a7c8c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-LISTP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-LISTP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-LISTP.TEST new file mode 100644 index 00000000..3d40c65f --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/6-2-2-NULL.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-NULL.DFASL new file mode 100644 index 00000000..6b1face3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-NULL.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-NULL.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-NULL.TEST new file mode 100644 index 00000000..5cfb068b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/6-2-2-NUMBERP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.DFASL new file mode 100644 index 00000000..83aa69b5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.DFASL differ 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 00000000..a8c62651 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.TEST new file mode 100644 index 00000000..3300d250 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/6-2-2-RATIONALP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.DFASL new file mode 100644 index 00000000..e05a3796 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.DFASL differ 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 00000000..6b0dba36 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL differ 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 00000000..f0d741f4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.DFASL differ 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 00000000..07646e28 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.DFASL differ 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 00000000..194281d5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.DFASL differ 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 00000000..b0fc45b3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.TEST b/internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.TEST new file mode 100644 index 00000000..e7c33dfd --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/6-2-2-VECTORP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.DFASL new file mode 100644 index 00000000..bbaa70d7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.DFASL differ 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 00000000..a475379f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-3-EQ.DFASL differ 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 00000000..64251c99 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-3-EQL.DFASL differ 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 00000000..09e05934 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-3-EQUAL.DFASL differ 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 00000000..69e63f83 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-3-EQUALP.DFASL differ 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 00000000..4a994deb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-4-AND.DFASL differ 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 00000000..989c43eb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-4-NOT.DFASL differ 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 00000000..5d5f9bde Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/6-4-OR.DFASL differ 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 00000000..50139375 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.DFASL differ 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 00000000..0990fc2e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-1-FBOUNDP.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-FBOUNDP.TEST b/internal/test/LANGUAGE/AUTO/7-1-1-FBOUNDP.TEST new file mode 100644 index 00000000..acffe6a7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-1-1-FUNCTION.DFASL b/internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.DFASL new file mode 100644 index 00000000..58a41f51 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.DFASL differ 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 00000000..ae6cbcb6 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.TEST b/internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.TEST new file mode 100644 index 00000000..13dc4bc5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..98eb79a3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.DFASL differ 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 00000000..72ad45d2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.TEST b/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.TEST new file mode 100644 index 00000000..38124414 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.DFASL b/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.DFASL new file mode 100644 index 00000000..d05b978a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.TEST b/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.TEST new file mode 100644 index 00000000..f0404e7c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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 ~ 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 00000000..0d26c282 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.DFASL differ 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 00000000..0fd7d9d0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.DFASL differ 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 00000000..ef117865 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.TEST differ 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 00000000..dc75ea23 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.DFASL differ 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 00000000..7737ac4e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/7-1-2-SET.DFASL b/internal/test/LANGUAGE/AUTO/7-1-2-SET.DFASL new file mode 100644 index 00000000..4d37a885 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-1-2-SET.DFASL differ 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 00000000..586ddb44 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-10-CATCH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-10-CATCH.TEST b/internal/test/LANGUAGE/AUTO/7-10-CATCH.TEST new file mode 100644 index 00000000..e37d61aa --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-10-THROW.DFASL b/internal/test/LANGUAGE/AUTO/7-10-THROW.DFASL new file mode 100644 index 00000000..771f873b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-10-THROW.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-10-THROW.TEST b/internal/test/LANGUAGE/AUTO/7-10-THROW.TEST new file mode 100644 index 00000000..8a3e8520 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-10-UNWIND-PROTECT.DFASL b/internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.DFASL new file mode 100644 index 00000000..d8bc20a0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.DFASL differ 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 00000000..0e32d81c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-2-DEFINE-MODIFY-MACRO.DFASL differ 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 00000000..0c64a96a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.DFASL differ 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 00000000..6caf8138 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-2-DEFSETF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-2-DEFSETF.TEST b/internal/test/LANGUAGE/AUTO/7-2-DEFSETF.TEST new file mode 100644 index 00000000..81070a18 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-2-DEFSETF.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL b/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL new file mode 100644 index 00000000..87697dd3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL differ 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 00000000..a69f35f1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.DFASL differ 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 00000000..659e61dd Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-2-PSETF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-2-PSETF.TEST b/internal/test/LANGUAGE/AUTO/7-2-PSETF.TEST new file mode 100644 index 00000000..cdcc2bae --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-2-ROTATEF.DFASL b/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.DFASL new file mode 100644 index 00000000..68cdc1bc Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.DFASL differ 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 00000000..298e4fe2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-2-SETF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-2-SETF.TEST b/internal/test/LANGUAGE/AUTO/7-2-SETF.TEST new file mode 100644 index 00000000..8498c888 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-2-SHIFTF.DFASL b/internal/test/LANGUAGE/AUTO/7-2-SHIFTF.DFASL new file mode 100644 index 00000000..7d4d6392 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-2-SHIFTF.DFASL differ 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 00000000..71469a66 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-3-APPLY.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-3-APPLY.TEST b/internal/test/LANGUAGE/AUTO/7-3-APPLY.TEST new file mode 100644 index 00000000..c86dcb98 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-3-CALL-ARGUMENTS-LIMIT.DFASL b/internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.DFASL new file mode 100644 index 00000000..837eb021 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.DFASL differ 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 00000000..0749e3f2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-3-FUNCALL.DFASL differ 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 00000000..56335ae1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-4-PROG1.DFASL differ 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 00000000..36ed2de8 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-4-PROG2.DFASL differ 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 00000000..3b290f27 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-4-PROGN.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-4-PROGN.TEST b/internal/test/LANGUAGE/AUTO/7-4-PROGN.TEST new file mode 100644 index 00000000..96e92f36 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..bde2c130 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-5-FLET.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-5-FLET.TEST b/internal/test/LANGUAGE/AUTO/7-5-FLET.TEST new file mode 100644 index 00000000..bbbdca3d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..39cd1c77 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-5-LET.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-5-LET.TEST b/internal/test/LANGUAGE/AUTO/7-5-LET.TEST new file mode 100644 index 00000000..9c7249d5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-5-LETSTAR.DFASL b/internal/test/LANGUAGE/AUTO/7-5-LETSTAR.DFASL new file mode 100644 index 00000000..84a5d023 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-5-LETSTAR.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-5-LETSTAR.TEST b/internal/test/LANGUAGE/AUTO/7-5-LETSTAR.TEST new file mode 100644 index 00000000..9a9d42bc --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-5-MACROLET.DFASL b/internal/test/LANGUAGE/AUTO/7-5-MACROLET.DFASL new file mode 100644 index 00000000..62082c99 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-5-MACROLET.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-5-MACROLET.TEST b/internal/test/LANGUAGE/AUTO/7-5-MACROLET.TEST new file mode 100644 index 00000000..b3fb6180 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-5-PROGV.DFASL b/internal/test/LANGUAGE/AUTO/7-5-PROGV.DFASL new file mode 100644 index 00000000..992be3ba Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-5-PROGV.DFASL differ 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 00000000..4d50ba83 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-6-CASE.DFASL differ 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 00000000..0f38f99e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-6-COND.DFASL differ 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 00000000..c1f68434 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-6-IF.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-6-IF.TEST b/internal/test/LANGUAGE/AUTO/7-6-IF.TEST new file mode 100644 index 00000000..4a3fb4c9 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-6-TYPECASE.DFASL b/internal/test/LANGUAGE/AUTO/7-6-TYPECASE.DFASL new file mode 100644 index 00000000..bbb3b82f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-6-TYPECASE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-6-TYPECASE.TEST b/internal/test/LANGUAGE/AUTO/7-6-TYPECASE.TEST new file mode 100644 index 00000000..17978ed5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-6-UNLESS.DFASL b/internal/test/LANGUAGE/AUTO/7-6-UNLESS.DFASL new file mode 100644 index 00000000..1492a14c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-6-UNLESS.DFASL differ 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 00000000..74efc0cf Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-6-WHEN.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-6-WHEN.TEST b/internal/test/LANGUAGE/AUTO/7-6-WHEN.TEST new file mode 100644 index 00000000..f4c37669 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..e334df32 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.TEST b/internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.TEST new file mode 100644 index 00000000..5ea67b9d --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-7-RETURN.DFASL b/internal/test/LANGUAGE/AUTO/7-7-RETURN.DFASL new file mode 100644 index 00000000..bf9496a1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-7-RETURN.DFASL differ 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 00000000..22a10022 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-1-LOOP.DFASL differ 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 00000000..f3046468 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-2-DO.DFASL differ 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 00000000..23394660 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.DFASL differ 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 00000000..d5b0273a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.DFASL differ 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 00000000..6624bf74 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.DFASL differ 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 00000000..bdd73131 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-4-MAPC.DFASL differ 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 00000000..b4e27223 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.TEST b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.TEST new file mode 100644 index 00000000..5aaa6a64 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-8-4-MAPCAR.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.DFASL new file mode 100644 index 00000000..631f08d0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.DFASL differ 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 00000000..6ac055d2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.DFASL differ 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 00000000..aec2214e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-4-MAPL.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPL.TEST b/internal/test/LANGUAGE/AUTO/7-8-4-MAPL.TEST new file mode 100644 index 00000000..5f4d4455 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-8-4-MAPLIST.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.DFASL new file mode 100644 index 00000000..7f9dc3e7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.DFASL differ 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 00000000..e2da1955 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.DFASL differ 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 00000000..ee050df1 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-5-GO.DFASL differ 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 00000000..79b8283d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-5-PROG.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-8-5-PROG.TEST b/internal/test/LANGUAGE/AUTO/7-8-5-PROG.TEST new file mode 100644 index 00000000..5f0c3df4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-8-5-PROGSTAR.DFASL b/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.DFASL new file mode 100644 index 00000000..8907c505 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.DFASL differ 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 00000000..241726d3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.TEST b/internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.TEST new file mode 100644 index 00000000..4cba6a14 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..bee2669d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL differ 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 00000000..0bad97fd Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.TEST b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.TEST new file mode 100644 index 00000000..bae10496 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL new file mode 100644 index 00000000..673f42d5 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL differ 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 00000000..02adbd6f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-EVALUATION-APPLICATION.DFASL differ 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 00000000..934b8db0 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-1.DFASL differ 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 00000000..23c504b6 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-MISC-SITUATIONS.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.DFASL b/internal/test/LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.DFASL new file mode 100644 index 00000000..f3178ae4 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.DFASL differ 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 00000000..2eb5cc9e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/8-1-PARSE-BODY.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/8-1-PARSE-BODY.TEST b/internal/test/LANGUAGE/AUTO/8-1-PARSE-BODY.TEST new file mode 100644 index 00000000..1bd785af --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/8-2-MACROEXPAND-AND-MACROEXPAND-1.TEST b/internal/test/LANGUAGE/AUTO/8-2-MACROEXPAND-AND-MACROEXPAND-1.TEST new file mode 100644 index 00000000..0df15b23 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/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 00000000..18d23ece Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/9-3-THE.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/9-3-THE.TEST b/internal/test/LANGUAGE/AUTO/9-3-THE.TEST new file mode 100644 index 00000000..9f478c52 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/AR-TEST-CASES.DFASL b/internal/test/LANGUAGE/AUTO/AR-TEST-CASES.DFASL new file mode 100644 index 00000000..67e70820 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR-TEST-CASES.DFASL differ 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 00000000..4a9a78a7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR-TEST-CASES.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/AR5741.DFASL b/internal/test/LANGUAGE/AUTO/AR5741.DFASL new file mode 100644 index 00000000..c6dd5179 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR5741.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/AR5741.TEST b/internal/test/LANGUAGE/AUTO/AR5741.TEST new file mode 100644 index 00000000..96f707a5 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR5741.TEST @@ -0,0 +1 @@ +(do-test "prog scoping" (prog ((foo (return t))) nil)) \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/AR6150.DFASL b/internal/test/LANGUAGE/AUTO/AR6150.DFASL new file mode 100644 index 00000000..65070bb2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR6150.DFASL differ 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 00000000..011aa31d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR6247.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/AR6247.TEST b/internal/test/LANGUAGE/AUTO/AR6247.TEST new file mode 100644 index 00000000..673ed6c7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/AR6247.TEST @@ -0,0 +1 @@ +;; AR 6247 test ;; Filed as {ERIS}TEST>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 00000000..ce46bba6 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR6273.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/AR6273.TEST b/internal/test/LANGUAGE/AUTO/AR6273.TEST new file mode 100644 index 00000000..882979f4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/AR6781.DFASL b/internal/test/LANGUAGE/AUTO/AR6781.DFASL new file mode 100644 index 00000000..17e5b9d2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR6781.DFASL differ 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 00000000..c82f53fb Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR7412.DFASL differ 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 00000000..3faaf92e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR7475.DFASL differ 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 00000000..51c34b5a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR7525.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/AR7525.TEST b/internal/test/LANGUAGE/AUTO/AR7525.TEST new file mode 100644 index 00000000..008c6856 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/AR7587-DOC.DFASL b/internal/test/LANGUAGE/AUTO/AR7587-DOC.DFASL new file mode 100644 index 00000000..8b170fa3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR7587-DOC.DFASL differ 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 00000000..89ee6a66 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR7647.DFASL differ 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 00000000..9f8b4b2f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR7742.DFASL differ 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 00000000..4016e449 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR8135.DFASL differ 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 00000000..d4b214aa Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR8136.DFASL differ 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 00000000..bfbdc31c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR8190.DFASL differ 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 00000000..f5e839b3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR8207.DFASL differ 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 00000000..1ec2b6c3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR8297.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/AR8301.DFASL b/internal/test/LANGUAGE/AUTO/AR8301.DFASL new file mode 100644 index 00000000..f2d6afaf Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR8301.DFASL differ 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 00000000..98483055 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR8319.DFASL differ 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 00000000..a1aafdc7 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR8458.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/AR8458.TEST b/internal/test/LANGUAGE/AUTO/AR8458.TEST new file mode 100644 index 00000000..075d4266 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/AR8465.DFASL b/internal/test/LANGUAGE/AUTO/AR8465.DFASL new file mode 100644 index 00000000..51b3d462 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR8465.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/AR8465.TEST b/internal/test/LANGUAGE/AUTO/AR8465.TEST new file mode 100644 index 00000000..320e97f4 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/AR8466.TEST b/internal/test/LANGUAGE/AUTO/AR8466.TEST new file mode 100644 index 00000000..85990a2a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/AR8470.DFASL b/internal/test/LANGUAGE/AUTO/AR8470.DFASL new file mode 100644 index 00000000..ac005eb6 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR8470.DFASL differ 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 00000000..a9449777 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/AR8575.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/AR8575.TEST b/internal/test/LANGUAGE/AUTO/AR8575.TEST new file mode 100644 index 00000000..86290397 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/ARITHMETIC-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/ARITHMETIC-REGRESSION.TEST new file mode 100644 index 00000000..6c07bd5d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/ARITHMETIC-REGRESSION.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/ARRAY.DFASL b/internal/test/LANGUAGE/AUTO/ARRAY.DFASL new file mode 100644 index 00000000..7c0c2454 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/ARRAY.DFASL differ 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 00000000..74b55b95 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/ARRAYP.DFASL differ 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 00000000..49dbcc4c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/ARRAYS-AR6466.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/BIGNUM-PATCH-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/BIGNUM-PATCH-REGRESSION.DFASL new file mode 100644 index 00000000..ea1a146a Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/BIGNUM-PATCH-REGRESSION.DFASL differ 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 00000000..6b3a08fe Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/BINDING.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/BINDING.TEST b/internal/test/LANGUAGE/AUTO/BINDING.TEST new file mode 100644 index 00000000..f9b104bb --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/BINDING.TEST @@ -0,0 +1 @@ +;; Functions To Be Tested: From section 11.2.2 of the IRM ;; ;; Source: IRM, p 11.6 ;; ;; Chapter 5: stkscan ;; ;; Created By: Henry Cate III ;; ;; Creation Date: April 1, 1987 ;; ;; Last Update: ;; ;; Filed As: {eris}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/AUTO/BYTECOMPILER-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.DFASL new file mode 100644 index 00000000..1a19964e Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.DFASL differ 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 00000000..1e3b84f6 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.DFASL differ 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 00000000..b3638823 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CL-INTERPRETER-REGRESSION.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/CL-INTERPRETER-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/CL-INTERPRETER-REGRESSION.TEST new file mode 100644 index 00000000..46480d5b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/CLSTREAMS-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.DFASL new file mode 100644 index 00000000..7d67cc29 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.DFASL differ 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 00000000..34d27f84 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.TEST b/internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.TEST new file mode 100644 index 00000000..beff200b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/CMLARRAY.DFASL b/internal/test/LANGUAGE/AUTO/CMLARRAY.DFASL new file mode 100644 index 00000000..d513be70 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLARRAY.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/CMLARRAY.TEST b/internal/test/LANGUAGE/AUTO/CMLARRAY.TEST new file mode 100644 index 00000000..0024fd3b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/CMLCHARACTER.DFASL b/internal/test/LANGUAGE/AUTO/CMLCHARACTER.DFASL new file mode 100644 index 00000000..269593ce Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLCHARACTER.DFASL differ 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 00000000..4eece1e3 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLFILESYS-REGRESSION.DFASL differ 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 00000000..48356a04 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLFLOAT.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.DFASL new file mode 100644 index 00000000..38a2599f Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.DFASL differ 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 00000000..c4251a76 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLPROGV-REGRESSION.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/CMLPROGV-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/CMLPROGV-REGRESSION.TEST new file mode 100644 index 00000000..a936b70b --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/CMLRAND.DFASL b/internal/test/LANGUAGE/AUTO/CMLRAND.DFASL new file mode 100644 index 00000000..a35d485d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLRAND.DFASL differ 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 00000000..c1e51f99 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.DFASL differ 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 00000000..6a072a67 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.TEST b/internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.TEST new file mode 100644 index 00000000..84c77a94 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/CMLSETF-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.DFASL new file mode 100644 index 00000000..50707a83 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.DFASL differ 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 00000000..a8a29c54 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.DFASL differ diff --git a/internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.TEST new file mode 100644 index 00000000..8fc82fd7 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/CMLTYPES-PATCH.DFASL b/internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.DFASL new file mode 100644 index 00000000..e3ce6a88 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.DFASL differ 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 00000000..2664a2c2 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/DEFSTRUCT-REGRESSION.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/DELETE-SIDE-EFFECT.TEST b/internal/test/LANGUAGE/AUTO/DELETE-SIDE-EFFECT.TEST new file mode 100644 index 00000000..18f897b6 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/DESCRIBE.TEST b/internal/test/LANGUAGE/AUTO/DESCRIBE.TEST new file mode 100644 index 00000000..916427aa --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/DOVEVMEMSIZEPATCH-LLFAULT.TEST b/internal/test/LANGUAGE/AUTO/DOVEVMEMSIZEPATCH-LLFAULT.TEST new file mode 100644 index 00000000..0f284bfd Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/DOVEVMEMSIZEPATCH-LLFAULT.TEST differ 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 00000000..775a9b94 Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/FORMAT-REGRESSION.TEST differ 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 00000000..6c07bd5d Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/REGRESSION.TEST differ 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 00000000..ee94094b Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/STACK.TEST differ 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 00000000..d12d7b8c Binary files /dev/null and b/internal/test/LANGUAGE/AUTO/VECTOR.TEST differ diff --git a/internal/test/LANGUAGE/AUTO/WRAPPERS-AR7900.TEST b/internal/test/LANGUAGE/AUTO/WRAPPERS-AR7900.TEST new file mode 100644 index 00000000..03b3dc4e --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/WRITEFILE-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/WRITEFILE-REGRESSION.TEST new file mode 100644 index 00000000..e024eb2a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/XCL-COMPILER-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/XCL-COMPILER-REGRESSION.TEST new file mode 100644 index 00000000..87367d66 --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/XCLC-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/XCLC-REGRESSION.TEST new file mode 100644 index 00000000..e2a4c7af --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/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/AUTO/Y b/internal/test/LANGUAGE/AUTO/Y new file mode 100644 index 00000000..99fa106a --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/Y @@ -0,0 +1 @@ +FOO(@Z) LAMBDA '511 RETURN FOO name table: (L (0 Z)) code length: argtype: 0 SICX 1 377Q RETURN -X- \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/test-results b/internal/test/LANGUAGE/AUTO/test-results new file mode 100644 index 00000000..7a494a9c --- /dev/null +++ b/internal/test/LANGUAGE/AUTO/test-results @@ -0,0 +1 @@ +;;; Test results for sysout of 18-Oct-88 17:06:07 ;;; Sysout type is SUN3, OS3.4 AR TESTS ;;; Tests run on 28-Oct-88 13:40:10 ;;; Running tests from ({ERIS}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 00000000..cf52829e Binary files /dev/null and b/internal/test/LANGUAGE/Plans/21-STREAMS.NOTEFILE differ 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 00000000..512c2c57 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/14/14-4-MISMATCH.TEST differ 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 00000000..e838a888 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/23/.DFASL differ 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 00000000..bc393615 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-SIMPLE-BIT-VECTOR-P.TEST differ diff --git a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-STRINGP.TEST b/internal/test/LANGUAGE/from-sun/language/6/6-2-2-STRINGP.TEST new file mode 100644 index 00000000..4d821219 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/6/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/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 00000000..a209fd14 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/DO-TEST.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/README b/internal/test/LANGUAGE/from-sun/language/README new file mode 100644 index 00000000..3b592dae --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/README @@ -0,0 +1 @@ +This is the test directory containing all Automatic Language Tests. All the files should be plain text with all CR's converted to LF's. The files are organized according to chapters of CLTL, along with an directory for specific AR tests, and one containing OTHER files. \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR5741.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR5741.TEST new file mode 100644 index 00000000..96f707a5 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR5741.TEST @@ -0,0 +1 @@ +(do-test "prog scoping" (prog ((foo (return t))) nil)) \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR6150.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR6150.TEST new file mode 100644 index 00000000..804b5294 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/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/from-sun/language/ar/AR6247.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR6247.TEST new file mode 100644 index 00000000..673ed6c7 --- /dev/null +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR6247.TEST @@ -0,0 +1 @@ +;; AR 6247 test ;; Filed as {ERIS}TEST>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)) <23Cz \ 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 00000000..0b7ff9d0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/other/SINGLE-OP-ARITH.TEST differ 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 00000000..bc20495e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GET-PROPERTIES.DFASL differ 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 00000000..8190a18d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GET.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GETF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GETF.DFASL new file mode 100644 index 00000000..a64b46f2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GETF.DFASL differ 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 00000000..d48beabb Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-REMF.DFASL differ 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 00000000..99dfb0ce Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-REMPROP.DFASL differ 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 00000000..2a4f746c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-SYMBOL-PLIST.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-2-SYMBOL-NAME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-2-SYMBOL-NAME.DFASL new file mode 100644 index 00000000..df5817be Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-2-SYMBOL-NAME.DFASL differ 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 00000000..72776bb3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-COPY-SYMBOL.DFASL differ 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 00000000..a1fd9e10 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-GENSYM.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-GENTEMP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-GENTEMP.DFASL new file mode 100644 index 00000000..91fcafb4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-GENTEMP.DFASL differ 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 00000000..10a0b242 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-KEYWORDP.DFASL differ 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 00000000..425dc7d4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-MAKE-SYMBOL.DFASL differ 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 00000000..1ac880d5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-SYMBOL-PACKAGE.DFASL differ 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 00000000..28d8969a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-6-IMPORT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-ALL-SYMBOLS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-ALL-SYMBOLS.DFASL new file mode 100644 index 00000000..662895b8 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-ALL-SYMBOLS.DFASL differ 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 00000000..d46292b0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-EXTERNAL-SYMBOLS.DFASL differ 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 00000000..24700b43 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-SYMBOLS.DFASL differ 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 00000000..fb742032 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-EXPORT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-ALL-SYMBOLS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-ALL-SYMBOLS.DFASL new file mode 100644 index 00000000..1c29266f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-ALL-SYMBOLS.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-PACKAGE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-PACKAGE.DFASL new file mode 100644 index 00000000..fe0896f3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-PACKAGE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-SYMBOL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-SYMBOL.DFASL new file mode 100644 index 00000000..e185e8c8 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-SYMBOL.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-IMPORT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-IMPORT.DFASL new file mode 100644 index 00000000..cab7952b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-IMPORT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-IN-PACKAGE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-IN-PACKAGE.DFASL new file mode 100644 index 00000000..6127e649 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-IN-PACKAGE.DFASL differ 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 00000000..c10ba974 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-INTERN.DFASL differ 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 00000000..5e155506 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-LIST-ALL-PACKAGES.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-MAKE-PACKAGE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-MAKE-PACKAGE.DFASL new file mode 100644 index 00000000..88070d30 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-MAKE-PACKAGE.DFASL differ 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 00000000..a64c827e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-NAME.DFASL differ 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 00000000..33ad1be1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-NICKNAMES.DFASL differ 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 00000000..cd484fc1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-USE-LIST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-USE-LIST.DFASL new file mode 100644 index 00000000..ed56cc99 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-USE-LIST.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-USED-BY-LIST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-USED-BY-LIST.DFASL new file mode 100644 index 00000000..d44cbb36 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-USED-BY-LIST.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-RENAME-PACKAGE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-RENAME-PACKAGE.DFASL new file mode 100644 index 00000000..a0450ce7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-RENAME-PACKAGE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-SHADOW.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-SHADOW.DFASL new file mode 100644 index 00000000..f75aa46c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-SHADOW.DFASL differ 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 00000000..b020270d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-SHADOWING-IMPORT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNEXPORT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNEXPORT.DFASL new file mode 100644 index 00000000..b249238a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNEXPORT.DFASL differ 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 00000000..8f9c0e12 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNINTERN.DFASL differ 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 00000000..f796c55c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNUSE-PACKAGE.DFASL differ 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 00000000..3af07b5c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-USE-PACKAGE.DFASL differ 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 00000000..9c4b403e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/11-8-PROVIDE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-10-IMPLEMENTATION-PARAMETERS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-10-IMPLEMENTATION-PARAMETERS.DFASL new file mode 100644 index 00000000..e6ebcf6c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-10-IMPLEMENTATION-PARAMETERS.DFASL differ 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 00000000..6c263796 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-EVENP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-MINUSP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-MINUSP.DFASL new file mode 100644 index 00000000..87636c1c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-MINUSP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-ODDP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-ODDP.DFASL new file mode 100644 index 00000000..0677139e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-ODDP.DFASL differ 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 00000000..fd398704 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-PLUSP.DFASL differ 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 00000000..96004e1e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-ZEROP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-EQP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-EQP.DFASL new file mode 100644 index 00000000..1f323114 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-EQP.DFASL differ 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 00000000..af8b8189 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-GEQ.DFASL differ 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 00000000..d315d2f4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-GREATERP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-LEQ.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-LEQ.DFASL new file mode 100644 index 00000000..04fddfc1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-LEQ.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-LESSP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-LESSP.DFASL new file mode 100644 index 00000000..7d272754 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-LESSP.DFASL differ 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 00000000..b0c4dc13 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-MAX.DFASL differ 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 00000000..d6ea5edf Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-MIN.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-NEQP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-NEQP.DFASL new file mode 100644 index 00000000..d2727e0c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-NEQP.DFASL differ 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 00000000..7bb06066 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-+.DFASL differ 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 00000000..9a86d40c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4--.DFASL differ 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 00000000..26a3b123 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-1+.DFASL differ 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 00000000..d291e91a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-1-.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-CONJUGATE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-CONJUGATE.DFASL new file mode 100644 index 00000000..b1af9267 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-CONJUGATE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-DECF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-DECF.DFASL new file mode 100644 index 00000000..639240c2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-DECF.DFASL differ 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 00000000..1a7d2aac Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-GCD.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-INCF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-INCF.DFASL new file mode 100644 index 00000000..645e96c5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-INCF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-LCM.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-LCM.DFASL new file mode 100644 index 00000000..8406d795 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-LCM.DFASL differ 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 00000000..1330a09d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-QUOTIENT.DFASL differ 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 00000000..5d0f26f6 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-TIMES.DFASL differ 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 00000000..134ccfa5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-EXP.DFASL differ 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 00000000..97023147 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-EXPT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-ISQRT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-ISQRT.DFASL new file mode 100644 index 00000000..31064a09 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-ISQRT.DFASL differ 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 00000000..52cb5ad4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-LOG.DFASL differ 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 00000000..5d9bef85 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-SQRT.DFASL differ 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 00000000..a85443eb Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ABS.DFASL differ 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 00000000..af7bfde0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ACOS.DFASL differ 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 00000000..0babd097 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ACOSH.DFASL differ 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 00000000..c127ce2a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ASIN.DFASL differ 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 00000000..56d9b955 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ASINH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ATAN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ATAN.DFASL new file mode 100644 index 00000000..7d003a92 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ATAN.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ATANH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ATANH.DFASL new file mode 100644 index 00000000..7a4bd970 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ATANH.DFASL differ 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 00000000..2e4e2164 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-CIS.DFASL differ 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 00000000..1500e6ca Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-COS.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-COSH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-COSH.DFASL new file mode 100644 index 00000000..5d7190ef Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-COSH.DFASL differ 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 00000000..4695723c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-PHASE.DFASL differ 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 00000000..866665fb Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SIGNUM.DFASL differ 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 00000000..0927b084 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SIN.DFASL differ 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 00000000..70a98602 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SINH.DFASL differ 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 00000000..5f9aab29 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-TAN.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-TANH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-TANH.DFASL new file mode 100644 index 00000000..1cfaf94f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-TANH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-CEILING.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-CEILING.DFASL new file mode 100644 index 00000000..27798b65 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-CEILING.DFASL differ 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 00000000..861ea10f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-COMPLEX.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-DECODE-FLOAT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-DECODE-FLOAT.DFASL new file mode 100644 index 00000000..3fcbb3d5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-DECODE-FLOAT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-DENOMINATOR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-DENOMINATOR.DFASL new file mode 100644 index 00000000..c709c252 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-DENOMINATOR.DFASL differ 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 00000000..0bd76882 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FCEILING.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FFLOOR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FFLOOR.DFASL new file mode 100644 index 00000000..82b5029b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FFLOOR.DFASL differ 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 00000000..c74fc801 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-DIGITS.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-PRECISION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-PRECISION.DFASL new file mode 100644 index 00000000..052268f2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-PRECISION.DFASL differ 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 00000000..fbb1a041 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-RADIX.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-SIGN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-SIGN.DFASL new file mode 100644 index 00000000..a282844d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-SIGN.DFASL differ 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 00000000..d79f7f56 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT.DFASL differ 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 00000000..55806686 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOOR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FROUND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FROUND.DFASL new file mode 100644 index 00000000..92698194 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FROUND.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FTRUNCATE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FTRUNCATE.DFASL new file mode 100644 index 00000000..48cbc0ca Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FTRUNCATE.DFASL differ 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 00000000..e5b3fe50 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-IMAGPART.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-INTEGER-DECODE-FLOAT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-INTEGER-DECODE-FLOAT.DFASL new file mode 100644 index 00000000..eb99080e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-INTEGER-DECODE-FLOAT.DFASL differ 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 00000000..ebd1d962 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-MOD.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-NUMERATOR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-NUMERATOR.DFASL new file mode 100644 index 00000000..fa5a2d8a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-NUMERATOR.DFASL differ 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 00000000..62b206bf Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-RATIONAL.DFASL differ 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 00000000..863ee24d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-RATIONALIZE.DFASL differ 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 00000000..859b2eb7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-REALPART.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-REM.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-REM.DFASL new file mode 100644 index 00000000..48f2c106 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-REM.DFASL differ 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 00000000..28ebef26 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-ROUND.DFASL differ 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 00000000..3cea44d2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-SCALE-FLOAT.DFASL differ 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 00000000..28b199e4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-TRUNCATE.DFASL differ 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 00000000..96059e25 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-ASH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-BOOLE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-BOOLE.DFASL new file mode 100644 index 00000000..e5814b58 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-BOOLE.DFASL differ 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 00000000..d75fa05a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-INTEGER-LENGTH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGAND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGAND.DFASL new file mode 100644 index 00000000..46f2f8e2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGAND.DFASL differ 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 00000000..9c2eebf5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGANDC1.DFASL differ 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 00000000..1a2bae27 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGANDC2.DFASL differ 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 00000000..a6e264ac Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGBITP.DFASL differ 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 00000000..8d0954bb Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGCOUNT.DFASL differ 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 00000000..4337e12f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGEQV.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGIOR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGIOR.DFASL new file mode 100644 index 00000000..619ef08f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGIOR.DFASL differ 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 00000000..25334118 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNAND.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNOR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNOR.DFASL new file mode 100644 index 00000000..8adb2160 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNOR.DFASL differ 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 00000000..e04679d5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNOT.DFASL differ 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 00000000..49ebbbd3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGORC1.DFASL differ 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 00000000..4c730c3f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGORC2.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGTEST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGTEST.DFASL new file mode 100644 index 00000000..fd316cb1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGTEST.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGXOR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGXOR.DFASL new file mode 100644 index 00000000..e0ac9086 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGXOR.DFASL differ 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 00000000..5ccd5880 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE-POSITION.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE-SIZE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE-SIZE.DFASL new file mode 100644 index 00000000..fe485a64 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE-SIZE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE.DFASL new file mode 100644 index 00000000..da67d003 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-DEPOSIT-FIELD.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-DEPOSIT-FIELD.DFASL new file mode 100644 index 00000000..31f50c26 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-DEPOSIT-FIELD.DFASL differ 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 00000000..fed7ff8d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-DPB.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-LDB-TEST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-LDB-TEST.DFASL new file mode 100644 index 00000000..b4ef2a98 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-LDB-TEST.DFASL differ 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 00000000..957524c6 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-LDB.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-MASK-FIELD.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-MASK-FIELD.DFASL new file mode 100644 index 00000000..fab175e1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-MASK-FIELD.DFASL differ 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 00000000..17224daf Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-9-MAKE-RANDOM-STATE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-9-RANDOM.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-9-RANDOM.DFASL new file mode 100644 index 00000000..f0da6bfd Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/12-9-RANDOM.DFASL differ 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 00000000..6c3868e5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-1-CHARACTERATTRIBUTES.DFASL differ 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 00000000..1c17bc96 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-ALPHA-CHAR-P.DFASL differ 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 00000000..03f20fe7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-ALPHANUMERIC-P.DFASL differ 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 00000000..7460aa14 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-BOTH-CASE-P.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-EQUAL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-EQUAL.DFASL new file mode 100644 index 00000000..ee9d8667 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-EQUAL.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GE.DFASL new file mode 100644 index 00000000..0af83b52 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GREATERP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GREATERP.DFASL new file mode 100644 index 00000000..004d2407 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GREATERP.DFASL differ 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 00000000..61e24482 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GT.DFASL differ 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 00000000..fffa1b05 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LESSP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LESSP.DFASL new file mode 100644 index 00000000..4ff95024 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LESSP.DFASL differ 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 00000000..518f8fb7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LT.DFASL differ 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 00000000..ae1c7bac Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-EQUAL.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-GREATERP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-GREATERP.DFASL new file mode 100644 index 00000000..4d8353bc Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-GREATERP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-LESSP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-LESSP.DFASL new file mode 100644 index 00000000..c54248ef Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-LESSP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAREQ.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAREQ.DFASL new file mode 100644 index 00000000..9afb4d4b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAREQ.DFASL differ 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 00000000..b5f19e2b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHARNEQ.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-DIGIT-CHAR-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-DIGIT-CHAR-P.DFASL new file mode 100644 index 00000000..fd9cb597 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-DIGIT-CHAR-P.DFASL differ 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 00000000..09672706 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-GRAPHIC-CHAR-P.DFASL differ 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 00000000..d44f218c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-LOWER-CASE-P.DFASL differ 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 00000000..2fe40eb4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-STANDARD-CHAR-P.DFASL differ 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 00000000..4883752b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-STRING-CHAR-P.DFASL differ 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 00000000..c7e6f071 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-UPPER-CASE-P.DFASL differ 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 00000000..08ec313d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-BITS.DFASL differ 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 00000000..cd743c45 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-CODE.DFASL differ 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 00000000..9c5db677 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-FONT.DFASL differ 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 00000000..e2b1f7f3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CODE-CHAR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-MAKE-CHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-MAKE-CHAR.DFASL new file mode 100644 index 00000000..53298896 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-MAKE-CHAR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-DOWNCASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-DOWNCASE.DFASL new file mode 100644 index 00000000..17376176 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-DOWNCASE.DFASL differ 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 00000000..30fed284 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-INT.DFASL differ 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 00000000..673ff432 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-NAME.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-UPCASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-UPCASE.DFASL new file mode 100644 index 00000000..b602c632 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-UPCASE.DFASL differ 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 00000000..bfa3a3f3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHARACTER.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-DIGIT-CHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-DIGIT-CHAR.DFASL new file mode 100644 index 00000000..c52b48f7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-DIGIT-CHAR.DFASL differ 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 00000000..2c13d0e5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-INT-CHAR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-NAME-CHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-NAME-CHAR.DFASL new file mode 100644 index 00000000..b270db6f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-NAME-CHAR.DFASL differ 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 00000000..5281db2d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-5-CHAR-BIT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-5-SET-CHAR-BIT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-5-SET-CHAR-BIT.DFASL new file mode 100644 index 00000000..1fe2e865 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/13-5-SET-CHAR-BIT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-COPY-SEQ.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-COPY-SEQ.DFASL new file mode 100644 index 00000000..ae17143b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-COPY-SEQ.DFASL differ 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 00000000..e965aa7c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-ELT.DFASL differ 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 00000000..bdc81e2f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-LENGTH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-MAKE-SEQUENCE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-MAKE-SEQUENCE.DFASL new file mode 100644 index 00000000..d3b90b60 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-MAKE-SEQUENCE.DFASL differ 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 00000000..3ffc5f5e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-NREVERSE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-REVERSE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-REVERSE.DFASL new file mode 100644 index 00000000..7df65acf Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-REVERSE.DFASL differ 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 00000000..d3673a22 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-SUBSEQ.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-CONCATENATE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-CONCATENATE.DFASL new file mode 100644 index 00000000..08352fa3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-CONCATENATE.DFASL differ 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 00000000..2bb6ef00 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-EVERY.DFASL differ 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 00000000..61fe2602 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-MAP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-NOTANY.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-NOTANY.DFASL new file mode 100644 index 00000000..91a6e80c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-NOTANY.DFASL differ 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 00000000..2345bddc Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-NOTEVERY.DFASL differ 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 00000000..296f84e8 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-REDUCE.DFASL differ 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 00000000..77aa73b1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-SOME.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-DUPLICATES.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-DUPLICATES.DFASL new file mode 100644 index 00000000..8cc60703 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-DUPLICATES.DFASL differ 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 00000000..3cbc8a1e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-IF-NOT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-IF.DFASL new file mode 100644 index 00000000..94bb6452 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-IF.DFASL differ 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 00000000..f04311fb Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FILL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FILL.DFASL new file mode 100644 index 00000000..bf174fea Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FILL.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND-IF-NOT.DFASL new file mode 100644 index 00000000..06afa871 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND-IF-NOT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND-IF.DFASL new file mode 100644 index 00000000..a2f7c4b9 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND-IF.DFASL differ 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 00000000..8f806d47 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND.DFASL differ 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 00000000..6e5737c1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE-IF-NOT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE-IF.DFASL new file mode 100644 index 00000000..6c69f9ae Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE-IF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE.DFASL new file mode 100644 index 00000000..83ed1a49 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE.DFASL differ 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 00000000..13ed8013 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION-IF-NOT.DFASL differ 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 00000000..9c87410c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION-IF.DFASL differ 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 00000000..adaca5a2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-DUPLICATES.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-DUPLICATES.DFASL new file mode 100644 index 00000000..893d50d6 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-DUPLICATES.DFASL differ 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 00000000..35a1777e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-IF-NOT.DFASL differ 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 00000000..84483dd3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-IF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE.DFASL new file mode 100644 index 00000000..b311a9a2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE.DFASL differ 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 00000000..3fe3649e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE-IF-NOT.DFASL differ 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 00000000..0e383f7f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE-IF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE.DFASL new file mode 100644 index 00000000..b472e39f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE.DFASL differ 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 00000000..fb21e499 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT-IF-NOT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT-IF.DFASL new file mode 100644 index 00000000..2c726210 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT-IF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT.DFASL new file mode 100644 index 00000000..0b107f52 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT.DFASL differ 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 00000000..8b06e578 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-MISMATCH.DFASL differ 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 00000000..f090eb3e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-MERGE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-SORT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-SORT.DFASL new file mode 100644 index 00000000..32004db0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-SORT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-STABLE-SORT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-STABLE-SORT.DFASL new file mode 100644 index 00000000..785ac9f0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-STABLE-SORT.DFASL differ 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 00000000..bdc8b34a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAAAR.DFASL differ 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 00000000..b36fb5c1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAADR.DFASL differ 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 00000000..4059ed9f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAAR.DFASL differ 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 00000000..0531da85 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADAR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADDR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADDR.DFASL new file mode 100644 index 00000000..7f75e2ac Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADDR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADR.DFASL new file mode 100644 index 00000000..139da523 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADR.DFASL differ 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 00000000..82e127bc Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADAA.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADAA.DFASL new file mode 100644 index 00000000..1c79b7cb Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADAA.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADADR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADADR.DFASL new file mode 100644 index 00000000..34487b62 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADADR.DFASL differ 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 00000000..9183c5f6 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADAR.DFASL differ 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 00000000..ae5bfd66 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDAR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDDR-AND-FOURTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDDR-AND-FOURTH.DFASL new file mode 100644 index 00000000..17374008 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDDR-AND-FOURTH.DFASL differ 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 00000000..366ca367 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDR-AND-THIRD.DFASL differ 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 00000000..88ef70b9 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADR-AND-SECOND.DFASL differ 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 00000000..392eac1d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAR-AND-FIRST.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAAAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAAAR.DFASL new file mode 100644 index 00000000..d24fb7ee Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAAAR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAADR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAADR.DFASL new file mode 100644 index 00000000..9cdc72c9 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAADR.DFASL differ 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 00000000..0318cbdc Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAAR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADAR.DFASL new file mode 100644 index 00000000..6b46fd84 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADAR.DFASL differ 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 00000000..ff17dc27 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADDR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADR.DFASL new file mode 100644 index 00000000..45e1fc46 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADR.DFASL differ 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 00000000..b6a8c077 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAR.DFASL differ 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 00000000..dc54729e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDAAR.DFASL differ 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 00000000..c94be82e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDADR.DFASL differ 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 00000000..cc162b25 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDAR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDAR.DFASL new file mode 100644 index 00000000..5e1c43f9 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDAR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDDR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDDR.DFASL new file mode 100644 index 00000000..0ce5aacc Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDDR.DFASL differ 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 00000000..b14962f7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDR.DFASL differ 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 00000000..b79f95dd Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDR.DFASL differ 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 00000000..f1c02095 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDR-AND-REST.DFASL differ 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 00000000..88aa7b2a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CONS.DFASL differ 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 00000000..034658e0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-TREE-EQUAL.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-APPEND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-APPEND.DFASL new file mode 100644 index 00000000..9416c5a2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-APPEND.DFASL differ 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 00000000..acf03d45 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-BUTLAST.DFASL differ 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 00000000..709bb06f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-ALIST.DFASL differ 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 00000000..d91886a7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-LIST.DFASL differ 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 00000000..5cfa7e66 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-TREE.DFASL differ 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 00000000..2105724b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-EIGHTH.DFASL differ 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 00000000..cb42b166 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-ENDP.DFASL differ 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 00000000..546dad86 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FIFTH.DFASL differ 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 00000000..d948ff1a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FIRST.DFASL differ 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 00000000..0c9b92dc Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FOURTH.DFASL differ 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 00000000..8c9af132 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LAST.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LDIFF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LDIFF.DFASL new file mode 100644 index 00000000..e9af7281 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LDIFF.DFASL differ 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 00000000..caa62b35 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LIST-LENGTH.DFASL differ 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 00000000..ba1292d1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LIST.DFASL differ 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 00000000..1e643626 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LISTSTAR.DFASL differ 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 00000000..042ff3bd Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-MAKE-LIST.DFASL differ 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 00000000..c38b79e7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NBUTLAST.DFASL differ 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 00000000..5a54bc84 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NCONC.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NINTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NINTH.DFASL new file mode 100644 index 00000000..b83f4772 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NINTH.DFASL differ 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 00000000..3382886d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NRECONC.DFASL differ 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 00000000..bf8ffd97 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NTH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NTHCDR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NTHCDR.DFASL new file mode 100644 index 00000000..5e02c7cc Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NTHCDR.DFASL differ 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 00000000..19faf6d2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-POP.DFASL differ 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 00000000..dc98fbc3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-PUSH.DFASL differ 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 00000000..0857a4c9 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-PUSHNEW.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-REST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-REST.DFASL new file mode 100644 index 00000000..5f4efdc6 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-REST.DFASL differ 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 00000000..2c6ad1d1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-REVAPPEND.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SECOND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SECOND.DFASL new file mode 100644 index 00000000..241e62b6 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SECOND.DFASL differ 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 00000000..cc8cede8 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SEVENTH.DFASL differ 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 00000000..2e78f49c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SIXTH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-TENTH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-TENTH.DFASL new file mode 100644 index 00000000..c9f3aad4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-TENTH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-THIRD.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-THIRD.DFASL new file mode 100644 index 00000000..844e030c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-THIRD.DFASL differ 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 00000000..4618dd24 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-3-RPLACA.DFASL differ 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 00000000..c20aeb33 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-3-RPLACD.DFASL differ 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 00000000..a4f22773 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBLIS.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST-IF-NOT.DFASL new file mode 100644 index 00000000..6ef07d78 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST-IF-NOT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST-IF.DFASL new file mode 100644 index 00000000..9e1479e1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST-IF.DFASL differ 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 00000000..5a66cd13 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST.DFASL differ 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 00000000..b6585e60 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBLIS.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST-IF-NOT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST-IF-NOT.DFASL new file mode 100644 index 00000000..fdefbaf4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST-IF-NOT.DFASL differ 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 00000000..b933b383 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST-IF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST.DFASL new file mode 100644 index 00000000..df7e4c81 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST.DFASL differ 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 00000000..0a562c90 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-ADJOIN.DFASL differ 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 00000000..7bd59703 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-INTERSECTION.DFASL differ 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 00000000..ac0e97ec Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER-IF-NOT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER-IF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER-IF.DFASL new file mode 100644 index 00000000..e922c593 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER-IF.DFASL differ 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 00000000..57dec952 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER.DFASL differ 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 00000000..082dcb7b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NINTERSECTION.DFASL differ 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 00000000..d676aa62 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NSET-DIFFERENCE.DFASL differ 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 00000000..7744e28e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NSET-EXCLUSIVE-OR.DFASL differ 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 00000000..747671d3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NUNION.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-SET-DIFFERENCE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-SET-DIFFERENCE.DFASL new file mode 100644 index 00000000..7abdb163 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-SET-DIFFERENCE.DFASL differ 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 00000000..ec1d5752 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-SUBSETP.DFASL differ 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 00000000..4c81e2e2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-TAILP.DFASL differ 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 00000000..dfe9f825 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-UNION.DFASL differ 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 00000000..c449fae4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ACONS.DFASL differ 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 00000000..dc76d324 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC-IF-NOT.DFASL differ 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 00000000..04d60199 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC-IF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC.DFASL new file mode 100644 index 00000000..40cf353f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-PAIRLIS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-PAIRLIS.DFASL new file mode 100644 index 00000000..95e68155 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-PAIRLIS.DFASL differ 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 00000000..efab7bac Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC-IF-NOT.DFASL differ 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 00000000..77f53c11 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC-IF.DFASL differ 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 00000000..21b79764 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC.DFASL differ 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 00000000..8de3af0b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-CLRHASH.DFASL differ 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 00000000..5a3d0137 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-GETHASH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-HASH-TABLE-COUNT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-HASH-TABLE-COUNT.DFASL new file mode 100644 index 00000000..486fef64 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-HASH-TABLE-COUNT.DFASL differ 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 00000000..498bbcb8 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-HASH-TABLE-P.DFASL differ 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 00000000..d3ad9392 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-MAKE-HASH-TABLE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-MAPHASH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-MAPHASH.DFASL new file mode 100644 index 00000000..1bb34f08 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-MAPHASH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-REMHASH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-REMHASH.DFASL new file mode 100644 index 00000000..37b7b36b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-REMHASH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-2-SXHASH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-2-SXHASH.DFASL new file mode 100644 index 00000000..5fb1d339 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/16-2-SXHASH.DFASL differ 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 00000000..675f7c6e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-1-MAKE-ARRAY.DFASL differ 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 00000000..d1e80647 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-1-VECTOR.DFASL differ 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 00000000..fe350ac3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-2-AREF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-2-SVREF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-2-SVREF.DFASL new file mode 100644 index 00000000..0bff00f8 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-2-SVREF.DFASL differ 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 00000000..7160a5bd Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ADJUSTABLE-ARRAY-P.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-DIMENSION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-DIMENSION.DFASL new file mode 100644 index 00000000..a7da2773 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-DIMENSION.DFASL differ 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 00000000..3f22f31a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-DIMENSIONS.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-ELEMENT-TYPE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-ELEMENT-TYPE.DFASL new file mode 100644 index 00000000..f64e73b3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-ELEMENT-TYPE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-IN-BOUNDS-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-IN-BOUNDS-P.DFASL new file mode 100644 index 00000000..620c9c30 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-IN-BOUNDS-P.DFASL differ 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 00000000..ab325979 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-RANK.DFASL differ 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 00000000..9e3211ef Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-ROW-MAJOR-INDEX.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-TOTAL-SIZE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-TOTAL-SIZE.DFASL new file mode 100644 index 00000000..0101ba7d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-TOTAL-SIZE.DFASL differ 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 00000000..019b065d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-AND.DFASL differ 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 00000000..5788b48f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ANDC1.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ANDC2.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ANDC2.DFASL new file mode 100644 index 00000000..258b779c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ANDC2.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-EQV.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-EQV.DFASL new file mode 100644 index 00000000..9ea46e53 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-EQV.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-IOR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-IOR.DFASL new file mode 100644 index 00000000..50cbd1c7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-IOR.DFASL differ 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 00000000..97c5aa7f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NAND.DFASL differ 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 00000000..348e3021 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NOR.DFASL differ 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 00000000..a72ccd2b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NOT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ORC1.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ORC1.DFASL new file mode 100644 index 00000000..676f4ac6 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ORC1.DFASL differ 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 00000000..3ae1a89c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ORC2.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-XOR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-XOR.DFASL new file mode 100644 index 00000000..b9d23795 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-XOR.DFASL differ 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 00000000..2025ec2a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-SBIT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-SBIT.DFASL new file mode 100644 index 00000000..6b8ee2cb Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-SBIT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-ARRAY-HAS-FILL-POINTER-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-ARRAY-HAS-FILL-POINTER-P.DFASL new file mode 100644 index 00000000..b5f4a714 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-ARRAY-HAS-FILL-POINTER-P.DFASL differ 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 00000000..9bedb1f7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-FILL-POINTER.DFASL differ 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 00000000..0511c4e5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-POP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-PUSH-EXTEND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-PUSH-EXTEND.DFASL new file mode 100644 index 00000000..761ec79b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-PUSH-EXTEND.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-PUSH.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-PUSH.DFASL new file mode 100644 index 00000000..b1a05adf Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-PUSH.DFASL differ 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 00000000..78d1b3d1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/17-6-ADJUST-ARRAY.DFASL differ 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 00000000..9f6a81ea Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-1-CHAR.DFASL differ 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 00000000..415202ab Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-1-SCHAR.DFASL differ 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 00000000..b691b9b3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-EQ.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-EQUAL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-EQUAL.DFASL new file mode 100644 index 00000000..f09e785c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-EQUAL.DFASL differ 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 00000000..81e063ec Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GREATERP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GREATERP.DFASL new file mode 100644 index 00000000..24196377 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GREATERP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GT.DFASL new file mode 100644 index 00000000..9321bb41 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GT.DFASL differ 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 00000000..047a9221 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LE.DFASL differ 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 00000000..0a0e017b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LESSP.DFASL differ 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 00000000..5a7c32b4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LT.DFASL differ 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 00000000..6fbcf3e4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NEQ.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-EQUAL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-EQUAL.DFASL new file mode 100644 index 00000000..d28f1f91 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-EQUAL.DFASL differ 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 00000000..615c8a7b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-GREATERP.DFASL differ 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 00000000..b7ecdd94 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-LESSP.DFASL differ 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 00000000..11c9bff8 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-MAKE-STRING.DFASL differ 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 00000000..402fe0c0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-CAPITALIZE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-DOWNCASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-DOWNCASE.DFASL new file mode 100644 index 00000000..aef1aced Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-DOWNCASE.DFASL differ 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 00000000..870d016a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-UPCASE.DFASL differ 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 00000000..57f962a0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-CAPITALIZE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-DOWNCASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-DOWNCASE.DFASL new file mode 100644 index 00000000..fc979a19 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-DOWNCASE.DFASL differ 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 00000000..d3edceb4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-LEFT-TRIM.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-RIGHT-TRIM.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-RIGHT-TRIM.DFASL new file mode 100644 index 00000000..73ec7291 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-RIGHT-TRIM.DFASL differ 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 00000000..86f0308b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-TRIM.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-UPCASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-UPCASE.DFASL new file mode 100644 index 00000000..9a59a064 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-UPCASE.DFASL differ 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 00000000..1880be5d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING.DFASL differ 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 00000000..956ad958 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-APPLYHOOK.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-CONSTANTP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-CONSTANTP.DFASL new file mode 100644 index 00000000..2991f22d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-CONSTANTP.DFASL differ 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 00000000..da2e3e87 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-EVAL.DFASL differ 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 00000000..73f41b07 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-COPY-READTABLE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL new file mode 100644 index 00000000..5d093244 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL differ 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 00000000..49061ee0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-GET-MACRO-CHARACTER.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL new file mode 100644 index 00000000..572b506f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL differ 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 00000000..e7a29899 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-READTABLEP.DFASL differ 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 00000000..bf369439 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-MACRO-CHARACTER.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-MACRO-CHARACTER.DFASL new file mode 100644 index 00000000..9b3e2743 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-MACRO-CHARACTER.DFASL differ 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 00000000..861d7759 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-SYNTAX-FROM-CHAR.DFASL differ 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 00000000..356b0dac Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-LISTEN.DFASL differ 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 00000000..26a161b0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-PARSE-INTEGER.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-PEEK-CHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-PEEK-CHAR.DFASL new file mode 100644 index 00000000..97eebfae Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-PEEK-CHAR.DFASL differ 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 00000000..baac4a29 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-CHAR-NO-HANG.DFASL differ 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 00000000..d5edee26 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-CHAR.DFASL differ 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 00000000..e9ada3b3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-DELIMITED-LIST.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-PRESERVING-WHITESPACE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-PRESERVING-WHITESPACE.DFASL new file mode 100644 index 00000000..fa5ea2b4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-PRESERVING-WHITESPACE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ.DFASL new file mode 100644 index 00000000..ef6a5aff Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-UNREAD-CHAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-UNREAD-CHAR.DFASL new file mode 100644 index 00000000..6024e6d7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-UNREAD-CHAR.DFASL differ 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 00000000..7ae5cdc1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-FINISH-OUTPUT.DFASL differ 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 00000000..7e5e6648 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-FRESH-LINE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PPRINT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PPRINT.DFASL new file mode 100644 index 00000000..182ad503 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PPRINT.DFASL differ 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 00000000..87392812 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRIN1-TO-STRING.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRIN1.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRIN1.DFASL new file mode 100644 index 00000000..506b2308 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRIN1.DFASL differ 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 00000000..733874a1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINC-TO-STRING.DFASL differ 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 00000000..b01ccf24 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINC.DFASL differ 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 00000000..a01fe223 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-TERPRI.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-TERPRI.DFASL new file mode 100644 index 00000000..3576b03a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-TERPRI.DFASL differ 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 00000000..3c021f9c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-CHAR.DFASL differ 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 00000000..a49afc60 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-LINE.DFASL differ 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 00000000..026dd632 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-STRING.DFASL differ 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 00000000..e0b92d1b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-3-FORMAT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/23-FUNCTIONS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/23-FUNCTIONS.DFASL new file mode 100644 index 00000000..b152cd21 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/23-FUNCTIONS.DFASL differ 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 00000000..19d14e50 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-BREAK.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-CERROR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-CERROR.DFASL new file mode 100644 index 00000000..305bee87 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-CERROR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-ERROR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-ERROR.DFASL new file mode 100644 index 00000000..e2872f60 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-ERROR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-WARN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-WARN.DFASL new file mode 100644 index 00000000..b8223d41 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-WARN.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-2-ASSERT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-2-ASSERT.DFASL new file mode 100644 index 00000000..373d67f9 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-2-ASSERT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-CCASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-CCASE.DFASL new file mode 100644 index 00000000..4809f1cc Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-CCASE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-CTYPECASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-CTYPECASE.DFASL new file mode 100644 index 00000000..ecaae617 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-CTYPECASE.DFASL differ 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 00000000..4733e3fc Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-ECASE.DFASL differ 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 00000000..c623a3bf Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-ETYPECASE.DFASL differ 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 00000000..21330442 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-COMPILE-FILE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-COMPILE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-COMPILE.DFASL new file mode 100644 index 00000000..7d0335ee Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-COMPILE.DFASL differ 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 00000000..2652bbce Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-DISASSEMBLE.DFASL differ 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 00000000..05156ceb Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-2-DOCUMENTATION.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-APROPOS-LIST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-APROPOS-LIST.DFASL new file mode 100644 index 00000000..407fc391 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-APROPOS-LIST.DFASL differ 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 00000000..3c468513 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-APROPOS.DFASL differ 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 00000000..30effa98 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-DESCRIBE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-ED.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-ED.DFASL new file mode 100644 index 00000000..11c0d959 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-ED.DFASL differ 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 00000000..55d58378 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-INSPECT.DFASL differ 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 00000000..23117622 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-ROOM.DFASL differ 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 00000000..da40ef37 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-TIME.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-DECODE-UNIVERSAL-TIME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-DECODE-UNIVERSAL-TIME.DFASL new file mode 100644 index 00000000..c57c6332 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-DECODE-UNIVERSAL-TIME.DFASL differ 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 00000000..c81b0630 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-ENCODE-UNIVERSAL-TIME.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-DECODED-TIME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-DECODED-TIME.DFASL new file mode 100644 index 00000000..eec97a32 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-DECODED-TIME.DFASL differ 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 00000000..3fe1009c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-INTERNAL-REAL-TIME.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-INTERNAL-RUN-TIME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-INTERNAL-RUN-TIME.DFASL new file mode 100644 index 00000000..1384490c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-INTERNAL-RUN-TIME.DFASL differ 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 00000000..390df6d3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-UNIVERSAL-TIME.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-LISP-IMPLEMENTATION-VERSION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-LISP-IMPLEMENTATION-VERSION.DFASL new file mode 100644 index 00000000..9e2225e3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-LISP-IMPLEMENTATION-VERSION.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-LONG-SITE-NAME.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-LONG-SITE-NAME.DFASL new file mode 100644 index 00000000..8181e2c4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-LONG-SITE-NAME.DFASL differ 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 00000000..424df4b3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-INSTANCE.DFASL differ 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 00000000..a0734874 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-TYPE.DFASL differ 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 00000000..402dccbe Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-VERSION.DFASL differ 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 00000000..7ff05ef3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SHORT-SITE-NAME.DFASL differ 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 00000000..a9a7c508 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SLEEP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SOFTWARE-TYPE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SOFTWARE-TYPE.DFASL new file mode 100644 index 00000000..c1449780 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SOFTWARE-TYPE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SOFTWARE-VERSION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SOFTWARE-VERSION.DFASL new file mode 100644 index 00000000..f56800aa Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SOFTWARE-VERSION.DFASL differ 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 00000000..9f5bf905 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/25-5-IDENTITY.DFASL differ 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 00000000..28ae008b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/4-8-COERCE.DFASL differ 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 00000000..c1ede303 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/4-9-TYPE-OF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-EXPRESSIONS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-EXPRESSIONS.DFASL new file mode 100644 index 00000000..11384d54 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-EXPRESSIONS.DFASL differ 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 00000000..807f1de5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-LIST-KEYWORDS.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL new file mode 100644 index 00000000..acb6eb2b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-1-DEFUN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-1-DEFUN.DFASL new file mode 100644 index 00000000..af2275b2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-1-DEFUN.DFASL differ 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 00000000..39ad15ba Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFCONSTANT.DFASL differ 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 00000000..c4ed2745 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFPARAMETER.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFVAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFVAR.DFASL new file mode 100644 index 00000000..0384a4b4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFVAR.DFASL differ 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 00000000..b451ee23 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-3-EVAL-WHEN.DFASL differ 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 00000000..50d7da4a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-1-SUBTYPEP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-1-TYPEP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-1-TYPEP.DFASL new file mode 100644 index 00000000..7d08bf8f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-1-TYPEP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-ARRAYP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-ARRAYP.DFASL new file mode 100644 index 00000000..2a6f6f03 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-ARRAYP.DFASL differ 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 00000000..8a1a73cf Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-ATOM.DFASL differ 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 00000000..68e20a7f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-BIT-VECTOR-P.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-CHARACTERP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-CHARACTERP.DFASL new file mode 100644 index 00000000..ca66bf3d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-CHARACTERP.DFASL differ 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 00000000..36f6dd3c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMMONP.DFASL differ 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 00000000..a950f0ee Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMPILED-FUNCTION-P.DFASL differ 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 00000000..c5a98ea5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMPLEXP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-CONSP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-CONSP.DFASL new file mode 100644 index 00000000..ef5b15fa Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-CONSP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-FLOATP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-FLOATP.DFASL new file mode 100644 index 00000000..3d4d31e4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-FLOATP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-FUNCTIONP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-FUNCTIONP.DFASL new file mode 100644 index 00000000..a4b52c1a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-FUNCTIONP.DFASL differ 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 00000000..fa0a9055 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-INTEGERP.DFASL differ 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 00000000..401a7c8c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-LISTP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-NULL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-NULL.DFASL new file mode 100644 index 00000000..6b1face3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-NULL.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-NUMBERP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-NUMBERP.DFASL new file mode 100644 index 00000000..83aa69b5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-NUMBERP.DFASL differ 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 00000000..a8c62651 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-PACKAGEP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-RATIONALP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-RATIONALP.DFASL new file mode 100644 index 00000000..e05a3796 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-RATIONALP.DFASL differ 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 00000000..6b0dba36 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL differ 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 00000000..f0d741f4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-STRING-P.DFASL differ 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 00000000..07646e28 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-VECTOR-P.DFASL differ 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 00000000..194281d5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-STRINGP.DFASL differ 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 00000000..b0fc45b3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SYMBOLP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-VECTORP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-VECTORP.DFASL new file mode 100644 index 00000000..bbaa70d7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-VECTORP.DFASL differ 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 00000000..a475379f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQ.DFASL differ 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 00000000..64251c99 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQL.DFASL differ 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 00000000..09e05934 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQUAL.DFASL differ 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 00000000..69e63f83 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQUALP.DFASL differ 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 00000000..4a994deb Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-AND.DFASL differ 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 00000000..989c43eb Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-NOT.DFASL differ 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 00000000..5d5f9bde Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-OR.DFASL differ 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 00000000..50139375 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-BOUNDP.DFASL differ 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 00000000..0990fc2e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-FBOUNDP.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-FUNCTION.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-FUNCTION.DFASL new file mode 100644 index 00000000..58a41f51 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-FUNCTION.DFASL differ 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 00000000..ae6cbcb6 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-QUOTE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SPECIAL-FORM-P.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SPECIAL-FORM-P.DFASL new file mode 100644 index 00000000..98eb79a3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SPECIAL-FORM-P.DFASL differ 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 00000000..72ad45d2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SYMBOL-FUNCTION.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SYMBOL-VALUE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SYMBOL-VALUE.DFASL new file mode 100644 index 00000000..171e3d9f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SYMBOL-VALUE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-FMAKUNBOUND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-FMAKUNBOUND.DFASL new file mode 100644 index 00000000..471b4f23 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-FMAKUNBOUND.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-MAKUNBOUND.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-MAKUNBOUND.DFASL new file mode 100644 index 00000000..0fd7d9d0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-MAKUNBOUND.DFASL differ 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 00000000..1bfcada5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-PSETQ.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-SET.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-SET.DFASL new file mode 100644 index 00000000..4d37a885 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-SET.DFASL differ 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 00000000..586ddb44 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-CATCH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-THROW.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-THROW.DFASL new file mode 100644 index 00000000..771f873b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-THROW.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-UNWIND-PROTECT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-UNWIND-PROTECT.DFASL new file mode 100644 index 00000000..d8bc20a0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-UNWIND-PROTECT.DFASL differ 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 00000000..0e32d81c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFINE-MODIFY-MACRO.DFASL differ 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 00000000..e39c2837 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFINE-SETF-METHOD.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFSETF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFSETF.DFASL new file mode 100644 index 00000000..6caf8138 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFSETF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL new file mode 100644 index 00000000..87697dd3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL differ 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 00000000..a69f35f1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-GET-SETF-METHOD.DFASL differ 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 00000000..659e61dd Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-PSETF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-ROTATEF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-ROTATEF.DFASL new file mode 100644 index 00000000..68cdc1bc Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-ROTATEF.DFASL differ 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 00000000..298e4fe2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-SETF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-SHIFTF.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-SHIFTF.DFASL new file mode 100644 index 00000000..7d4d6392 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-SHIFTF.DFASL differ 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 00000000..71469a66 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-APPLY.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-CALL-ARGUMENTS-LIMIT.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-CALL-ARGUMENTS-LIMIT.DFASL new file mode 100644 index 00000000..837eb021 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-CALL-ARGUMENTS-LIMIT.DFASL differ 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 00000000..0749e3f2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-FUNCALL.DFASL differ 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 00000000..56335ae1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROG1.DFASL differ 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 00000000..36ed2de8 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROG2.DFASL differ 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 00000000..3b290f27 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROGN.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-FLET.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-FLET.DFASL new file mode 100644 index 00000000..bde2c130 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-FLET.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-LET.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-LET.DFASL new file mode 100644 index 00000000..39cd1c77 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-LET.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-LETSTAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-LETSTAR.DFASL new file mode 100644 index 00000000..84a5d023 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-LETSTAR.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-MACROLET.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-MACROLET.DFASL new file mode 100644 index 00000000..62082c99 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-MACROLET.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-PROGV.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-PROGV.DFASL new file mode 100644 index 00000000..992be3ba Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-PROGV.DFASL differ 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 00000000..4d50ba83 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-CASE.DFASL differ 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 00000000..0f38f99e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-COND.DFASL differ 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 00000000..c1f68434 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-IF.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-TYPECASE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-TYPECASE.DFASL new file mode 100644 index 00000000..bbb3b82f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-TYPECASE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-UNLESS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-UNLESS.DFASL new file mode 100644 index 00000000..1492a14c Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-UNLESS.DFASL differ 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 00000000..74efc0cf Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-WHEN.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-7-RETURN-FROM.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-7-RETURN-FROM.DFASL new file mode 100644 index 00000000..e334df32 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-7-RETURN-FROM.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-7-RETURN.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-7-RETURN.DFASL new file mode 100644 index 00000000..bf9496a1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-7-RETURN.DFASL differ 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 00000000..22a10022 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-1-LOOP.DFASL differ 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 00000000..f3046468 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-2-DO.DFASL differ 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 00000000..23394660 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-2-DOSTAR.DFASL differ 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 00000000..d5b0273a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-3-DOLIST.DFASL differ 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 00000000..6624bf74 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-3-DOTIMES.DFASL differ 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 00000000..bdd73131 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPC.DFASL differ 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 00000000..b4e27223 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCAN.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCAR.DFASL new file mode 100644 index 00000000..631f08d0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCAR.DFASL differ 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 00000000..6ac055d2 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCON.DFASL differ 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 00000000..aec2214e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPL.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPLIST.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPLIST.DFASL new file mode 100644 index 00000000..7f9dc3e7 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPLIST.DFASL differ 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 00000000..e2da1955 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPPER.DFASL differ 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 00000000..ee050df1 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-GO.DFASL differ 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 00000000..79b8283d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-PROG.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-PROGSTAR.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-PROGSTAR.DFASL new file mode 100644 index 00000000..8907c505 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-PROGSTAR.DFASL differ 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 00000000..241726d3 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-TAGBODY.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL new file mode 100644 index 00000000..bee2669d Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL differ 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 00000000..0bad97fd Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-CATCH.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL new file mode 100644 index 00000000..673f42d5 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL differ 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 00000000..02adbd6f Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-EVALUATION-APPLICATION.DFASL differ 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 00000000..934b8db0 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-IMPLICIT-PROGN-1.DFASL differ 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 00000000..6479481a Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-MISC-SITUATIONS.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-MULTIPLE-VALUES.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-MULTIPLE-VALUES.DFASL new file mode 100644 index 00000000..f3178ae4 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-MULTIPLE-VALUES.DFASL differ 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 00000000..2eb5cc9e Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/8-1-PARSE-BODY.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/9-3-THE.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/9-3-THE.DFASL new file mode 100644 index 00000000..18d23ece Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/9-3-THE.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/ADDBASE-OP.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/ADDBASE-OP.DFASL new file mode 100644 index 00000000..9923628b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/ADDBASE-OP.DFASL differ 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 00000000..0d482f7b Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/CAR-CDRUFN.DFASL differ 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 00000000..f0b9c388 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/language/xcompiled/LONGFNCALL.DFASL differ 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 00000000..e0e3e2b9 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/sw/do-test.dfasl differ diff --git a/internal/test/LANGUAGE/from-sun/sw/do-test.tedit b/internal/test/LANGUAGE/from-sun/sw/do-test.tedit new file mode 100644 index 00000000..870c2623 Binary files /dev/null and b/internal/test/LANGUAGE/from-sun/sw/do-test.tedit differ diff --git a/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC b/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC new file mode 100644 index 00000000..a835fbce Binary files /dev/null and b/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC differ 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 00000000..83b42df1 Binary files /dev/null and b/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC.~1~ differ diff --git a/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC.~2~ b/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC.~2~ new file mode 100644 index 00000000..a835fbce Binary files /dev/null and b/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC.~2~ differ diff --git a/internal/test/Library/4045xlpstream/Hand/4045xlpstream.u b/internal/test/Library/4045xlpstream/Hand/4045xlpstream.u new file mode 100644 index 00000000..83b42df1 Binary files /dev/null and b/internal/test/Library/4045xlpstream/Hand/4045xlpstream.u differ diff --git a/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG b/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG new file mode 100644 index 00000000..1ec4b241 Binary files /dev/null and b/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG differ diff --git a/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~1~ b/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~1~ new file mode 100644 index 00000000..b65f9755 Binary files /dev/null and b/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~1~ differ diff --git a/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~2~ b/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~2~ new file mode 100644 index 00000000..b65f9755 Binary files /dev/null and b/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~2~ differ diff --git a/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~3~ b/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~3~ new file mode 100644 index 00000000..1ec4b241 Binary files /dev/null and b/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~3~ differ diff --git a/internal/test/Library/4045xlpstream/Plans/4045XLPSTREAM.PLAN b/internal/test/Library/4045xlpstream/Plans/4045XLPSTREAM.PLAN new file mode 100644 index 00000000..867dbc8e Binary files /dev/null and b/internal/test/Library/4045xlpstream/Plans/4045XLPSTREAM.PLAN differ 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 00000000..02e5b107 Binary files /dev/null and b/internal/test/Library/GCHAX/Auto/GCHAX.TEST differ diff --git a/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS b/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS new file mode 100644 index 00000000..50f8f4b3 --- /dev/null +++ b/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS @@ -0,0 +1 @@ +;;;; Test code for HASH-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 "HASH-FILE") ;;; Test MAKE-HASH-FILE & HASH-FILE-P (setq hash-file (make-hash-file "{dsk}test.hash" 10)) (hash-file-p hash-file) ;; should return T ;;; Test GET-HASH-FILE (multiple-value-list (get-hash-file :foo hash-file)) ;; should return (nil nil) (multiple-value-list (get-hash-file :foo hash-file :bar)) ;; should return (:bar nil) (setf (get-hash-file :test-key hash-file) :test-value) ;; should return :test-value (multiple-value-list (get-hash-file :test-key hash-file)) ;; should return (:test-value t) ;;; Test CLOSE-HASH-FILE (close-hash-file hash-file) ;; should return #.(pathname "{dsk}test.hash") (multiple-value-list (get-hash-file :test-key hash-file)) ;; should open hash file and return (:test-value t) (close-hash-file hash-file) ;; should return #.(pathname "{dsk}test.hash") ;;; Test OPEN-HASH-FILE (setq hash-file (open-hash-file "{dsk}test.hash")) (hash-file-p hash-file) ;; should be true (setf (get-hash-file :test-key hash-file) :test-value) ;; should signal an error (close-hash-file hash-file) ;; should return #.(pathname "{dsk}test.hash") (setq hash-file (open-hash-file "{dsk}test.hash" :direction :io)) (hash-file-p hash-file) ;; should be true (setf (get-hash-file :test-key hash-file) :test-value) ;; should return :test-value ;;; Test MAP-HASH-FILE (dotimes (n 5) (setf (get-hash-file n hash-file) n)) ;; Note: 5 chosen as we're not yet testing rehash (map-hash-file #'(lambda (key value) (format t "key: ~S; value: ~S;~%" key value)) hash-file) ;; should print contents of HASH-FILE & return NIL. ;; contents are not printed in any particular order. ;;; Test REM-HASH-FILE (rem-hash-file :test-key hash-file) ;; should return T (multiple-value-list (get-hash-file :test-key hash-file)) ;; should return (nil nil) (rem-hash-file :test-key hash-file) ;; should return NIL ;;; Test COPY-HASH-FILE (setq hash-file-copy (copy-hash-file hash-file "{dsk}test-copy.hash")) (hash-file-p hash-file-copy) ;; should be true (map-hash-file #'(lambda (key value) (unless (equal (get-hash-file key hash-file) value) (error "COPY-HASH-FILE failed to copy key ~S correctly" key))) hash-file-copy) ;; should return NIL with no errors signalled (map-hash-file #'(lambda (key value) (unless (equal (get-hash-file key hash-file-copy) value) (error "COPY-HASH-FILE failed to copy key ~S correctly" key))) hash-file) ;; should return NIL with no errors signalled ;;; Test HASH-FILE-COUNT (= (hash-file-count hash-file) 5) ;; should be true (setf (get-hash-file :test-key hash-file) :test-value) (= (hash-file-count hash-file) 6) ;; should be true ;;; Test HASH-FILE-P (and (hash-file-p hash-file) (typep hash-file 'hash-file)) ;; should be true ;;; can't easily test file format ;;; Test rehashing (dotimes (n 20) (setf (get-hash-file n hash-file) n)) ;; should return NIL. hash-file ;; should show that version 2 of file has been generated ;;; Test :VALUE-PRINT-FN w/ example from documentation (defun print-circular-object (object stream) (let ((*print-circle* t)) (hash-file::default-print-fn object stream))) (setq hash-file-with-circular-values (make-hash-file "{core}foo" 10 :value-print-fn #'print-circular-object)) (progn (setq l (list "foo")) (setf (cdr l) l) (setf (get-hash-file "bar" hash-file-with-circular-values) l) (setq l2 (get-hash-file "bar" hash-file-with-circular-values)) nil) (eq l l2) ;; should return nil (let ((*print-circle* t)) (string= (prin1-to-string l) (prin1-to-string l2))) ;; should return t ;;; Test default hashing methods ;;; We've already seen integers, symbols & strings work as keys ;; lists (setf (get-hash-file '(a . b) hash-file) '(c d e)) (equal (get-hash-file '(a . b) hash-file) '(c d e)) ;; floats (setf (get-hash-file pi hash-file) (log pi)) (= (get-hash-file pi hash-file) (log pi)) ;; ratios (setf (get-hash-file 1/3 hash-file) 1/7) (= (get-hash-file 1/3 hash-file) 1/7) ;; complex (setf (get-hash-file #c(1 2) hash-file) #c(3 4)) (= (get-hash-file #c(1 2) hash-file) #c(3 4)) ;; characters (setf (get-hash-file #\space hash-file) #\newline) (eql (get-hash-file #\space hash-file) #\newline) ;; pathnames (setf (get-hash-file (pathname "foo") hash-file) (pathname "bar")) (equal (get-hash-file (pathname "foo") hash-file) (pathname "bar")) ;; clean up (close-hash-file hash-file-with-circular-values) (delete-file "{core}foo") (close-hash-file hash-file) (il:while (xcl:ignore-errors (delete-file "{dsk}test.hash")) ; delete all versions ) (close-hash-file hash-file-copy) (delete-file "{dsk}test-copy.hash") \ No newline at end of file diff --git a/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~1~ b/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~1~ new file mode 100644 index 00000000..a0884bec --- /dev/null +++ b/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~1~ @@ -0,0 +1 @@ +;;;; Test code for HASH-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 "HASH-FILE") ;;; Test MAKE-HASH-FILE & HASH-FILE-P (setq hash-file (make-hash-file "{dsk}test.hash" 10)) (hash-file-p hash-file) ;; should return T ;;; Test GET-HASH-FILE (multiple-value-list (get-hash-file :foo hash-file)) ;; should return (nil nil) (multiple-value-list (get-hash-file :foo hash-file :bar)) ;; should return (:bar nil) (setf (get-hash-file :test-key hash-file) :test-value) ;; should return :test-value (multiple-value-list (get-hash-file :test-key hash-file)) ;; should return (:test-value t) ;;; Test CLOSE-HASH-FILE (close-hash-file hash-file) ;; should return #.(pathname "{dsk}test.hash") (multiple-value-list (get-hash-file :test-key hash-file)) ;; should open hash file and return (:test-value t) (close-hash-file hash-file) ;; should return #.(pathname "{dsk}test.hash") ;;; Test OPEN-HASH-FILE (setq hash-file (open-hash-file "{dsk}test.hash")) (hash-file-p hash-file) ;; should be true (setf (get-hash-file :test-key hash-file) :test-value) ;; should signal an error (close-hash-file hash-file) ;; should return #.(pathname "{dsk}test.hash") (setq hash-file (open-hash-file "{dsk}test.hash" :direction :io)) (hash-file-p hash-file) ;; should be true (setf (get-hash-file :test-key hash-file) :test-value) ;; should return :test-value ;;; Test MAP-HASH-FILE (dotimes (n 5) (setf (get-hash-file n hash-file) n)) ;; Note: 5 chosen as we're not yet testing rehash (map-hash-file #'(lambda (key value) (format t "key: ~S; value: ~S;~%" key value)) hash-file) ;; should print contents of HASH-FILE & return NIL. ;; contents are not printed in any particular order. ;;; Test REM-HASH-FILE (rem-hash-file :test-key hash-file) ;; should return T (multiple-value-list (get-hash-file :test-key hash-file)) ;; should return (nil nil) (rem-hash-file :test-key hash-file) ;; should return NIL ;;; Test COPY-HASH-FILE (setq hash-file-copy (copy-hash-file hash-file "{dsk}test-copy.hash")) (hash-file-p hash-file-copy) ;; should be true (map-hash-file #'(lambda (key value) (unless (equal (get-hash-file key hash-file) value) (error "COPY-HASH-FILE failed to copy key ~S correctly" key))) hash-file-copy) ;; should return NIL with no errors signalled (map-hash-file #'(lambda (key value) (unless (equal (get-hash-file key hash-file-copy) value) (error "COPY-HASH-FILE failed to copy key ~S correctly" key))) hash-file) ;; should return NIL with no errors signalled ;;; Test HASH-FILE-COUNT (= (hash-file-count hash-file) 5) ;; should be true (setf (get-hash-file :test-key hash-file) :test-value) (= (hash-file-count hash-file) 6) ;; should be true ;;; Test HASH-FILE-P (and (hash-file-p hash-file) (typep hash-file 'hash-file)) ;; should be true ;;; can't easily test file format ;;; Test rehashing (dotimes (n 20) (setf (get-hash-file n hash-file) n)) ;; should return NIL. hash-file ;; should show that version 2 of file has been generated ;;; Test :VALUE-PRINT-FN w/ example from documentation (defun print-circular-object (object stream) (let ((*print-circle* t)) (hash-file::default-print-fn object stream))) (setq hash-file-with-circular-values (make-hash-file "{core}foo" 10 :value-print-fn #'print-circular-object)) (progn (setq l (list "foo")) (setf (cdr l) l) (setf (get-hash-file "bar" hash-file-with-circular-values) l) (setq l2 (get-hash-file "bar" hash-file-with-circular-values)) nil) (eq l l2) ;; should return nil (let ((*print-circle* t)) (string= (prin1-to-string l) (prin1-to-string l2))) ;; should return t ;;; Test default hashing methods ;;; We've already seen integers, symbols & strings work as keys ;; lists (setf (get-hash-file '(a . b) hash-file) '(c d e)) (equal (get-hash-file '(a . b) hash-file) '(c d e))) ;; floats (setf (get-hash-file pi hash-file) (log pi)) (= (get-hash-file pi hash-file) (log pi)) ;; ratios (setf (get-hash-file 1/3 hash-file) 1/7) (= (get-hash-file 1/3 hash-file) 1/7) ;; complex (setf (get-hash-file #c(1 2) hash-file) #c(3 4)) (= (get-hash-file #c(1 2) hash-file) #c(3 4)) ;; characters (setf (get-hash-file #\space hash-file) #\newline) (eql (get-hash-file #\space hash-file) #\newline) ;; pathnames (setf (get-hash-file (pathname "foo") hash-file) (pathname "bar")) (equal (get-hash-file (pathname "foo") hash-file) (pathname "bar")) \ No newline at end of file diff --git a/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~2~ b/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~2~ new file mode 100644 index 00000000..50f8f4b3 --- /dev/null +++ b/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~2~ @@ -0,0 +1 @@ +;;;; Test code for HASH-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 "HASH-FILE") ;;; Test MAKE-HASH-FILE & HASH-FILE-P (setq hash-file (make-hash-file "{dsk}test.hash" 10)) (hash-file-p hash-file) ;; should return T ;;; Test GET-HASH-FILE (multiple-value-list (get-hash-file :foo hash-file)) ;; should return (nil nil) (multiple-value-list (get-hash-file :foo hash-file :bar)) ;; should return (:bar nil) (setf (get-hash-file :test-key hash-file) :test-value) ;; should return :test-value (multiple-value-list (get-hash-file :test-key hash-file)) ;; should return (:test-value t) ;;; Test CLOSE-HASH-FILE (close-hash-file hash-file) ;; should return #.(pathname "{dsk}test.hash") (multiple-value-list (get-hash-file :test-key hash-file)) ;; should open hash file and return (:test-value t) (close-hash-file hash-file) ;; should return #.(pathname "{dsk}test.hash") ;;; Test OPEN-HASH-FILE (setq hash-file (open-hash-file "{dsk}test.hash")) (hash-file-p hash-file) ;; should be true (setf (get-hash-file :test-key hash-file) :test-value) ;; should signal an error (close-hash-file hash-file) ;; should return #.(pathname "{dsk}test.hash") (setq hash-file (open-hash-file "{dsk}test.hash" :direction :io)) (hash-file-p hash-file) ;; should be true (setf (get-hash-file :test-key hash-file) :test-value) ;; should return :test-value ;;; Test MAP-HASH-FILE (dotimes (n 5) (setf (get-hash-file n hash-file) n)) ;; Note: 5 chosen as we're not yet testing rehash (map-hash-file #'(lambda (key value) (format t "key: ~S; value: ~S;~%" key value)) hash-file) ;; should print contents of HASH-FILE & return NIL. ;; contents are not printed in any particular order. ;;; Test REM-HASH-FILE (rem-hash-file :test-key hash-file) ;; should return T (multiple-value-list (get-hash-file :test-key hash-file)) ;; should return (nil nil) (rem-hash-file :test-key hash-file) ;; should return NIL ;;; Test COPY-HASH-FILE (setq hash-file-copy (copy-hash-file hash-file "{dsk}test-copy.hash")) (hash-file-p hash-file-copy) ;; should be true (map-hash-file #'(lambda (key value) (unless (equal (get-hash-file key hash-file) value) (error "COPY-HASH-FILE failed to copy key ~S correctly" key))) hash-file-copy) ;; should return NIL with no errors signalled (map-hash-file #'(lambda (key value) (unless (equal (get-hash-file key hash-file-copy) value) (error "COPY-HASH-FILE failed to copy key ~S correctly" key))) hash-file) ;; should return NIL with no errors signalled ;;; Test HASH-FILE-COUNT (= (hash-file-count hash-file) 5) ;; should be true (setf (get-hash-file :test-key hash-file) :test-value) (= (hash-file-count hash-file) 6) ;; should be true ;;; Test HASH-FILE-P (and (hash-file-p hash-file) (typep hash-file 'hash-file)) ;; should be true ;;; can't easily test file format ;;; Test rehashing (dotimes (n 20) (setf (get-hash-file n hash-file) n)) ;; should return NIL. hash-file ;; should show that version 2 of file has been generated ;;; Test :VALUE-PRINT-FN w/ example from documentation (defun print-circular-object (object stream) (let ((*print-circle* t)) (hash-file::default-print-fn object stream))) (setq hash-file-with-circular-values (make-hash-file "{core}foo" 10 :value-print-fn #'print-circular-object)) (progn (setq l (list "foo")) (setf (cdr l) l) (setf (get-hash-file "bar" hash-file-with-circular-values) l) (setq l2 (get-hash-file "bar" hash-file-with-circular-values)) nil) (eq l l2) ;; should return nil (let ((*print-circle* t)) (string= (prin1-to-string l) (prin1-to-string l2))) ;; should return t ;;; Test default hashing methods ;;; We've already seen integers, symbols & strings work as keys ;; lists (setf (get-hash-file '(a . b) hash-file) '(c d e)) (equal (get-hash-file '(a . b) hash-file) '(c d e)) ;; floats (setf (get-hash-file pi hash-file) (log pi)) (= (get-hash-file pi hash-file) (log pi)) ;; ratios (setf (get-hash-file 1/3 hash-file) 1/7) (= (get-hash-file 1/3 hash-file) 1/7) ;; complex (setf (get-hash-file #c(1 2) hash-file) #c(3 4)) (= (get-hash-file #c(1 2) hash-file) #c(3 4)) ;; characters (setf (get-hash-file #\space hash-file) #\newline) (eql (get-hash-file #\space hash-file) #\newline) ;; pathnames (setf (get-hash-file (pathname "foo") hash-file) (pathname "bar")) (equal (get-hash-file (pathname "foo") hash-file) (pathname "bar")) ;; clean up (close-hash-file hash-file-with-circular-values) (delete-file "{core}foo") (close-hash-file hash-file) (il:while (xcl:ignore-errors (delete-file "{dsk}test.hash")) ; delete all versions ) (close-hash-file hash-file-copy) (delete-file "{dsk}test-copy.hash") \ No newline at end of file diff --git a/internal/test/Library/MatMult/Auto/AR8230.TEST b/internal/test/Library/MatMult/Auto/AR8230.TEST new file mode 100644 index 00000000..c5c792ec --- /dev/null +++ b/internal/test/Library/MatMult/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/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 00000000..cbe66862 Binary files /dev/null and b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-4-BY-4.TEST differ diff --git a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-4-VECTOR.TEST b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-4-VECTOR.TEST new file mode 100644 index 00000000..31c0100f --- /dev/null +++ b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-4-VECTOR.TEST @@ -0,0 +1 @@ +;;MAKE-HOMOGENEOUS-4-VECTOR ;; By Peter Reidy ;; Filed as {ERIS}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 00000000..398bc268 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/.read-me-first differ 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 00000000..289059a6 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~1~ differ 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 00000000..65255cf5 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~2~ differ 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 00000000..398bc268 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~3~ differ 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 00000000..47a3bed4 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/AR10063.TEdit differ diff --git a/internal/test/Library/TEdit/Hand-Aux/AR8400-TEST-SAMPLE.TEDIT b/internal/test/Library/TEdit/Hand-Aux/AR8400-TEST-SAMPLE.TEDIT new file mode 100644 index 00000000..4f61dbe5 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/AR8400-TEST-SAMPLE.TEDIT differ diff --git a/internal/test/Library/TEdit/Hand-Aux/BIG-FOOTNOTE.TEDIT b/internal/test/Library/TEdit/Hand-Aux/BIG-FOOTNOTE.TEDIT new file mode 100644 index 00000000..ddf44824 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/BIG-FOOTNOTE.TEDIT differ 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 00000000..f7a00dde Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/DANCER10-C0.DISPLAYFONT differ 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 00000000..4e3cda0a Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/DANCEROBJ.LCOM differ diff --git a/internal/test/Library/TEdit/Hand-Aux/Dancer12-C0.DisplayFont b/internal/test/Library/TEdit/Hand-Aux/Dancer12-C0.DisplayFont new file mode 100644 index 00000000..9ae49c75 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/Dancer12-C0.DisplayFont differ 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} bO0Y@1:G{!^@ Y0rz \ 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 00000000..af591aa1 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL differ 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 00000000..d5d5882d Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL-LAFITE-TOC differ diff --git a/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG2.MAIL b/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG2.MAIL new file mode 100644 index 00000000..a82d42d9 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG2.MAIL differ diff --git a/internal/test/Library/TEdit/Hand-Aux/MASINTER-CAROL-NEWSLETTER b/internal/test/Library/TEdit/Hand-Aux/MASINTER-CAROL-NEWSLETTER new file mode 100644 index 00000000..d4842ac2 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/MASINTER-CAROL-NEWSLETTER differ diff --git a/internal/test/Library/TEdit/Hand-Aux/UNDERLINE-TEST.TEDIT b/internal/test/Library/TEdit/Hand-Aux/UNDERLINE-TEST.TEDIT new file mode 100644 index 00000000..fe062edc Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/UNDERLINE-TEST.TEDIT differ 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 00000000..515df291 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/abbrev-sample.tedit differ diff --git a/internal/test/Library/TEdit/Hand-Aux/dancer10-C0.WD b/internal/test/Library/TEdit/Hand-Aux/dancer10-C0.WD new file mode 100644 index 00000000..89a31583 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/dancer10-C0.WD differ 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 00000000..87a92132 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/dancer12-c0.wd differ 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 00000000..daec3547 Binary files /dev/null and b/internal/test/Library/TEdit/Hand-Aux/new-page-after.tedit differ diff --git a/internal/test/Library/WHERE-IS/HAND/WHERE-IS.TESTS b/internal/test/Library/WHERE-IS/HAND/WHERE-IS.TESTS new file mode 100644 index 00000000..402a8f66 --- /dev/null +++ b/internal/test/Library/WHERE-IS/HAND/WHERE-IS.TESTS @@ -0,0 +1 @@ +;;;; Test code for WHERE-IS ;;; 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. (in-package "XCL") ;; turn off any databases currently on (dolist (db *where-is-cash-files*) (del-where-is-database db)) ;; make a database of records used in TCP (where-is-notice "{dsk}test.hash" :files "{eris}library>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 00000000..2186b05a Binary files /dev/null and b/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl differ 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 00000000..cfffe10c Binary files /dev/null and b/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl.~1~ differ diff --git a/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl.~2~ b/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl.~2~ new file mode 100644 index 00000000..2186b05a Binary files /dev/null and b/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl.~2~ differ 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 00000000..0be391a9 Binary files /dev/null and b/internal/test/Library/rs232/hand/TESTSEND.dfasl differ 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 00000000..16d58d77 Binary files /dev/null and b/internal/test/Library/rs232/hand/TESTSEND.dfasl.~1~ differ 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 00000000..0be391a9 Binary files /dev/null and b/internal/test/Library/rs232/hand/TESTSEND.dfasl.~2~ differ 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 00000000..09f581cd Binary files /dev/null and b/internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL differ diff --git a/internal/test/Maiko/ARs/optests.dfasl b/internal/test/Maiko/ARs/optests.dfasl new file mode 100644 index 00000000..c35f1ca1 Binary files /dev/null and b/internal/test/Maiko/ARs/optests.dfasl differ diff --git a/internal/test/Maiko/ARs/optests.lisp b/internal/test/Maiko/ARs/optests.lisp new file mode 100644 index 00000000..76b1c18f --- /dev/null +++ b/internal/test/Maiko/ARs/optests.lisp @@ -0,0 +1 @@ +;;; Random opcode tests (in-package "XCL-USER") (defun copy.n.test (use-ufn) "Tests a case of the COPY.N opcode. Both (COPY.N.TEST NIL) and (COPY.N.TEST T) should return :OK" (if use-ufn (progn ((il:opcodes il:copy) 2 1 :ok -1 -2) ; the COPY compensates for a POP (funcall (il:\\getufnentry 'il:copy.n) 4)) ((il:opcodes il:copy.n 4) 2 1 :ok -1 -2))) (defun store.n.test (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)" (if use-ufn (progn ((il:opcodes il:copy) 5 4 3 2 1) (funcall (il:\\getufnentry 'il:store.n) t 4)) ((il:opcodes il:store.n 4) 5 4 3 2 1 t)) ((il:opcodes il:applyfn) 5 'list)) (defun pop.n.test (use-ufn) "Tests a case of the STORE.N opcode. Both (POP.N.TEST NIL) and (POP.N.TEST T) should return 2" (if use-ufn (progn ((il:opcodes il:copy) 4 3 2 1 0) (funcall (il:\\getufnentry 'il:pop.n) 2)) ((il:opcodes il:pop.n 2) 4 3 2 1 0))) \ No newline at end of file diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL b/internal/test/Maiko/AUTO/OPCODES.DFASL new file mode 100644 index 00000000..07c9f625 Binary files /dev/null and b/internal/test/Maiko/AUTO/OPCODES.DFASL differ diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL.~1~ b/internal/test/Maiko/AUTO/OPCODES.DFASL.~1~ new file mode 100644 index 00000000..ff19eef8 Binary files /dev/null and b/internal/test/Maiko/AUTO/OPCODES.DFASL.~1~ differ diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL.~2~ b/internal/test/Maiko/AUTO/OPCODES.DFASL.~2~ new file mode 100644 index 00000000..0db47210 Binary files /dev/null and b/internal/test/Maiko/AUTO/OPCODES.DFASL.~2~ differ diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL.~3~ b/internal/test/Maiko/AUTO/OPCODES.DFASL.~3~ new file mode 100644 index 00000000..d5ad86e5 Binary files /dev/null and b/internal/test/Maiko/AUTO/OPCODES.DFASL.~3~ differ diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL.~4~ b/internal/test/Maiko/AUTO/OPCODES.DFASL.~4~ new file mode 100644 index 00000000..60aa16b2 Binary files /dev/null and b/internal/test/Maiko/AUTO/OPCODES.DFASL.~4~ differ diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL.~5~ b/internal/test/Maiko/AUTO/OPCODES.DFASL.~5~ new file mode 100644 index 00000000..125b8386 Binary files /dev/null and b/internal/test/Maiko/AUTO/OPCODES.DFASL.~5~ differ diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL.~6~ b/internal/test/Maiko/AUTO/OPCODES.DFASL.~6~ new file mode 100644 index 00000000..07c9f625 Binary files /dev/null and b/internal/test/Maiko/AUTO/OPCODES.DFASL.~6~ differ diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST b/internal/test/Maiko/AUTO/OPCODES.TEST new file mode 100644 index 00000000..1913c86b --- /dev/null +++ b/internal/test/Maiko/AUTO/OPCODES.TEST @@ -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/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 00000000..36a75527 Binary files /dev/null and b/internal/test/Maiko/Aux/BBTESTS.DFASL differ diff --git a/internal/test/Maiko/Aux/OPTESTS.DFASL b/internal/test/Maiko/Aux/OPTESTS.DFASL new file mode 100644 index 00000000..c35f1ca1 Binary files /dev/null and b/internal/test/Maiko/Aux/OPTESTS.DFASL differ diff --git a/internal/test/Maiko/Aux/optests.lisp b/internal/test/Maiko/Aux/optests.lisp new file mode 100644 index 00000000..76b1c18f --- /dev/null +++ b/internal/test/Maiko/Aux/optests.lisp @@ -0,0 +1 @@ +;;; Random opcode tests (in-package "XCL-USER") (defun copy.n.test (use-ufn) "Tests a case of the COPY.N opcode. Both (COPY.N.TEST NIL) and (COPY.N.TEST T) should return :OK" (if use-ufn (progn ((il:opcodes il:copy) 2 1 :ok -1 -2) ; the COPY compensates for a POP (funcall (il:\\getufnentry 'il:copy.n) 4)) ((il:opcodes il:copy.n 4) 2 1 :ok -1 -2))) (defun store.n.test (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)" (if use-ufn (progn ((il:opcodes il:copy) 5 4 3 2 1) (funcall (il:\\getufnentry 'il:store.n) t 4)) ((il:opcodes il:store.n 4) 5 4 3 2 1 t)) ((il:opcodes il:applyfn) 5 'list)) (defun pop.n.test (use-ufn) "Tests a case of the STORE.N opcode. Both (POP.N.TEST NIL) and (POP.N.TEST T) should return 2" (if use-ufn (progn ((il:opcodes il:copy) 4 3 2 1 0) (funcall (il:\\getufnentry 'il:pop.n) 2)) ((il:opcodes il:pop.n 2) 4 3 2 1 0))) \ No newline at end of file diff --git a/internal/test/Maiko/Aux/optests.lisp.~1~ b/internal/test/Maiko/Aux/optests.lisp.~1~ new file mode 100644 index 00000000..76b1c18f --- /dev/null +++ b/internal/test/Maiko/Aux/optests.lisp.~1~ @@ -0,0 +1 @@ +;;; Random opcode tests (in-package "XCL-USER") (defun copy.n.test (use-ufn) "Tests a case of the COPY.N opcode. Both (COPY.N.TEST NIL) and (COPY.N.TEST T) should return :OK" (if use-ufn (progn ((il:opcodes il:copy) 2 1 :ok -1 -2) ; the COPY compensates for a POP (funcall (il:\\getufnentry 'il:copy.n) 4)) ((il:opcodes il:copy.n 4) 2 1 :ok -1 -2))) (defun store.n.test (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)" (if use-ufn (progn ((il:opcodes il:copy) 5 4 3 2 1) (funcall (il:\\getufnentry 'il:store.n) t 4)) ((il:opcodes il:store.n 4) 5 4 3 2 1 t)) ((il:opcodes il:applyfn) 5 'list)) (defun pop.n.test (use-ufn) "Tests a case of the STORE.N opcode. Both (POP.N.TEST NIL) and (POP.N.TEST T) should return 2" (if use-ufn (progn ((il:opcodes il:copy) 4 3 2 1 0) (funcall (il:\\getufnentry 'il:pop.n) 2)) ((il:opcodes il:pop.n 2) 4 3 2 1 0))) \ No newline at end of file diff --git a/internal/test/Maiko/Aux/optests.lisp.~2~ b/internal/test/Maiko/Aux/optests.lisp.~2~ new file mode 100644 index 00000000..76b1c18f --- /dev/null +++ b/internal/test/Maiko/Aux/optests.lisp.~2~ @@ -0,0 +1 @@ +;;; Random opcode tests (in-package "XCL-USER") (defun copy.n.test (use-ufn) "Tests a case of the COPY.N opcode. Both (COPY.N.TEST NIL) and (COPY.N.TEST T) should return :OK" (if use-ufn (progn ((il:opcodes il:copy) 2 1 :ok -1 -2) ; the COPY compensates for a POP (funcall (il:\\getufnentry 'il:copy.n) 4)) ((il:opcodes il:copy.n 4) 2 1 :ok -1 -2))) (defun store.n.test (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)" (if use-ufn (progn ((il:opcodes il:copy) 5 4 3 2 1) (funcall (il:\\getufnentry 'il:store.n) t 4)) ((il:opcodes il:store.n 4) 5 4 3 2 1 t)) ((il:opcodes il:applyfn) 5 'list)) (defun pop.n.test (use-ufn) "Tests a case of the STORE.N opcode. Both (POP.N.TEST NIL) and (POP.N.TEST T) should return 2" (if use-ufn (progn ((il:opcodes il:copy) 4 3 2 1 0) (funcall (il:\\getufnentry 'il:pop.n) 2)) ((il:opcodes il:pop.n 2) 4 3 2 1 0))) \ No newline at end of file diff --git a/internal/test/Maiko/BAD-XREF b/internal/test/Maiko/BAD-XREF new file mode 100644 index 00000000..fb3b294f --- /dev/null +++ b/internal/test/Maiko/BAD-XREF @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "XCL-USER" READTABLE "XCL") (IL:FILECREATED "28-Nov-88 16:38:31" IL:|{DSK}/users/greep/BAD-XREF.;2| 2420 ) (IL:PRETTYCOMPRINT IL:BAD-XREFCOMS) (IL:RPAQQ IL:BAD-XREFCOMS ((IL:FUNCTIONS XREF XREF-FILE XREF-OUTPUT) (IL:VARIABLES XREF-READTABLE))) (DEFUN XREF (FILENAMES &OPTIONAL (OUTPUT *STANDARD-OUTPUT*)) (LET (DEFS) (DOLIST (FILENAME FILENAMES) (SETQ DEFS (NCONC (XREF-FILE FILENAME) DEFS))) (SORT DEFS #'STRING< :KEY #'CAR) (IF (STREAMP OUTPUT) (XREF-OUTPUT DEFS OUTPUT) (WITH-OPEN-FILE (OUTPUT-STREAM OUTPUT :DIRECTION :OUTPUT) (XREF-OUTPUT DEFS OUTPUT-STREAM))) (VALUES))) (DEFUN XREF-FILE (FILENAME) (DECLARE (SPECIAL XREF-READTABLE)) (WITH-OPEN-FILE (STRM FILENAME :DIRECTION :INPUT) (LET (FORM DEFS (FN (PATHNAME-NAME FILENAME))) (LOOP (WHEN (EQ (SETQ FORM (LET ((*READTABLE* XREF-READTABLE)) (READ STRM NIL :EOF))) :EOF) (RETURN)) (WHEN (CONSP FORM) (LET ((FIRSTWORD (STRING (FIRST FORM)))) (WHEN (AND (CONSP (REST FORM)) (>= (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 00000000..e097e6ea Binary files /dev/null and b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.DFASL differ diff --git a/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~1~ b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~1~ new file mode 100644 index 00000000..ab44cedd --- /dev/null +++ b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10) (FILECREATED "22-Jun-88 13:52:22" {ERIS}MAIKO>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 00000000..d705603d Binary files /dev/null and b/internal/test/Maiko/OBSOLETE/AREF-TESTER.DFASL differ diff --git a/internal/test/Maiko/OBSOLETE/ARRAY-TESTER b/internal/test/Maiko/OBSOLETE/ARRAY-TESTER new file mode 100644 index 00000000..9d8c281d --- /dev/null +++ b/internal/test/Maiko/OBSOLETE/ARRAY-TESTER @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL-USER") (il:filecreated "14-Jun-88 14:57:44" il:{qv}lisp>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 00000000..a176ab17 Binary files /dev/null and b/internal/test/Maiko/OBSOLETE/ARRAY-TESTER.DFASL differ 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:opcodesil: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 00000000..784f4e61 Binary files /dev/null and b/internal/test/Maiko/OBSOLETE/FLOAT-TESTER.DFASL differ 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 00000000..ab34422a Binary files /dev/null and b/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL differ 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 00000000..43733862 Binary files /dev/null and b/internal/test/Maiko/OBSOLETE/TESTER.DFASL differ 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 00000000..1b89b425 Binary files /dev/null and b/internal/test/Maiko/OBSOLETE/unwindtest.dfasl differ diff --git a/internal/test/Maiko/OBSOLETE/unwindtest.lcom b/internal/test/Maiko/OBSOLETE/unwindtest.lcom new file mode 100644 index 00000000..0222bb5d Binary files /dev/null and b/internal/test/Maiko/OBSOLETE/unwindtest.lcom differ 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 00000000..4f34b32d Binary files /dev/null and b/internal/test/Maiko/OBSOLETE/xclopcodetests.lcom differ 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 00000000..8912c48e Binary files /dev/null and b/internal/test/Maiko/STACKHAX.LCOM differ diff --git a/internal/test/Maiko/STACKHAX.LCOM.~1~ b/internal/test/Maiko/STACKHAX.LCOM.~1~ new file mode 100644 index 00000000..6e51f093 Binary files /dev/null and b/internal/test/Maiko/STACKHAX.LCOM.~1~ differ diff --git a/internal/test/Maiko/STACKHAX.LCOM.~2~ b/internal/test/Maiko/STACKHAX.LCOM.~2~ new file mode 100644 index 00000000..fa289775 Binary files /dev/null and b/internal/test/Maiko/STACKHAX.LCOM.~2~ differ diff --git a/internal/test/Maiko/STACKHAX.LCOM.~3~ b/internal/test/Maiko/STACKHAX.LCOM.~3~ new file mode 100644 index 00000000..11580a06 Binary files /dev/null and b/internal/test/Maiko/STACKHAX.LCOM.~3~ differ diff --git a/internal/test/Maiko/STACKHAX.LCOM.~4~ b/internal/test/Maiko/STACKHAX.LCOM.~4~ new file mode 100644 index 00000000..8912c48e Binary files /dev/null and b/internal/test/Maiko/STACKHAX.LCOM.~4~ differ diff --git a/internal/test/Maiko/STACKHAX.~1~ b/internal/test/Maiko/STACKHAX.~1~ new file mode 100644 index 00000000..5422fe0c --- /dev/null +++ b/internal/test/Maiko/STACKHAX.~1~ @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "27-Oct-88 14:58:37" {ERIS}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 00000000..0040cc3e Binary files /dev/null and b/internal/test/Maiko/STACKTAKESHI.LCOM differ 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 00000000..a8c20040 Binary files /dev/null and b/internal/test/Tools/AUTOTEST.LCOM differ diff --git a/internal/test/Tools/AUTOTEST.TEDIT b/internal/test/Tools/AUTOTEST.TEDIT new file mode 100644 index 00000000..a82d0046 --- /dev/null +++ b/internal/test/Tools/AUTOTEST.TEDIT @@ -0,0 +1,66 @@ +AUTOMATED TEST HARNESS INTERFACES +This document specifies the interfaces to the automated tester harness. The harness is composed of two parts: the top-level tester and the individual test handler. The name of the file to load for this is AUTOTEST.DCOM in the top level of the standard test directory. [We need to set up this standard test directory.] +The top-level tester is set up similarly to the package FileBrowser. Items are selected in the same manner as FileBrowser, and are displayed similarly. The portions of the display are as follows (from top to bottom): +1. A prompt window for displaying messages and getting new input. +2. A command menu with the following commands: +TEST Tests sequentially each of the items selected in the test files window. Testing consists of loading the file containing the test suite, calling a function which has the same name as the NAME field of the filename (this function must return NIL iff the test suite is not successful), then undoing (as best as possible) the side-effects of loading and running the test suite. The function which is called is passed one argument: the name of the directory that the test suite came from (including the host name). If this item is selected with the middle button, then first it asks for the name of the file to direct output to (selecting this item with the left button will direct output to T, the process' TTY display stream), before running the test suites. All output directed to NIL, the default output stream, will go to this file, including all error messages generated by the automated test harness and by TEST-MESSAGE (see below). It is assumed that no other activity is being performed while testing is in progress. +ABORT Aborts any tests in progress. Confirmation (via clicking the left mouse button) is required. New tests can be selected, tests can be re-run, etc. after an abort. +PAUSE Temporarily pauses any tests in progress. Any pause time does not count in the computation of timeouts (see below). +RESUME Resumes PAUSEd testing. +DIRECTORY Does a directory of files (the directory pattern is prompted for in the prompt window) and puts them in the test files window in order to have a new set of test suites to select from. +PRINT Prints the results of testing the selected files. Selecting this item with the left button will print on the default printer. Selecting this item with the middle button will put up a menu asking whether to print to a printer or a file. If a printer is selected, then a menu asking for the printer to print to (gotten from DEFAULTPRINTINGHOST plus the selection "Other"; the latter will ask for the name of a new printer to print to) is put up. Otherwise, if a file is selected, then the user will be prompted for the name of a file to print to (also, if the type of output is not obvious, i.e. PRESS or INTERPRESS, then the user will be prompted for the type of output). When the Hardcopy item of the right button menu is selected for this window, then this command is performed (except that selecting the main item does the default, while selecting either the printer or the file sub-item starts the sequence of questions at the intuitive place). +SUMMARIZE Similar to PRINT, except that it prints only those tests (out of the selected tests) which failed. +QUIT Quits testing, closing the window and throwing away all test results, test names, etc. stored in the window. If any tests are currently in progress, then confirmation (via clicking the left mouse button) is required in order to quit (in this case an ABORT is performed before quitting). When the tester window is closed, this command is performed. +3. A status window, which has the following fields: +Suite The name of the test suite currently running. +ID The ID of the current test being performed by SINGLE-TEST. +Start The time that the current test was started. +End The time that the current test will time out at, or blank if none. +4. A summary window, which has the following fields: +Files The number of files in the test files window. +Selected The number of files (test suites) selected in the test files window. +Completed The number of test suites completed. +Successful The number of test suites which were successful. +5. The directory pattern used to select the test suite files. Unless otherwise overridden, the directory pattern by default only selects the latest version of each test suite file. Also, unless otherwise overridden, the directory pattern by default only selects .DCOM files (if a source file is more recent than the corresponding compiled file, then an error message is displayed). +6. A heading line which identifies each column in the test files window. +7. The test files window which has a line for each test suite file which matches the directory pattern. The left button on an entry selects only that entry. The middle button on an unselected entry adds that entry to the selected entries. The middle button on a selected entry removes that entry from the selected entries. The right button in the left portion of an entry will extend the current entries to include this entry and all the entries inbetween (the mouse cursor will change to a right pointing arrow when this action is enabled). This window is also scrollable (both vertically and horizontally). When each test is completed, a line is drawn through the entry. This window has the following columns: +Result: The result of testing using the corresponding test file. The following can appear in this column: +? The test suite has not been completed or possibly even initiated, so no results are known. +pass The test suite completed successfully. +FAIL The test suite did not complete successfully. This could be because a test in the test suite returned bad results, a test in the test suite aborted, a test in the test suite timed out, etc.. +Name: The NAME portion of the test suite file name. +File: The full name of the test suite file (except for the host name). +When the tester is loaded, a new entry is added to the background menu, labelled AutomatedTester. When this is selected, an automated tester process is started, which will prompt (in the system prompt window) for a directory pattern which is used to initialize the test files window. +The individual test handler is a function which is called by the top-level function of each test suite (the function which was called by the top-level tester). This function has the following interface (all arguments must be supplied): +Name: SINGLE-TEST (LAMBDA function). +Arguments: +IDENTIFIER The integer identifier of this test. Identifiers are assigned manually and are unique across all tests in all test suites. [We need to set up an index file for this purpose, in the standard test directory.] +EXPRESSION The expression to evaluate (e.g. (PLUS 2 3)). Note that in order to get the right results, this argument would normally be quoted with QUOTE (or ') or be an expression such as (QUOTE (fn)), where fn is a separately defined function (and is therefore compiled code, instead of interpreted code). +PREDICATE The (one argument) predicate to check the result (e.g. (LAMBDA (X) (EQP X 5)) or NULL). This must be NIL iff the result was not correct (non-NIL indicates that the result was correct). If more than one error can occur, then output identifying the specific error should printed (to NIL). Note that this argument would normally be quoted with QUOTE (or ') or FUNCTION in order to get the right results. +TIMEOUT The maximum elapsed (wall) time (in milliseconds) that the expression EXPRESSION should take to complete (NIL implies that no timeout is to be used). With the current Interlisp-D process mechanism, this will only work if the expression (or anything it calls) does a BLOCK, so that another process can check to see whether a timeout has occurred. Also, the timing is not exact, so the actual timeout used will be no less than the value supplied. Time elapsed while the test was PAUSEd is not counted in checking for a timeout. +Result: NIL iff the test was not successful (due to PREDICATE returning NIL, a NOBIND being returned, a timeout occurring, or a deep exit (such as an abort) occurring). Non-NIL indicates success. +Description: This function evaluates the expression EXPRESSION and checks the result with the predicate PREDICATE, returning the result from calling PREDICATE. If NOBIND is returned from either EXPRESSION or PREDICATE, then an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. If the timeout is exceeded (and timeouts can be checked) then the evaluation of the expression is aborted and an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. If a deep exit occured in either EXPRESSION or PREDICATE (e.g. from aborting of the expression), then an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. +Side Effects: A message can be printed (to NIL). +Assumptions: Deep exits completely out of EXPRESSION or PREDICATE are not part of the successful behaviour of either EXPRESSION or PREDICATE (any such exits must be caught internally within EXPRESSION or PREDICATE). Note that deep exits are caught via ERRORSET, so RETFROM, RETTO, RETEVAL, RESUME, etc. are not caught. +There is a function available which prints out an easily identifiable error message in a standard format to the standard ouput. Thisfunction has the following interface (all arguments must be supplied): +Name: TEST-MESSAGE (LAMBDA function). +Arguments: +IDENTIFIER The integer identifier of this test (as given to SINGLE-TEST). +TEXT The text of the error message. +INFO Information specific to this instance of this error. +Result: Not useful. +Description: The error message along with the test identifier and the specific information is printed to NIL in a standard, easy to notice format. +Side Effects: A message is printed (to NIL). +Assumptions: None. +Some side-effects of the automated test harness are: +1. The History List for the Programmer's Assistant is used, therefore old items are lost and a REDO, etc. immediately after testing will redo the last command that the automated test harness performed, not the last item printed in the top level typescript window. +2. The top level value and the value in the Programmer's Assistant of HELPFLAG are changed for the duration of running a test suite. +3. Extra processes are run to perform the testing. +Known deficiencies with the implementation are: +1. ABORTing and PAUSEing can only be done between individual tests. +2. If a test is aborted between individual tests, but not between tests suites, then the effects of LOADing and running that test suite are not UNDOne. +3. Some errors are not caught, and some side effects are not undone if errors occur. +Some possible extensions to this package are: +1. Utilities to help with testing for deliberate errors. +2. Utilities to help with automating input which would normally be manual. +(LIST ((PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY CLASSIC OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT BOLD)) (270 36 72 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SIZE 10 FAMILY CLASSIC OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT BOLD)) (270 36 72 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY CLASSIC OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT BOLD)) (270 36 72 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL)))))<x<xx<<TTCLASSIC CLASSIC "1B/{mc44>2G54N/<Ik],4H% S31@& J$:-530DU.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 00000000..7245314f Binary files /dev/null and b/internal/test/Tools/DO-TEST differ 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 00000000..64794fb4 Binary files /dev/null and b/internal/test/Tools/DO-TEST-MENU.dfasl differ 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 00000000..813fdabb Binary files /dev/null and b/internal/test/Tools/DO-TEST-MENU.dfasl.~1~ differ diff --git a/internal/test/Tools/DO-TEST-MENU.dfasl.~2~ b/internal/test/Tools/DO-TEST-MENU.dfasl.~2~ new file mode 100644 index 00000000..64794fb4 Binary files /dev/null and b/internal/test/Tools/DO-TEST-MENU.dfasl.~2~ differ diff --git a/internal/test/Tools/DO-TEST.LCOM b/internal/test/Tools/DO-TEST.LCOM new file mode 100644 index 00000000..6bbca04c Binary files /dev/null and b/internal/test/Tools/DO-TEST.LCOM differ diff --git a/internal/test/Tools/DO-TEST.dfasl b/internal/test/Tools/DO-TEST.dfasl new file mode 100644 index 00000000..6c7f65a0 Binary files /dev/null and b/internal/test/Tools/DO-TEST.dfasl differ diff --git a/internal/test/Tools/DO-TEST.dfasl.~1~ b/internal/test/Tools/DO-TEST.dfasl.~1~ new file mode 100644 index 00000000..dfa9d21e Binary files /dev/null and b/internal/test/Tools/DO-TEST.dfasl.~1~ differ diff --git a/internal/test/Tools/DO-TEST.dfasl.~2~ b/internal/test/Tools/DO-TEST.dfasl.~2~ new file mode 100644 index 00000000..6c7f65a0 Binary files /dev/null and b/internal/test/Tools/DO-TEST.dfasl.~2~ differ 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 00000000..03f79229 Binary files /dev/null and b/internal/test/Tools/RANDOM-GENERATOR.LCOM differ 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 00000000..d52d98ba Binary files /dev/null and b/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM differ 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 00000000..de62470c Binary files /dev/null and b/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~1~ differ 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 00000000..d52d98ba Binary files /dev/null and b/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~2~ differ 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 00000000..593c7161 Binary files /dev/null and b/internal/test/Tools/TEST-DISPLAY-UTILS.LCOM differ 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 00000000..4380140e Binary files /dev/null and b/internal/test/Tools/TEST-FILING-UTILS.LCOM differ 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 00000000..15696f7c Binary files /dev/null and b/internal/test/Tools/TEST-REMOTE-EVAL.LCOM differ 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. + .*ꪪꪪ>1UUU]UUUUUUWuUUUUUU]UUTc?`UUU]UUUUUUWuUUUUUU]UUTc?`*c?`6*ꪪꪪ>?`fUUU]UUUUUWuUUUUUUuUUTc?`fUUUUUUUUUWuUUUUUUuUUTc?`ـ*ꪪꪪc?1*ꪪꪪc`UUU_UUUUUWUUUUUUUUT>UUUUUUUUUUUUUUUUUUUUUT**0?|?0q9g?3?09g?c~01?`|0<1 ~01?yac01Ϝ? 0c 01?`c01??c0p>s<<<<<<<<<<<<<<< < @@<#X@8MX@<$L"d#$"D@$J"d@<"@"$@>0@$J>@<"@"$@ @$J @<H"@"$ "DH$ʙ"@@<@"#@80#J@@<@!<@."=g<@!1"<@!!<@!!<!!1<. +< < 0<<<<<<<<<<<<< ;8pp`<۷~۽~tcǞy<;{>~mm<wg}~ +ۍ<~{~}m< +.;|}vsx<<<<< < <.x<##HLH1 <"!!HH! <>!!HH! <A##HHH1 <AG.< < <<<<<<<<<< < (<b (<cD<|<|xx"A>| <@D"c <xx>c<<@"D"U ><@>D"U <|tAD"I><x< +?$<@ XĀ|@<@&$B@<$AG<8xp<`tHA"HDĉ<A>O@<@A H@<@AB"HD<0`|G 8xp<<$P< EDHB&2 H<@EGC3 H<H2$HB%R $`0<OHB%R " <DHB$`< 8<@0< <`@ < < & 0|N<  @<@ axN<@@@< @<a|N<< Y<G<`< ``p< 0XH<A&$"<B$< `<"##<$"!!< >!!<@`A##<X A<<<$R`x#<HLD$N<@*D#<@x < @@$N<'ȐO# ( @Î<!$&K0<!$<H!H$ <!H$#  <Q!O#! < |O<<"@<0F H<` H<!O<`F<<0O< <  <@!|<ByOI @<$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|@@<1B@@<(@<OAG<<<(0PȒA"HDH<ȒA>OG<OA HD< PHB"HDH< H|G 3 < <<<@< < <BN>|"N<b H@"BDALPN<RR xTB*JPN<RJ`@TB*IPN<`"FDB@BHЈN<"BD|<ON< Lj?<A$HD<@H(<@HG"< @$>< @~@< @<!|pO!|pDx<!1H!1D<~!)`O!)`D<!%!%D"<!#H!#D <!pH!p8x$<@@<@@/p<@~#$<@!$<@@!$<@@#$< >HO#p< LP<<0<@<x<<8< ODB <@ <8!<AxA# <@A$LI @8pA#Hq@< A HI@ < xxB$LI< |#<<!<!8<$'<B1B!!1D&(<B)@!!)0<% UUUUUUUUUUUU| Bd%@!!%$B#B!!#D<$h<!|q8<@B pE<px`AE< @@GE<@B E<`|pA8<<<<8<<<!|Cǀ<p"(1@$@A@< <()x'A@ <"D%@$@AYC<"|#@$@"j2$&$A"DJ"H!|@AB$"C<A2B$"@J<A"B2$&!"DD<AA3<<<<< < < 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`s0aٛ`aٛ0aٛ0a9ٛ0aٛ0`ٛ߿<G6l0f1B6l0p1fB6o><0eB00xBl00l0f1do?|1dG矟8;@À 1;T  @ @1{8Ňxp<8Ç"p @Ňx@dž01{T&H HD" @"FH" @01msO |"x @>D" @1mxH" @ @ D" @ 1mx$H"$ED  @"D" @2l8Gp 8x @D @ 0 Ň8Ç᥈HD "fH"O0"$HH"$H$HD "dI"G8!F @@>8"D@$N<8  D A"l$@&"D,8hŀ D A"l$@&"D8D2DF@<0 "T'@R%O<0# D |D@  ! "T#"@R%H(" | @D@ D !"T>@2%H$D" @D DD@ D B!"T"@2%H"D" D 8hD@>8 CÇD"|O"8" 8@ H>8p'(@M!"(@M!"(@ʞ!>D@J!|@J!"D@J!"DH8p qGxq"8!HD!2Dŋ"!HXÍ8ŇD!2D&L"!F"d$J ͘HD!Ǐ*@H"!A"D'ʀ<͘OD! *@$H!H"D$ l͘HD! &D&L!H"D$Jl͘$HD!&DqDb#>Gxqȟ"80pApea D&@"A "D "G>AD"H AD@&H"I "L p⥇14apC߾AN!<8p 3AF!@ "D 03 AFA@ "D 1g3 AEOA <@` !f>A%H"AB(\ 3AH>A"@$D 63 A%H"A@"D 6 A$O"!"8p @ p Cߟ>~@l1`A@0l1`@1ϟ1| !l1`P l1` l1` 3~A@ >c~ccccccPݰccPݰcc0ݰcc0ɿ>><@fp@<@ݰ@ݰ@ݰf@ɿ| 3>|?~<Cxp6666 ٳf `"(B$D6663f `"($D@6Ǐ3f |"(džx@6Ǿ| `J"D"P @6666f `ʑ"|D>H@6666 ٰf`J"D$"D@0f1~H|<|H@A"@<H@A"@eHxAD!À>8"D@$N<8ycB$H lP@@ D A"l$@&"Dyc" lP@@ D A"l$@&"Dmc@2%H$Dgc! T@@ D B!"T"@2%H"Dc>A>DAÀ>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>qG ٳ!H0 !H1 !F!>!A3!H 3 !H3 q矷 6060dž606060 607ώ +EXAMPLE 2 +`00p00|yo`0 ll͍a0 ll͍c00x ll͍c00 ll͍c0 ll͍`00|xp g`0@ߞ~xDA63H!681 PB`7x1 pB< "HB6 >HC 631"DB 70"D@Ϗwp@@ccw` *c`baÏpË +lņ"aË,8pǀpcl`b * D" L"TFI"$L2DB"c۶l`xȑ"TPDH*"|`B"xcc۶<`DH"TPDH*"@B"cc۶<`b$D"H"TDI0$H2DB@ "c6M`aqxȍTDFÈ,8pAx    H,8pǀXh` 8qa||aÉXh$ȑ2D"d & f$J"dH"@"D"f "@"H"@""D"@6f$ "@ $ɑ"D""D&#6f$I "@HF"8pDhqf|a㈊@h@@ @@@"@AÀ,8hÁXqa"XpC<a,8q`$@2# A"d  d@A 2D' "#Dy DA |$ "$AD"DA @$@ "$A"D "DD@I  Db# h"#DyaDp#1 8qp@@aǍ,8ᣋ,4,4XqËB 2D"`2Lfl2L"dDLB "0> "Dl"D>@xDHB "  "Dfl"D @DHBJ2D "`"Lfl"L"@DH`A,8᠈"4g"4@x`C  8 ÀDp @$@&D @"Dx @"D @@&L @4x 8@ !C B'8  q d "D q d  "DفᏙ  0ف H @. H  "Da H  "Daـ '8   8@88Ȁ8!D$DQ"D$ DQ"@@Q@D @@JD$D "D$DH"88H8 !ϟ? q6 ٰBq6 ٰ BكϘپ Bك6 0B6 ٰBa6 ٰ Ba pqߟ1AN CÇcq1AF $Hc{1 AF@$Hc{1 AEO@cn1A%H"Acn1AH>ADHcn1 A%H"A$Hcdߟ A$O"!#@ pp8"D &L*T*T2d"D8pqߞ cq3`c{8 c{ cn cn cn3 cd߾ pǟ>~ςAN!<8p@lٳ`0AF!@ "D@`0 AFA@ "D Ǚ| +> AEOA <@` {>` +0A%H"AB(\ `3`φ0AH>A"@$D l3`0 A%H"A@"D Ϙ3~Ϙ? A$O"!"8p@@ @p`c|"x!>D! xp6DQ lQ "!DHDo6DQ lQ "ADHD@f*DQTQADOx@f *xBȄT@ A$J"P @f*@"T "AI>H@f*@T "A$H"D@f"@D '"Dp  qπDp!"DH> !"DHٳ !D߳ !D3 !"DHٳ !"DH3p8p  8AG>A>B$H  yx$H  Ͳ$H<<$H  $H  ͦ$H  yxAÇ>>@ `8p1AÏ|"|CD "8G<8@ٱAB2@d`"D!B"D@ٱ AB2@d`"D!B"D @ٱ A*x𠇀T"D!B"D @1A *@"T"D!B"D @1AB&@>L"D!"DP @1 AB&@"L"D!"DP @ AÂ"|"D 8!<8P@@@p@ @pq!x>|Ȅ< H Cb"DH @ +" H Cb"DPH @ +"x B"DP|   @ @|"|CD "8|>DpD2@d`"D!" l$"d2@d`"D!" l$"d*x𠇀T"D!L"D!" TD"L&@"L"D!" T$"L"|"D 8!>Dp'D8@"&@*@*@2@"88 !o B''8Ï>D" qlـ dC$HD$H dB2B!qـ d C$HD$H dB2B!كـ BHDD" 8PpJ H"PBdHHI D"PBdHDI Dp<P' DÈ>8D 8q"xqLJD@d "2D$HD@d" 2DR$HD@T P *DR'DOT.P *DSD@ L@ "0&DD@ L@"0&DH8 D@8q"xpG DqÈD!$HT!$JT!R$JT!R$J(!2$E(!2$E(qÅqπ<|pB!"@B&B !"@B&A !DO"@B$E DH"@>x$E TPH* @fxAH>(O@@@  <|"|8q>  "@"@"< "@"@" f0"xx P  f0<@ @" .S f@0 @ @ "0 f 0 @@"0 < 0 ||8q  8qDqÈ<|pB @HD!$H"@B&B @HT!$J"@B&A `@HT!R$JT!R$J(@B%A @H(!2$E$@B$ @H(!2$E"@B$>8p@(qÅ"|pB AB>DO"@B$E DH"@>x$E TPH* @fxAH>(O@@@ >D>D!Ïpϑ88D lQ$H$$!DAD lQ$H $$!DADPTQH aǏ<!QDA DPTO "!R' D0T$H D"!SD0T$H $"!R$8DÈp'ϑ<8!$ccceca c ccccacgBB +EXAMPLE 3 +```saٛ`aٛ aٛ a9ٛaٛ`ٛ߿<>xq8p@6l0f1D  D@6l0p1bD D 6o><0b xRp 00xPR l00H2   l0f1bD2 @ o?|1aDq|p@@"|!"@Q B*@Q@*xQ*@ @ @|矟8;Hp 1;T "B&H" " 1{8Ňxp&B&H"qxqc` &`dž01{T&H *BH *01msO *BH *1mxH" 2B$ȕ" 2  1mx$H"$"B$ȕ"H " B#2l8GpGp q A>8 Dŋ8p Dl&LD<0 "TH|`  >T$H@ D  T&LD D "T`8p>8 T  @ p  >>qaÉxA8pǀ,8ō3f$J "$A"2D&J3f >A`""|$ 3f   DA""@$ 3f$I$ "$ " "D$ >qÈAp"8 @ >xpH @  Dɀ2`Dp8C߾3B03 B1g3 B!f>B3B63 B6  Cߟ>~B #||Dl1`BE"!$BD BB0l1`E"A$BD BA1ϟ1|EA$BSD B!l1`HA$B ȔR>D Bl1`OA$BRD BAl1`HA$BRD BA3~C㈞ Â8 @ @ 0 >c~<@cc"(ADHcc"(DHcc"(G ݰccJ"D% ݰccʑ"|䈑ݰccJ"D$Hɿ>>H|?~<Cxp6666 ٳf `"(B$D6663f `"($D@6Ǐ3f |"(džx@6Ǿ| `J"D"P @6666f `ʑ"|D>H@6666 ٰf`J"D$"D@0f1~HD "D@@@ "T&D!I"D "D@@@D"8!"88@>|pH|G" $M"@H" $M"@H" <J"xH> DJ"@K" $J"@Ȅ" $J"@Ȅ">pÈ@G" 8<8!À` "DQ$@ "D|Q$@c6 <@fQc6(\fBc6$Df"$@c6"Df$@a"8fÀ@!G"!'"!H!H"!$E$Q H(AH"A$E(Q ,٘AH>AE8Q٘AK"A$B٘HAȄ"Ad$" l٘HAȄ"Ad" ٘>!G" $" @@>|p$OD"@H8 &H"HH"@ LD$ &H"PH"@ LD$ <%H p "@ J@dž %O H"@ J"@ $"H"@ I>DD $"DH"@ I"D$>pHDO| "8' @01733333< CǂD>Dq!(" $F"D$ dB!("@$J"D$ dB ("@$BD'DpB!  @!G">x㈐> !H"" DH AH"" DHAH>R"x    @pC<q>8 "("@ D "(B@ D "(@<0 8q @qπ !  !( ! ! ! !p>    @Ç> !<! f! f!  f! f! <Ç``x$OD"@@"D&H"HH"@ @o"D&H"PH"@ l D%H p "@ l D%O H"@ l"D$"H"@ l"D$"DH"@ lxHDO| @@>8Ç DB8ٙ3 DB ٘f6@a>8Ç  AG>p B$H $H $H< $H $H $H AÇ>p @  `x'8"8qÂDB$LD"D$BǟDB$LD"D$AlـxB'D "@oـPB% D"@@lHB$D"D$AlـDB$ID"D$AvgDAH8p8q !Ȟ" #| O!2!$B@PBH<<A2A$B@PBHffA*A$BxPBO~~AB*A$B@BJ``A"&A$B@BIffA&A$B@BH<<!" Â@㈟ @0 qc~C8>B'qπ@p8#yc@DE $H!@!!d@ycDE $H !@!!d@mc@SDž<H !@ !mc\R |H !@ Ȑ>!gcD2 dH !@!!@gcD2H dH !@!!@c>@8H>'p|p8!#@  8'Dpp$H" B$"D$H!$M" B$"T$ H!$M( AG"T'x!J AD"TB$>D!rJ" AD"("$D!dJ" @"($D!dJ8 (xp#> @ @" @& * * 2 "  @ @ @C>qO ٳ @0 @1 @O !> @H3 @H 3 @H3 pAO矷 6060dž6060 60 607 +EXAMPLE 4 +w`000|yoc0 ll͍c0 ll͍c0x ll͍c0 ll͍c0 ll͍c0|xp gaߞ~x#63!683!7x2<6 a632a72#Ϗw@ 8pccw` *!@@c`b!aÀ8Ň<8#68cl`b *!D@"D@&HD$D*@" c۶l`!C>0@|#*<@"cc۶<`!@ @@!@*D@""cc۶<`b!D@ "DH$DDD*DH" "c6M`a!C80 8*<0!  >8Ǐ>|@ @ DB$H @,8ŇxHX DB$H @%L2@"&H" $ȕ"dAD@ DB@%H"D@"$A" H D@  DB$@%L"DH"$H" ɕ"DIH DB$H@K"<0!G FD0 8AO|@p%8&HD$HD$HDdHDG8@@    A  +xpÀ,8aŀ,8XL @2DA&@2D "d ȑ "|A"| >@ H !"@A"@ @H$$@ "DI$ "D "@ȍpÀ "81"8 @  (8!p(@@ (CxK +@ D@" $L@ G" $H@ D" $H@ D@"$$ȓ@ CH 8@ !C B'8  q d "D q d  "DفᏙ  0ف H @. H  "Da H  "Daـ '8   8@>88 CH"@  CLjqπ|O>8qǏ< $H!"@!&B DB"|@$H !"@!&B DB"f@$H !x!%B<0B<fALj !@!%B @(fA !"@!$ D $fA !"@!$ D"ٞf!p|!B>8q"   xp@D@D@x@"P @>H@"D@"Dp@@ !ϟ? q6 ٰBq6 ٰ BكϘپ Bك6 0B6 ٰBa6 ٰ Ba qߟ1cq1Bc{1 Bc{1 Bcn1Bcn1Bcn1 Bcdߟ qߞ cq3`c{8 c{ cn cn cn3 cd߾ pǟ>~ςAN!<8p@lٳ`0AF!@ "D@`0 AFA@ "D Ǚ| +> AEOA <@` {>` +0A%H"AB(\ `3`φ0AH>A"@$D l3`0 A%H"A@"D Ϙ3~Ϙ? A$O"!"8p@@ @p`@ @c8G8< DE"! DE" 8" @B qπDp!"DH> !"DHٳ !D߳ !D3 !"DHٳ !"DH3p8p  8AG>A>B$H  yx$H  Ͳ$H<<$H  $H  ͦ$H  yxAÇ>>@ `81 #""8D #ٱ!$B6( B "D!"DP!ٱ ADB6( B "D!"DP!ٱ @C*( B"D! |P1@ *D B"D! D1AB*| B "D!"Da1 AB*D B "D!"Da "D 8!D# "8p#"D! 0!"D!P!"D!"D! "D!@a"D!a8!|#>88B8 D D"D ED D D"D ED<0 D DED  $ DHD  D "DτD D B$"DȄD>8 B'π8H8@8pq<8"| DH +"" DH +""Dx "P>DD "P"DD "P"DD "P"8pxq<8q"   @qx$ ADD$ ADD$ ADx$ B$Pr$ CH$ B$D$pB'DȑH<p'8ȞD$H "dH"Dd  $H "dH"Dd  H <O0T  H("T  $H$ "D>L  $H""D"L Ï"p$8Ȑ"D"88"D!"D"D! "L"D! "TP"D! TP"D! d0"D!"D08!8 "8xB >8p#"D!"D  D!"D!"D@ D!"D!D@<0`"D!x "D!"@ Da"D!"@ Da8!@>8p#  !o|q| qlـ@Hqـ@HكـxPك@P "@0I>al@0H"al@q"cccecacccccacg' T& ' T'H T&H & MODERN MODERNMODERN nwWr2;7Yz;gX&4hl& BMOBJ.GETFN2#UkP > BMOBJ.GETFN2MODERN  ` BMOBJ.GETFN2MODERN  e BMOBJ.GETFN2MODERN  W BMOBJ.GETFN2MODERN Bz \ 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 00000000..7affcd04 Binary files /dev/null and b/internal/test/Tools/TESTERVARS.DFASL differ 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[f91@e<GE9~S[-b2 +I*'jJ9#,cb$q$2+u;01W9~289:404-)4,8oe7A  TU W  }ZA +eBUHz \ 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 00000000..febfe6e2 Binary files /dev/null and b/internal/test/Tools/TestExec.LCOM differ diff --git a/internal/test/Tools/TestExec.TEdit b/internal/test/Tools/TestExec.TEdit new file mode 100644 index 00000000..902c3b3a Binary files /dev/null and b/internal/test/Tools/TestExec.TEdit differ 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 00000000..55ef7cff Binary files /dev/null and b/internal/test/Tools/TestUtils.LCOM differ diff --git a/internal/test/Tools/TestUtils.TEdit b/internal/test/Tools/TestUtils.TEdit new file mode 100644 index 00000000..c2a718b3 Binary files /dev/null and b/internal/test/Tools/TestUtils.TEdit differ diff --git a/internal/test/Tools/VARBROWSER b/internal/test/Tools/VARBROWSER new file mode 100644 index 00000000..7ea72e1d --- /dev/null +++ b/internal/test/Tools/VARBROWSER @@ -0,0 +1 @@ +(FILECREATED "22-Jul-85 13:26:35" {DSK}UTILITIES>VARBROWSER.;2 12094 changes to: (FNS VARBROWSER VB.CREATE-LIST-OF-EQ-WIDTH-MENUS VB.CREATE-ICON-WINDOW) (VARS VARBROWSERCOMS VB.MASK VB.ICON) previous date: "16-Jul-85 13:22:23" {DSK}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 00000000..77a07d3f Binary files /dev/null and b/internal/test/Tools/VARBROWSER.LCOM differ 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 00000000..c8608897 Binary files /dev/null and b/internal/test/admin/Running-AR-Test-Cases.TEdit differ 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 00000000..39beb0a0 Binary files /dev/null and b/internal/test/env/DEdit/report.TEdit differ 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 +H1Qz \ 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))5g)&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))5g)&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))5g)&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 00000000..57896548 Binary files /dev/null and b/internal/test/env/Debugger/logs/debugger.log differ 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 00000000..57896548 Binary files /dev/null and b/internal/test/env/Debugger/logs/debugger.log.~7~ differ 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 00000000..fd7206f5 Binary files /dev/null and b/internal/test/env/Exec/Hand/log-form differ 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 00000000..ce2194c3 Binary files /dev/null and b/internal/test/env/Exec/Hand/test.proc differ diff --git a/internal/test/env/Exec/Hand/time.u b/internal/test/env/Exec/Hand/time.u new file mode 100644 index 00000000..cd655e1a --- /dev/null +++ b/internal/test/env/Exec/Hand/time.u @@ -0,0 +1 @@ +;; Function To Be Tested: TIME (Programmer's Assistant Command) ;; ;; Source: Xerox Common Lisp Implementation Notes (Lyric Beta Release) ;; CLtL, Section 20.2 ;; Section: The EXEC ;; Page: 29 ;; ;; Created By: John Park ;; ;; Creation Date: Feb 23, 1987 ;; ;; Last Update: March 24, 1987 ;; ;; Filed As: {ERIS}exec>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 00000000..0f93888c Binary files /dev/null and b/internal/test/env/FreeMenu/Auto/FREEMENU.TEST differ 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 00000000..e033b950 Binary files /dev/null and b/internal/test/env/Program-Support/Auto/CLISP.TEST differ 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 00000000..e033b950 Binary files /dev/null and b/internal/test/env/Program-Support/Auto/CLISP.TEST.~2~ differ 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 00000000..36181837 Binary files /dev/null and b/internal/test/env/code-editor/hand/report.tedit differ 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 00000000..45bf3f07 Binary files /dev/null and b/internal/test/env/inspector/hand/inspect-allrec.tedit differ diff --git a/internal/test/env/inspector/hand/inspect-code.tedit b/internal/test/env/inspector/hand/inspect-code.tedit new file mode 100644 index 00000000..9d589aa7 Binary files /dev/null and b/internal/test/env/inspector/hand/inspect-code.tedit differ diff --git a/internal/test/env/inspector/hand/inspect-defstruct.tedit b/internal/test/env/inspector/hand/inspect-defstruct.tedit new file mode 100644 index 00000000..a208e5dc Binary files /dev/null and b/internal/test/env/inspector/hand/inspect-defstruct.tedit differ 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 00000000..bce6cb95 Binary files /dev/null and b/internal/test/env/inspector/hand/inspect-defstruct.tedit.~1~ differ diff --git a/internal/test/env/inspector/hand/inspect-defstruct.tedit.~2~ b/internal/test/env/inspector/hand/inspect-defstruct.tedit.~2~ new file mode 100644 index 00000000..a208e5dc Binary files /dev/null and b/internal/test/env/inspector/hand/inspect-defstruct.tedit.~2~ differ 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 00000000..dbbdafb5 Binary files /dev/null and b/internal/test/env/inspector/hand/inspect-macro.tedit differ 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 00000000..05087e2b Binary files /dev/null and b/internal/test/env/inspector/hand/inspect-macro.tedit.~1~ differ 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 00000000..dbbdafb5 Binary files /dev/null and b/internal/test/env/inspector/hand/inspect-macro.tedit.~2~ differ diff --git a/internal/test/env/inspector/hand/inspectfieldflg.tedit b/internal/test/env/inspector/hand/inspectfieldflg.tedit new file mode 100644 index 00000000..51f1cee0 Binary files /dev/null and b/internal/test/env/inspector/hand/inspectfieldflg.tedit differ 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 00000000..583aaa6e Binary files /dev/null and b/internal/test/env/inspector/hand/inspectfieldflg.tedit.~1~ differ 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 00000000..51f1cee0 Binary files /dev/null and b/internal/test/env/inspector/hand/inspectfieldflg.tedit.~2~ differ diff --git a/internal/test/env/inspector/hand/inspectw.tedit b/internal/test/env/inspector/hand/inspectw.tedit new file mode 100644 index 00000000..492201a1 Binary files /dev/null and b/internal/test/env/inspector/hand/inspectw.tedit differ 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 00000000..6f6e0f04 Binary files /dev/null and b/internal/test/env/inspector/hand/inspectw.tedit.~1~ differ diff --git a/internal/test/env/inspector/hand/inspectw.tedit.~2~ b/internal/test/env/inspector/hand/inspectw.tedit.~2~ new file mode 100644 index 00000000..492201a1 Binary files /dev/null and b/internal/test/env/inspector/hand/inspectw.tedit.~2~ differ diff --git a/internal/test/env/inspector/hand/report.tedit b/internal/test/env/inspector/hand/report.tedit new file mode 100644 index 00000000..c85a7b86 Binary files /dev/null and b/internal/test/env/inspector/hand/report.tedit differ diff --git a/internal/test/env/inspector/hand/userdef.test b/internal/test/env/inspector/hand/userdef.test new file mode 100644 index 00000000..eb9f52dc --- /dev/null +++ b/internal/test/env/inspector/hand/userdef.test @@ -0,0 +1 @@ +;; WARNING!! This test file will report spurious errors if run twice ;; in the same sysout!! You have been warned... (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/env/inspector/hand/userdef.test.~1~ b/internal/test/env/inspector/hand/userdef.test.~1~ new file mode 100644 index 00000000..ef59059a --- /dev/null +++ b/internal/test/env/inspector/hand/userdef.test.~1~ @@ -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/env/inspector/hand/userdef.test.~2~ b/internal/test/env/inspector/hand/userdef.test.~2~ new file mode 100644 index 00000000..eb9f52dc --- /dev/null +++ b/internal/test/env/inspector/hand/userdef.test.~2~ @@ -0,0 +1 @@ +;; WARNING!! This test file will report spurious errors if run twice ;; in the same sysout!! You have been warned... (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/env/inspector/logs/inspect-defstruct.log b/internal/test/env/inspector/logs/inspect-defstruct.log new file mode 100644 index 00000000..de5d1fc9 Binary files /dev/null and b/internal/test/env/inspector/logs/inspect-defstruct.log differ 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 00000000..de5d1fc9 Binary files /dev/null and b/internal/test/env/inspector/logs/inspect-defstruct.log.~2~ differ 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 00000000..dfb6266a Binary files /dev/null and b/internal/test/env/program-analysis/hand/BROWSER.GRAPH differ diff --git a/internal/test/env/program-analysis/hand/BROWSER.REPORT b/internal/test/env/program-analysis/hand/BROWSER.REPORT new file mode 100644 index 00000000..75c5ea9e --- /dev/null +++ b/internal/test/env/program-analysis/hand/BROWSER.REPORT @@ -0,0 +1 @@ + COMMAND: BROWSER TEST-ITEM: gragper-loaded? LISP VERSION: LYRIC of 26-Feb-87 21:33:01 STATUS: success DATE: 11-Mar-87 16:43:37 TESTER: jpark.pasa COMMAND: BROWSER TEST-ITEM: browser-disabled LISP VERSION: LYRIC of 26-Feb-87 21:33:01 STATUS: success DATE: 11-Mar-87 16:43:38 TESTER: jpark.pasa COMMAND: BROWSER TEST-ITEM: browser-display LISP VERSION: LYRIC of 26-Feb-87 21:33:01 STATUS: fail DATE: 11-Mar-87 17:00:40 TESTER: jpark.pasa COMMAND: BROWSER TEST-ITEM: browser-variables-bound? LISP VERSION: LYRIC of 26-Feb-87 21:33:01 STATUS: success DATE: 12-Mar-87 14:34:11 TESTER: jpark.pasa COMMAND: BROWSER TEST-ITEM: gragper-loaded? LISP VERSION: LYRIC of 26-Feb-87 21:33:01 STATUS: success DATE: 12-Mar-87 14:34:15 TESTER: jpark.pasa COMMAND: BROWSER TEST-ITEM: browser-disabled LISP VERSION: LYRIC of 26-Feb-87 21:33:01 STATUS: success DATE: 12-Mar-87 14:34:15 TESTER: jpark.pasa COMMAND: BROWSER TEST-ITEM: BROWSER-VARIABLES-BOUND? LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 9-Apr-87 08:38:45 TESTER: SCHUSTER COMMAND: BROWSER TEST-ITEM: GRAGPER-LOADED? LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: FAIL DATE: 9-Apr-87 08:38:48 TESTER: SCHUSTER COMMAND: BROWSER TEST-ITEM: BROWSER-DISABLED LISP VERSION: LYRIC of 11-Mar-87 13:49:38 STATUS: SUCCESS DATE: 9-Apr-87 08:38:51 TESTER: SCHUSTER \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.REPORT b/internal/test/env/program-analysis/hand/DATABASEFNS.REPORT new file mode 100644 index 00000000..bf8ab470 --- /dev/null +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.REPORT @@ -0,0 +1 @@ +TEST REPORT FOR DATABASEFNS COMMAND: DATABASEFNS TEST-ITEM: DABASEFNS-VARIABLES LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:26:26 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: DATABASE-UPDATE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: FAIL DATE: 20-Mar-87 16:26:26 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: DATABASE-CREATED LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:26:27 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: DATABASE-PROP-RESET LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:26:27 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: DATABASE-CREATED-BY-MAKEFILE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:26:27 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: LOADDB-FLG-NO LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:26:28 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: LOADDB-FLG-YES LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:26:29 TESTER: JPARK.PASA TOTAL TEST RUN TIME FOR DATABASEFNS: 2.43125 MINUTES COMMAND: DATABASEFNS TEST-ITEM: DABASEFNS-VARIABLES LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:50:33 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: DATABASE-UPDATE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:50:35 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: DATABASE-CREATED LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:50:35 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: DATABASE-PROP-RESET LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:50:35 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: DATABASE-CREATED-BY-MAKEFILE LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:50:36 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: LOADDB-FLG-NO LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:50:36 TESTER: JPARK.PASA COMMAND: DATABASEFNS TEST-ITEM: LOADDB-FLG-YES LISP VERSION: LYRIC of 11-Mar-87 13:34:07 STATUS: SUCCESS DATE: 20-Mar-87 16:50:36 TESTER: JPARK.PASA TOTAL TEST RUN TIME FOR DATABASEFNS: 2.4325666 MINUTES \ No newline at end of file diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U b/internal/test/env/program-analysis/hand/DATABASEFNS.U new file mode 100644 index 00000000..2cde5e8d --- /dev/null +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.U @@ -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/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 00000000..09efd41e Binary files /dev/null and b/internal/test/env/program-analysis/hand/browser-part1.u differ 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 00000000..09efd41e Binary files /dev/null and b/internal/test/env/program-analysis/hand/browser-part1.u.~3~ differ 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 00000000..9205cc1d Binary files /dev/null and b/internal/test/i/o/Display/Hand/CURSOR.PROC differ 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 00000000..01ed8569 Binary files /dev/null and b/internal/test/i/o/Display/Logs/CURSOR.LOG differ 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 00000000..1e77289a Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/FX80DRIVER.PROC differ diff --git a/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.LOG b/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.LOG new file mode 100644 index 00000000..69be0b2b Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.LOG differ 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 00000000..8f19c0cf Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.PROC differ 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 00000000..349997fb Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/STREAMTESTS.DFASL differ 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 00000000..c46dbeee Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/STRESSTEST/STRESSTEST.TEDIT differ 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 00000000..ace39487 Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/fx80driver.log differ 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 00000000..0d73c162 Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/01UR.TEDIT differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/02LOOKS.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/02LOOKS.TEDIT new file mode 100644 index 00000000..07e6b0eb Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/02LOOKS.TEDIT differ 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 00000000..2c71beda Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/03FONTS.TEDIT differ 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@@_WRK{s4WC/.ͮ J,.  L$̍ Ld,ll  d. L$n,m.md.Mm$ $ d,Ln +dN. d͍.,m$ d, .. +$ Le,l . +$.-,$l$ -n ͥ) D + +$ DE +nNln. D +DDA (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 00000000..b2193b8c Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/05PAGE.TEDIT differ 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 00000000..fcfdb908 Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/06LINE.TEDIT differ 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 00000000..fc74cbd5 Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/07NS.TEDIT differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/08IMOB.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/08IMOB.TEDIT new file mode 100644 index 00000000..63947bd7 Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/08IMOB.TEDIT differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/10MIXED.SKETCH b/internal/test/i/o/Hardcopy/Hand/testfiles/10MIXED.SKETCH new file mode 100644 index 00000000..7afc2977 Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/10MIXED.SKETCH differ 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 00000000..fefc3673 Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/11STRAIGHT.SKETCH differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/12CURVE.SKETCH b/internal/test/i/o/Hardcopy/Hand/testfiles/12CURVE.SKETCH new file mode 100644 index 00000000..a05cedd9 Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/12CURVE.SKETCH differ 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 00000000..93f84905 Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/13CHANGE.SKETCH differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/14TEXT.SKETCH b/internal/test/i/o/Hardcopy/Hand/testfiles/14TEXT.SKETCH new file mode 100644 index 00000000..7b109e04 Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/14TEXT.SKETCH differ 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 00000000..b33f1c41 Binary files /dev/null and b/internal/test/i/o/Hardcopy/Hand/testfiles/15REVERSE.SKETCH differ 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 00000000..e4aa3c6b Binary files /dev/null and b/internal/test/loops/LOOPS-SETUP.TEDIT differ diff --git a/internal/test/loops/LOOPS-TESTER-2-1 b/internal/test/loops/LOOPS-TESTER-2-1 new file mode 100644 index 00000000..c16a488e --- /dev/null +++ b/internal/test/loops/LOOPS-TESTER-2-1 @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED "17-Feb-88 16:42:23" {ERINYES}LOOPS>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 00000000..6b80a93a Binary files /dev/null and b/internal/test/loops/LOOPS-TESTER-2-1.dfasl differ 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 00000000..26f7cdde Binary files /dev/null and b/internal/test/loops/LOOPS-TESTER-2-2.dfasl differ 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 00000000..72da8b6d Binary files /dev/null and b/internal/test/loops/LOOPS-TESTER-2-4.dfasl differ 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 00000000..6642fe55 Binary files /dev/null and b/internal/test/loops/LOOPS-TESTER-BASICS.dfasl differ diff --git a/internal/test/lyric/DO-TEST b/internal/test/lyric/DO-TEST new file mode 100644 index 00000000..c5ff25d1 --- /dev/null +++ b/internal/test/lyric/DO-TEST @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "XCL-USER" READTABLE "XCL" BASE 10) (IL:FILECREATED " 7-Apr-87 19:56:45" IL:{ERIS}INTERNAL>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 00000000..a2c890cb Binary files /dev/null and b/internal/test/lyric/DO-TEST.dfasl differ diff --git a/internal/test/lyric/do-test.tedit b/internal/test/lyric/do-test.tedit new file mode 100644 index 00000000..870c2623 Binary files /dev/null and b/internal/test/lyric/do-test.tedit differ