diff --git a/internal/test/ARs/.read-me-first b/internal/test/ARs/.read-me-first deleted file mode 100644 index 367d0e4a..00000000 Binary files a/internal/test/ARs/.read-me-first and /dev/null differ diff --git a/internal/test/ARs/.read-me-first.~1~ b/internal/test/ARs/.read-me-first.~1~ deleted file mode 100644 index 1ad7c1e7..00000000 Binary files a/internal/test/ARs/.read-me-first.~1~ and /dev/null differ diff --git a/internal/test/ARs/.read-me-first.~2~ b/internal/test/ARs/.read-me-first.~2~ deleted file mode 100644 index 367d0e4a..00000000 Binary files a/internal/test/ARs/.read-me-first.~2~ and /dev/null differ diff --git a/internal/test/ARs/AR-Test-Case-Summary-Template.TEdit b/internal/test/ARs/AR-Test-Case-Summary-Template.TEdit index 9332c398..1d2bf85e 100644 Binary files a/internal/test/ARs/AR-Test-Case-Summary-Template.TEdit 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 index 92808d8f..c43e099f 100644 --- a/internal/test/ARs/Alpha-AR-TEST-CASE.Auto-log +++ b/internal/test/ARs/Alpha-AR-TEST-CASE.Auto-log @@ -1 +1,250 @@ -(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 +(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") diff --git a/internal/test/ARs/read-me-first.tedit b/internal/test/ARs/read-me-first.tedit new file mode 100644 index 00000000..26da8e3c Binary files /dev/null and b/internal/test/ARs/read-me-first.tedit differ diff --git a/internal/test/GC/HAND-AUX/ADVDICT-N-Z.TEDIT b/internal/test/GC/HAND-AUX/ADVDICT-N-Z.TEDIT index 4e139f2e..da1ec18f 100644 Binary files a/internal/test/GC/HAND-AUX/ADVDICT-N-Z.TEDIT 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 index f7a00dde..94c99d90 100644 Binary files a/internal/test/GC/HAND-AUX/DANCER10-C0.DISPLAYFONT 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 index 9ae49c75..36ef5396 100644 Binary files a/internal/test/GC/HAND-AUX/Dancer12-C0.DisplayFont and b/internal/test/GC/HAND-AUX/Dancer12-C0.DisplayFont differ diff --git a/internal/test/GC/Hand/DANCEROBJ b/internal/test/GC/Hand/DANCEROBJ index 064266c6..64024a06 100644 --- a/internal/test/GC/Hand/DANCEROBJ +++ b/internal/test/GC/Hand/DANCEROBJ @@ -1 +1,1407 @@ -(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 +(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 diff --git a/internal/test/GC/Hand/DANCEROBJ.LCOM b/internal/test/GC/Hand/DANCEROBJ.LCOM index 6f1a3a31..dacbcf05 100644 Binary files a/internal/test/GC/Hand/DANCEROBJ.LCOM 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 index d8df862f..ad353028 100644 --- a/internal/test/GC/Hand/MAIKO-GC-TESTS +++ b/internal/test/GC/Hand/MAIKO-GC-TESTS @@ -1 +1,925 @@ -(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 +(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 diff --git a/internal/test/GC/Hand/MAIKO-GC-TESTS.DATABASE b/internal/test/GC/Hand/MAIKO-GC-TESTS.DATABASE index 84f8813b..cd78faa6 100644 --- a/internal/test/GC/Hand/MAIKO-GC-TESTS.DATABASE +++ b/internal/test/GC/Hand/MAIKO-GC-TESTS.DATABASE @@ -1 +1,175 @@ -(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 +(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 + +) diff --git a/internal/test/GC/Hand/MAIKO-GC-TESTS.LCOM b/internal/test/GC/Hand/MAIKO-GC-TESTS.LCOM index ad86f35d..c4fac80b 100644 Binary files a/internal/test/GC/Hand/MAIKO-GC-TESTS.LCOM 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~ index 54b3a46f..d0591915 100644 --- a/internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ +++ b/internal/test/GC/Hand/MAIKO-GC-TESTS.~1~ @@ -1 +1,920 @@ -(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 +(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 diff --git a/internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ b/internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ index d8df862f..ad353028 100644 --- a/internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ +++ b/internal/test/GC/Hand/MAIKO-GC-TESTS.~2~ @@ -1 +1,925 @@ -(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 +(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 diff --git a/internal/test/GC/Hand/Maiko-GC-Tests.script b/internal/test/GC/Hand/Maiko-GC-Tests.script index 1a26243b..f86b16eb 100644 --- a/internal/test/GC/Hand/Maiko-GC-Tests.script +++ b/internal/test/GC/Hand/Maiko-GC-Tests.script @@ -1 +1,29 @@ -;;; 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 +;;; 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. diff --git a/internal/test/IO/Auto/IO-REGRESSION.TEST b/internal/test/IO/Auto/IO-REGRESSION.TEST index 490f0d8c..2289be4e 100644 Binary files a/internal/test/IO/Auto/IO-REGRESSION.TEST 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 index 12ecfaea..a73874b1 100644 Binary files a/internal/test/IO/Auto/MSPF.TEST 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 index f35339e3..14e65c04 100644 --- a/internal/test/IO/Auto/Peekbin.test +++ b/internal/test/IO/Auto/Peekbin.test @@ -1 +1,77 @@ -(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 +(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 diff --git a/internal/test/IO/Hand-Aux/AR11004-Arith-OFlow.IP b/internal/test/IO/Hand-Aux/AR11004-Arith-OFlow.IP index 9255877f..2f317d7d 100644 Binary files a/internal/test/IO/Hand-Aux/AR11004-Arith-OFlow.IP 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 index d5281f83..cadb4ef2 100644 --- a/internal/test/LANGUAGE/AUTO/.read-me-first +++ b/internal/test/LANGUAGE/AUTO/.read-me-first @@ -1 +1,3 @@ -This file obsolete, see: {ERIS}.read-me-first \ No newline at end of file +This file obsolete, see: + +{ERIS}.read-me-first diff --git a/internal/test/LANGUAGE/AUTO/.read-me-first.~1~ b/internal/test/LANGUAGE/AUTO/.read-me-first.~1~ index c3012707..a27b4716 100644 Binary files a/internal/test/LANGUAGE/AUTO/.read-me-first.~1~ 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~ index d5281f83..cadb4ef2 100644 --- a/internal/test/LANGUAGE/AUTO/.read-me-first.~2~ +++ b/internal/test/LANGUAGE/AUTO/.read-me-first.~2~ @@ -1 +1,3 @@ -This file obsolete, see: {ERIS}.read-me-first \ No newline at end of file +This file obsolete, see: + +{ERIS}.read-me-first diff --git a/internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.DFASL b/internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.DFASL index bc20495e..ed2b6db1 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.DFASL 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 index e8c94d85..7fba5619 100644 --- a/internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.TEST +++ b/internal/test/LANGUAGE/AUTO/10-1-GET-PROPERTIES.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/10-1-GET.DFASL b/internal/test/LANGUAGE/AUTO/10-1-GET.DFASL index 8190a18d..739b274b 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-1-GET.DFASL 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 index 959cdc6e..c7a2baea 100644 --- a/internal/test/LANGUAGE/AUTO/10-1-GET.TEST +++ b/internal/test/LANGUAGE/AUTO/10-1-GET.TEST @@ -1 +1,102 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/10-1-GETF.DFASL b/internal/test/LANGUAGE/AUTO/10-1-GETF.DFASL index a64b46f2..c7c65253 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-1-GETF.DFASL 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 index 50fd0686..cf044d35 100644 --- a/internal/test/LANGUAGE/AUTO/10-1-GETF.TEST +++ b/internal/test/LANGUAGE/AUTO/10-1-GETF.TEST @@ -1 +1,85 @@ -;; 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 +;; 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 index d48beabb..48e41324 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-1-REMF.DFASL 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 index 11972e1e..5c12eafc 100644 --- a/internal/test/LANGUAGE/AUTO/10-1-REMF.TEST +++ b/internal/test/LANGUAGE/AUTO/10-1-REMF.TEST @@ -1 +1,60 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/10-1-REMPROP.DFASL b/internal/test/LANGUAGE/AUTO/10-1-REMPROP.DFASL index 99dfb0ce..1dc68bba 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-1-REMPROP.DFASL 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 index 1b5b28c9..094220cb 100644 --- a/internal/test/LANGUAGE/AUTO/10-1-REMPROP.TEST +++ b/internal/test/LANGUAGE/AUTO/10-1-REMPROP.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.DFASL b/internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.DFASL index 2a4f746c..17c86f55 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.DFASL 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 index 1f97d9cb..46858c36 100644 --- a/internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.TEST +++ b/internal/test/LANGUAGE/AUTO/10-1-SYMBOL-PLIST.TEST @@ -1 +1,72 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.DFASL b/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.DFASL index df5817be..24478966 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.DFASL 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 index d10c33d1..92b62433 100644 --- a/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.TEST +++ b/internal/test/LANGUAGE/AUTO/10-2-SYMBOL-NAME.TEST @@ -1 +1,50 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.DFASL b/internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.DFASL index 72776bb3..a0a7caf8 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.DFASL 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 index f1a8d488..a65d139d 100644 --- a/internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.TEST +++ b/internal/test/LANGUAGE/AUTO/10-3-COPY-SYMBOL.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/10-3-GENSYM.DFASL b/internal/test/LANGUAGE/AUTO/10-3-GENSYM.DFASL index f58e197d..97d785a5 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-3-GENSYM.DFASL 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 index 4f1ab42a..addcd67c 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-3-GENSYM.TEST 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 index 91fcafb4..d3bc0305 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-3-GENTEMP.DFASL 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 index 917a078b..f3e9c893 100644 --- a/internal/test/LANGUAGE/AUTO/10-3-GENTEMP.TEST +++ b/internal/test/LANGUAGE/AUTO/10-3-GENTEMP.TEST @@ -1 +1,142 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.DFASL b/internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.DFASL index 10a0b242..ae459397 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.DFASL 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 index be1d4ec0..3c7290ea 100644 --- a/internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.TEST +++ b/internal/test/LANGUAGE/AUTO/10-3-KEYWORDP.TEST @@ -1 +1,42 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.DFASL b/internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.DFASL index 425dc7d4..0a2723ee 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.DFASL 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 index d3323036..61fa0ef4 100644 --- a/internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.TEST +++ b/internal/test/LANGUAGE/AUTO/10-3-MAKE-SYMBOL.TEST @@ -1 +1,39 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.DFASL index 1ac880d5..a9977dac 100644 Binary files a/internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.DFASL 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 index 5fc0e707..4b909fc1 100644 --- a/internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.TEST +++ b/internal/test/LANGUAGE/AUTO/10-3-SYMBOL-PACKAGE.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/11-6-IMPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-6-IMPORT.DFASL index 28d8969a..0a9d03f2 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-6-IMPORT.DFASL 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 index e15c3909..f3ad73f9 100644 --- a/internal/test/LANGUAGE/AUTO/11-6-IMPORT.TEST +++ b/internal/test/LANGUAGE/AUTO/11-6-IMPORT.TEST @@ -1 +1,49 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.DFASL index 662895b8..36d7b83b 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.DFASL 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 index 35563012..e42853d1 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-DO-ALL-SYMBOLS.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.DFASL index d46292b0..9c288806 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.DFASL 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 index 14b3c236..88ed7311 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-DO-EXTERNAL-SYMBOLS.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.DFASL index 24700b43..eea18f70 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.DFASL 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 index ccb0531a..1cc2e1d9 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-DO-SYMBOLS.TEST @@ -1 +1,81 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-EXPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-7-EXPORT.DFASL index fb742032..cabc8b58 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-EXPORT.DFASL 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 index a3e1e450..44295698 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-EXPORT.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-EXPORT.TEST @@ -1 +1,67 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.DFASL index 1c29266f..a74f17a9 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.DFASL 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 index 3ff17cad..93e0963f 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-FIND-ALL-SYMBOLS.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.DFASL index fe0896f3..6d78f46e 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.DFASL 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 index f229d7df..7e08915c 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-FIND-PACKAGE.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.DFASL b/internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.DFASL index e185e8c8..e5809f3d 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.DFASL 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 index cee00adc..d7a7c800 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-FIND-SYMBOL.TEST @@ -1 +1,61 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-IMPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-7-IMPORT.DFASL index cab7952b..086cb823 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-IMPORT.DFASL 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 index d9287be0..9ef4d4fe 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-IMPORT.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-IMPORT.TEST @@ -1 +1,51 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.DFASL index 6127e649..49ca00d8 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.DFASL 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 index a93f66b9..f3b663f3 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-IN-PACKAGE.TEST @@ -1 +1,57 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-INTERN.DFASL b/internal/test/LANGUAGE/AUTO/11-7-INTERN.DFASL index c10ba974..3d24010b 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-INTERN.DFASL 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 index 70673c12..dfe52842 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-INTERN.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-INTERN.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.DFASL b/internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.DFASL index 5e155506..c63328be 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.DFASL 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 index 7db42315..8896f888 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-LIST-ALL-PACKAGES.TEST @@ -1 +1,45 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.DFASL index 88070d30..8cdc5a47 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.DFASL 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 index e6f11fbd..90e6b51a 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-MAKE-PACKAGE.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.DFASL b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.DFASL index a64c827e..e6f21b7f 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.DFASL 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 index 45e5228e..58e52490 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NAME.TEST @@ -1 +1,49 @@ - ;; 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 + +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.DFASL b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.DFASL index 33ad1be1..d0d55e1d 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.DFASL 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 index d10337fe..e199fbee 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-NICKNAMES.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL index cd484fc1..9cc50860 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL 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 index 97f76cce..194201cc 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-SHADOWING-SYMBOLS.TEST @@ -1 +1,48 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.DFASL b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.DFASL index ed56cc99..3191268c 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.DFASL 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 index 6427cb03..d9e7bf8b 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USE-LIST.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 + + 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 index d44cbb36..01003650 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USED-BY-LIST.DFASL 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 index b35e8100..d144f87b 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USED-BY-LIST.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-PACKAGE-USED-BY-LIST.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.DFASL index a0450ce7..961ada51 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.DFASL 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 index 16f94ec3..09b4c43c 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-RENAME-PACKAGE.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-SHADOW.DFASL b/internal/test/LANGUAGE/AUTO/11-7-SHADOW.DFASL index f75aa46c..32eff8ba 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-SHADOW.DFASL 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 index 87441938..31de7fbf 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-SHADOW.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-SHADOW.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.DFASL index b020270d..96c355d4 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.DFASL 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 index 0ccbff6a..f21e4ed0 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-SHADOWING-IMPORT.TEST @@ -1 +1,59 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.DFASL b/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.DFASL index b249238a..5ff11331 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.DFASL 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 index 65653fb4..0aaf0f9d 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-UNEXPORT.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-UNINTERN.DFASL b/internal/test/LANGUAGE/AUTO/11-7-UNINTERN.DFASL index 8f9c0e12..39577cc5 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-UNINTERN.DFASL 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 index b8c2c190..e453cbf3 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-UNINTERN.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-UNINTERN.TEST @@ -1 +1,61 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.DFASL index f796c55c..37cf8890 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.DFASL 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 index 73cec8a4..f8331b95 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-UNUSE-PACKAGE.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.DFASL b/internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.DFASL index 3af07b5c..faa5e8ed 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.DFASL 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 index 473ced46..210afa88 100644 --- a/internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.TEST +++ b/internal/test/LANGUAGE/AUTO/11-7-USE-PACKAGE.TEST @@ -1 +1,45 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/11-8-PROVIDE.DFASL b/internal/test/LANGUAGE/AUTO/11-8-PROVIDE.DFASL index 9c4b403e..01e93248 100644 Binary files a/internal/test/LANGUAGE/AUTO/11-8-PROVIDE.DFASL 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 index ac656502..6807336f 100644 --- a/internal/test/LANGUAGE/AUTO/11-8-PROVIDE.TEST +++ b/internal/test/LANGUAGE/AUTO/11-8-PROVIDE.TEST @@ -1 +1,54 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.DFASL b/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.DFASL index e6ebcf6c..48f29c24 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.DFASL 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 index a9161124..f256beff 100644 --- a/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.TEST +++ b/internal/test/LANGUAGE/AUTO/12-10-IMPLEMENTATION-PARAMETERS.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 index 6c263796..6fba3d36 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-2-EVENP.DFASL 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 index 46401116..fd8bb8c9 100644 --- a/internal/test/LANGUAGE/AUTO/12-2-EVENP.TEST +++ b/internal/test/LANGUAGE/AUTO/12-2-EVENP.TEST @@ -1 +1,36 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-2-EVENP.TST b/internal/test/LANGUAGE/AUTO/12-2-EVENP.TST index 968e3cb9..11555ea4 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-2-EVENP.TST 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 index 87636c1c..e0f57cd2 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-2-MINUSP.DFASL 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 index fcc37363..15425cce 100644 --- a/internal/test/LANGUAGE/AUTO/12-2-MINUSP.TEST +++ b/internal/test/LANGUAGE/AUTO/12-2-MINUSP.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-2-MINUSP.TST b/internal/test/LANGUAGE/AUTO/12-2-MINUSP.TST index 0fbea9ab..cc1200bf 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-2-MINUSP.TST 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 index 0677139e..6b4f93ca 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-2-ODDP.DFASL 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 index 5248b9d0..323c7028 100644 --- a/internal/test/LANGUAGE/AUTO/12-2-ODDP.TEST +++ b/internal/test/LANGUAGE/AUTO/12-2-ODDP.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-2-ODDP.TST b/internal/test/LANGUAGE/AUTO/12-2-ODDP.TST index 06fc9b89..e575f860 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-2-ODDP.TST 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 index fd398704..9bd6d1c1 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-2-PLUSP.DFASL 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 index 53916c0b..fa608316 100644 --- a/internal/test/LANGUAGE/AUTO/12-2-PLUSP.TEST +++ b/internal/test/LANGUAGE/AUTO/12-2-PLUSP.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-2-PLUSP.TST b/internal/test/LANGUAGE/AUTO/12-2-PLUSP.TST index 3a8decc7..fd0e0fb3 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-2-PLUSP.TST 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 index 96004e1e..873b0dee 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-2-ZEROP.DFASL 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 index 87266fe5..ed374b5f 100644 --- a/internal/test/LANGUAGE/AUTO/12-2-ZEROP.TEST +++ b/internal/test/LANGUAGE/AUTO/12-2-ZEROP.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-2-ZEROP.TXT b/internal/test/LANGUAGE/AUTO/12-2-ZEROP.TXT index d2c36234..a21b8ccc 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-2-ZEROP.TXT 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 index 1f323114..22caef14 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-3-EQP.DFASL 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 index 83835fd7..20f0d52c 100644 --- a/internal/test/LANGUAGE/AUTO/12-3-EQP.TEST +++ b/internal/test/LANGUAGE/AUTO/12-3-EQP.TEST @@ -1 +1,109 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-3-GEQ.DFASL b/internal/test/LANGUAGE/AUTO/12-3-GEQ.DFASL index af8b8189..e1bc779e 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-3-GEQ.DFASL 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 index a51c6d65..698ef3c2 100644 --- a/internal/test/LANGUAGE/AUTO/12-3-GEQ.TEST +++ b/internal/test/LANGUAGE/AUTO/12-3-GEQ.TEST @@ -1 +1,130 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-3-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/12-3-GREATERP.DFASL index d315d2f4..1bd5b660 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-3-GREATERP.DFASL 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 index dc22e12c..9033d864 100644 --- a/internal/test/LANGUAGE/AUTO/12-3-GREATERP.TEST +++ b/internal/test/LANGUAGE/AUTO/12-3-GREATERP.TEST @@ -1 +1,124 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-3-LEQ.DFASL b/internal/test/LANGUAGE/AUTO/12-3-LEQ.DFASL index 04fddfc1..445d59e4 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-3-LEQ.DFASL 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 index 622be6e2..22780ab2 100644 --- a/internal/test/LANGUAGE/AUTO/12-3-LEQ.TEST +++ b/internal/test/LANGUAGE/AUTO/12-3-LEQ.TEST @@ -1 +1,129 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-3-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/12-3-LESSP.DFASL index 7d272754..99bac10c 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-3-LESSP.DFASL 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 index f9247118..0701cdde 100644 --- a/internal/test/LANGUAGE/AUTO/12-3-LESSP.TEST +++ b/internal/test/LANGUAGE/AUTO/12-3-LESSP.TEST @@ -1 +1,124 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-3-MAX.DFASL b/internal/test/LANGUAGE/AUTO/12-3-MAX.DFASL index b0c4dc13..11d62bb6 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-3-MAX.DFASL 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 index 277574d9..5d2e624a 100644 --- a/internal/test/LANGUAGE/AUTO/12-3-MAX.TEST +++ b/internal/test/LANGUAGE/AUTO/12-3-MAX.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-3-MIN.DFASL b/internal/test/LANGUAGE/AUTO/12-3-MIN.DFASL index d6ea5edf..2a257130 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-3-MIN.DFASL 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 index c918592c..4a4b9cc4 100644 --- a/internal/test/LANGUAGE/AUTO/12-3-MIN.TEST +++ b/internal/test/LANGUAGE/AUTO/12-3-MIN.TEST @@ -1 +1,71 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONDECREASE.TEST b/internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONDECREASE.TEST index cc70f120..f6c829cb 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONDECREASE.TEST 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 index 11e6c5cb..36a8ac6a 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-3-MONOTONIC-NONINCREASE.TEST 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 index d2727e0c..81906601 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-3-NEQP.DFASL 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 index 5af4e7c1..f1703b7b 100644 --- a/internal/test/LANGUAGE/AUTO/12-3-NEQP.TEST +++ b/internal/test/LANGUAGE/AUTO/12-3-NEQP.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-4-+.DFASL b/internal/test/LANGUAGE/AUTO/12-4-+.DFASL index 7bb06066..b00a1053 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4-+.DFASL 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 index 6b08ead2..3a7a854d 100644 --- a/internal/test/LANGUAGE/AUTO/12-4-+.TEST +++ b/internal/test/LANGUAGE/AUTO/12-4-+.TEST @@ -1 +1,73 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-4--.DFASL b/internal/test/LANGUAGE/AUTO/12-4--.DFASL index 9a86d40c..163165c7 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4--.DFASL 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 index 86fb0249..544e4ff7 100644 --- a/internal/test/LANGUAGE/AUTO/12-4--.TEST +++ b/internal/test/LANGUAGE/AUTO/12-4--.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-4-1+.DFASL b/internal/test/LANGUAGE/AUTO/12-4-1+.DFASL index 26a3b123..79f1e7bb 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4-1+.DFASL 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 index c4b82a90..bc727ab9 100644 --- a/internal/test/LANGUAGE/AUTO/12-4-1+.TEST +++ b/internal/test/LANGUAGE/AUTO/12-4-1+.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-4-1-.DFASL b/internal/test/LANGUAGE/AUTO/12-4-1-.DFASL index d291e91a..ed58dd9c 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4-1-.DFASL 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 index c134f6a1..90f9b77a 100644 --- a/internal/test/LANGUAGE/AUTO/12-4-1-.TEST +++ b/internal/test/LANGUAGE/AUTO/12-4-1-.TEST @@ -1 +1,45 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.DFASL b/internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.DFASL index b1af9267..14119d6a 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.DFASL 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 index 9973e736..353a3c22 100644 --- a/internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.TEST +++ b/internal/test/LANGUAGE/AUTO/12-4-CONJUGATE.TEST @@ -1 +1,42 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-4-DECF.DFASL b/internal/test/LANGUAGE/AUTO/12-4-DECF.DFASL index 639240c2..5fd0feba 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4-DECF.DFASL 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 index 61cc7588..fd96b3b3 100644 --- a/internal/test/LANGUAGE/AUTO/12-4-DECF.TEST +++ b/internal/test/LANGUAGE/AUTO/12-4-DECF.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-4-GCD.DFASL b/internal/test/LANGUAGE/AUTO/12-4-GCD.DFASL index 1a7d2aac..3a7dd054 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4-GCD.DFASL 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 index 26848e4a..d5b049d7 100644 --- a/internal/test/LANGUAGE/AUTO/12-4-GCD.TEST +++ b/internal/test/LANGUAGE/AUTO/12-4-GCD.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-4-INCF.DFASL b/internal/test/LANGUAGE/AUTO/12-4-INCF.DFASL index 645e96c5..d1b97dee 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4-INCF.DFASL 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 index 85a1ab44..a677cfb2 100644 --- a/internal/test/LANGUAGE/AUTO/12-4-INCF.TEST +++ b/internal/test/LANGUAGE/AUTO/12-4-INCF.TEST @@ -1 +1,49 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-4-LCM.DFASL b/internal/test/LANGUAGE/AUTO/12-4-LCM.DFASL index 8406d795..f6dc86ef 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4-LCM.DFASL 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 index f2369259..d92e69c4 100644 --- a/internal/test/LANGUAGE/AUTO/12-4-LCM.TEST +++ b/internal/test/LANGUAGE/AUTO/12-4-LCM.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.DFASL b/internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.DFASL index 1330a09d..e75bfad8 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.DFASL 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 index bbcf662e..02f8c6ad 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4-QUOTIENT.TEST 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 index 5d0f26f6..7ab1c52c 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-4-TIMES.DFASL 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 index 1d1ceeee..80e06ce7 100644 --- a/internal/test/LANGUAGE/AUTO/12-4-TIMES.TEST +++ b/internal/test/LANGUAGE/AUTO/12-4-TIMES.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-EXP.DFASL b/internal/test/LANGUAGE/AUTO/12-5-1-EXP.DFASL index 134ccfa5..ca0c01d3 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-1-EXP.DFASL 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 index f4bafdf2..1aa80fa1 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-1-EXP.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-1-EXP.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-EXPT.DFASL b/internal/test/LANGUAGE/AUTO/12-5-1-EXPT.DFASL index 97023147..2cd0c00a 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-1-EXPT.DFASL 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 index c3be36f7..cbcf7421 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-1-EXPT.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-1-EXPT.TEST @@ -1 +1,76 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.DFASL b/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.DFASL index 31064a09..637c99fa 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.DFASL 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 index 7abd3f8a..c51a2e5a 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-1-ISQRT.TEST @@ -1 +1,43 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-LOG.DFASL b/internal/test/LANGUAGE/AUTO/12-5-1-LOG.DFASL index 52cb5ad4..d80920fe 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-1-LOG.DFASL 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 index cd499f6b..76a8534d 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-1-LOG.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-1-LOG.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-5-1-SQRT.DFASL b/internal/test/LANGUAGE/AUTO/12-5-1-SQRT.DFASL index 5d9bef85..b83e9d82 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-1-SQRT.DFASL 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 index 8e273768..e17e777b 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-1-SQRT.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-1-SQRT.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ABS.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ABS.DFASL index a85443eb..54a354d5 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-ABS.DFASL 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 index ee89561e..e511436e 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-ABS.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ABS.TEST @@ -1 +1,56 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ACOS.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ACOS.DFASL index af7bfde0..7bfef9cf 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-ACOS.DFASL 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 index 66d70198..c8de277d 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-ACOS.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ACOS.TEST @@ -1 +1,73 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.DFASL index 0babd097..4d207978 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.DFASL 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 index 9d4d69a2..8b13e2a2 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ACOSH.TEST @@ -1 +1,94 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ASIN.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ASIN.DFASL index c127ce2a..41cf3e71 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-ASIN.DFASL 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 index 21168b9b..405786cc 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-ASIN.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ASIN.TEST @@ -1 +1,73 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ASINH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ASINH.DFASL index 56d9b955..ae4cb3bb 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-ASINH.DFASL 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 index 7e9d9eee..73c7c85b 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-ASINH.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ASINH.TEST @@ -1 +1,91 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-ATAN.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-ATAN.DFASL index 7d003a92..a72d39fb 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-ATAN.DFASL 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 index f38d1e37..a76dde38 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-ATAN.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ATAN.TEST @@ -1 +1,138 @@ -;; 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 +;; 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 index 7a4bd970..7eeee78c 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-ATANH.DFASL 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 index fb1a2e6c..158d7fdc 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-ATANH.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-ATANH.TEST @@ -1 +1,105 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-CIS.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-CIS.DFASL index 2e4e2164..f96b3461 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-CIS.DFASL 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 index a55eb7ca..3578d9a4 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-CIS.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-CIS.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-COS.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-COS.DFASL index 1500e6ca..59361151 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-COS.DFASL 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 index 043e71bf..592dd1cf 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-COS.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-COS.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-COSH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-COSH.DFASL index 5d7190ef..67b7c948 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-COSH.DFASL 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 index 4aefbaac..c7194cac 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-COSH.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-COSH.TEST @@ -1 +1,92 @@ - ;; 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 + +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-PHASE.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-PHASE.DFASL index 4695723c..dcc57f24 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-PHASE.DFASL 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 index 4131fdaa..1731c153 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-PHASE.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-PHASE.TEST @@ -1 +1,84 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.DFASL index 866665fb..64281de8 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.DFASL 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 index b0525335..10f3ec94 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-SIGNUM.TEST @@ -1 +1,101 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-SIN.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-SIN.DFASL index 2bf84756..ad98cba4 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-SIN.DFASL 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 index c829d0ee..d2dab431 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-SIN.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-SIN.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-SINH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-SINH.DFASL index 70a98602..1d1b6758 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-SINH.DFASL 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 index 128813a6..68d9d228 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-SINH.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-SINH.TEST @@ -1 +1,93 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-TAN.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-TAN.DFASL index 5f9aab29..b3f30ab1 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-TAN.DFASL 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 index 2f679949..82777122 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-TAN.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-TAN.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-5-2-TANH.DFASL b/internal/test/LANGUAGE/AUTO/12-5-2-TANH.DFASL index 1cfaf94f..5213b348 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-5-2-TANH.DFASL 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 index 0a13db09..b637ad06 100644 --- a/internal/test/LANGUAGE/AUTO/12-5-2-TANH.TEST +++ b/internal/test/LANGUAGE/AUTO/12-5-2-TANH.TEST @@ -1 +1,94 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-CEILING.DFASL b/internal/test/LANGUAGE/AUTO/12-6-CEILING.DFASL index 27798b65..c8df1ee8 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-CEILING.DFASL 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 index f3688a1e..e5bf0241 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-CEILING.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-CEILING.TEST @@ -1 +1,138 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-COMPLEX.DFASL b/internal/test/LANGUAGE/AUTO/12-6-COMPLEX.DFASL index 861ea10f..96bbe07e 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-COMPLEX.DFASL 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 index 1b6d4e9a..a24d2d8d 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-COMPLEX.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-COMPLEX.TEST @@ -1 +1,39 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.DFASL b/internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.DFASL index 3fcbb3d5..1a455d9b 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.DFASL 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 index 92e82a1d..7a970261 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-DECODE-FLOAT.TEST @@ -1 +1,54 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.DFASL b/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.DFASL index c709c252..55a717f1 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.DFASL 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 index e22f1143..a8c62e0c 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-DENOMINATOR.TEST @@ -1 +1,44 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-FCEILING.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FCEILING.DFASL index 0bd76882..e2d8bfcb 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-FCEILING.DFASL 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 index dac989fd..3091d92f 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-FCEILING.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-FCEILING.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.DFASL index 82b5029b..565bf10d 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.DFASL 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 index 9e390a45..56ad9a0b 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-FFLOOR.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.DFASL index c74fc801..ff1b8f1e 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.DFASL 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 index 626a9b2e..c64977fd 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-DIGITS.TEST @@ -1 +1,45 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.DFASL index 052268f2..b75cabd8 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.DFASL 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 index 8fdbdc95..0a8193c5 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-PRECISION.TEST @@ -1 +1,51 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.DFASL index fbb1a041..fdfa203f 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.DFASL 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 index a2d85fbf..179acf69 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-RADIX.TEST @@ -1 +1,44 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.DFASL index a282844d..bc07ec63 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.DFASL 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 index 3df45ea2..be9695fa 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-FLOAT-SIGN.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOAT.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOAT.DFASL index d79f7f56..6e54f52c 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-FLOAT.DFASL 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 index b8ed6448..b053e993 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-FLOAT.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-FLOAT.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-FLOOR.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FLOOR.DFASL index 55806686..733b706d 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-FLOOR.DFASL 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 index 0ed5c8cc..985d0b0e 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-FLOOR.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-FLOOR.TEST @@ -1 +1,138 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-FROUND.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FROUND.DFASL index 92698194..5d12b603 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-FROUND.DFASL 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 index b3da9296..d3533342 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-FROUND.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-FROUND.TEST @@ -1 +1,63 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.DFASL b/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.DFASL index 48cbc0ca..65210ba4 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.DFASL 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 index e0569c90..9995f46d 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-FTRUNCATE.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-IMAGPART.DFASL b/internal/test/LANGUAGE/AUTO/12-6-IMAGPART.DFASL index e5b3fe50..9c8a73c2 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-IMAGPART.DFASL 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 index ac90f5b1..6f26c02b 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-IMAGPART.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-IMAGPART.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.DFASL b/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.DFASL index eb99080e..c52ba581 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.DFASL 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 index f4c0407c..0736ac07 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-INTEGER-DECODE-FLOAT.TEST @@ -1 +1,73 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-6-MOD.DFASL b/internal/test/LANGUAGE/AUTO/12-6-MOD.DFASL index ebd1d962..dbd01fd0 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-MOD.DFASL 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 index 4486d09b..a8f56efe 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-MOD.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-MOD.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.DFASL b/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.DFASL index fa5a2d8a..8e1fecd7 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.DFASL 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 index b7c60994..c916aa48 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-NUMERATOR.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-RATIONAL.DFASL b/internal/test/LANGUAGE/AUTO/12-6-RATIONAL.DFASL index 62b206bf..4f78b3c4 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-RATIONAL.DFASL 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 index 7ac2c6a0..708a1e3c 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-RATIONAL.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-RATIONAL.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.DFASL b/internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.DFASL index 863ee24d..cb7c3321 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.DFASL 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 index d58a88f6..8854ab9a 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-RATIONALIZE.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-REALPART.DFASL b/internal/test/LANGUAGE/AUTO/12-6-REALPART.DFASL index 859b2eb7..d949aef8 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-REALPART.DFASL 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 index 25b2565d..c66320e8 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-REALPART.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-REALPART.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-6-REM.DFASL b/internal/test/LANGUAGE/AUTO/12-6-REM.DFASL index 48f2c106..e7fa5410 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-REM.DFASL 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 index 81271e5d..c202a46c 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-REM.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-REM.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-ROUND.DFASL b/internal/test/LANGUAGE/AUTO/12-6-ROUND.DFASL index 28ebef26..0888f8fe 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-ROUND.DFASL 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 index f360a1cc..a828adbb 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-ROUND.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-ROUND.TEST @@ -1 +1,139 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.DFASL b/internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.DFASL index 3cea44d2..2e1fddfa 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.DFASL 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 index 0960caca..f282abd0 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-SCALE-FLOAT.TEST @@ -1 +1,59 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.DFASL b/internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.DFASL index 28b199e4..246004f8 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.DFASL 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 index cdd5f735..d4f76a30 100644 --- a/internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.TEST +++ b/internal/test/LANGUAGE/AUTO/12-6-TRUNCATE.TEST @@ -1 +1,139 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-ASH.DFASL b/internal/test/LANGUAGE/AUTO/12-7-ASH.DFASL index 96059e25..b16b6357 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-ASH.DFASL 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 index 03564f3e..9ad07759 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-ASH.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-ASH.TEST @@ -1 +1,60 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-BOOLE.DFASL b/internal/test/LANGUAGE/AUTO/12-7-BOOLE.DFASL index ce2efeda..ca82811f 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-BOOLE.DFASL 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 index 18eed64a..f78f1936 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-BOOLE.TEST 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 index d75fa05a..945f71cb 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-INTEGER-LENGTH.DFASL 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 index 68be6c66..50d86f9d 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-INTEGER-LENGTH.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-INTEGER-LENGTH.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGAND.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGAND.DFASL index 46f2f8e2..70941b5e 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGAND.DFASL 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 index de0f4e44..f2c0ac01 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGAND.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGAND.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.DFASL index 9c2eebf5..2ad3572c 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.DFASL 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 index 1f06b788..aaaf2002 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC1.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.DFASL index 1a2bae27..a7e4ef77 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.DFASL 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 index a7510021..936f2b46 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGANDC2.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGBITP.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGBITP.DFASL index a6e264ac..c17321cd 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGBITP.DFASL 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 index 2fb1872a..a114fd90 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGBITP.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGBITP.TEST @@ -1 +1,43 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.DFASL index 8d0954bb..e9e1e6ef 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.DFASL 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 index 7839abe7..3df2179d 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGCOUNT.TEST @@ -1 +1,52 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGEQV.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGEQV.DFASL index 4337e12f..5d98c972 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGEQV.DFASL 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 index 4526257d..577256df 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGEQV.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGEQV.TEST @@ -1 +1,39 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.DFASL index 619ef08f..37d7e56c 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.DFASL 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 index 6ce9b96a..c1444214 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGIOR.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGNAND.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGNAND.DFASL index 25334118..b0c6f595 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGNAND.DFASL 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 index 2407940c..55fef6e0 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGNAND.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGNAND.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.DFASL index 8adb2160..42926b8d 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.DFASL 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 index a29595c1..3cf1516d 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGNOR.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGNOT.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGNOT.DFASL index e04679d5..3678511e 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGNOT.DFASL 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 index 5ef676ff..6af6b2e7 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGNOT.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGNOT.TEST @@ -1 +1,39 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGORC1.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGORC1.DFASL index 49ebbbd3..b99f3871 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGORC1.DFASL 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 index c45a5f9d..6123808e 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGORC1.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGORC1.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGORC2.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGORC2.DFASL index 4c730c3f..5a8b89ae 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGORC2.DFASL 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 index 6ec7ba6f..4a18ebf7 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGORC2.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGORC2.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGTEST.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGTEST.DFASL index fd316cb1..a6f2eb14 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGTEST.DFASL 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 index 6e5e5322..8a1038c7 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGTEST.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGTEST.TEST @@ -1 +1,40 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.DFASL b/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.DFASL index e0ac9086..59efdcbc 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.DFASL 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 index ebf980c0..403a0ca7 100644 --- a/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.TEST +++ b/internal/test/LANGUAGE/AUTO/12-7-LOGXOR.TEST @@ -1 +1,36 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.DFASL b/internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.DFASL index 5ccd5880..b1675a22 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.DFASL 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 index 9b76c040..303f50f9 100644 --- a/internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.TEST +++ b/internal/test/LANGUAGE/AUTO/12-8-BYTE-POSITION.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.DFASL b/internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.DFASL index fe485a64..1acb1e59 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.DFASL 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 index 1e9e2800..a1b09339 100644 --- a/internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.TEST +++ b/internal/test/LANGUAGE/AUTO/12-8-BYTE-SIZE.TEST @@ -1 +1,49 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-8-BYTE.DFASL b/internal/test/LANGUAGE/AUTO/12-8-BYTE.DFASL index da67d003..954bcbfa 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-8-BYTE.DFASL 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 index c0b37625..8b6abf46 100644 --- a/internal/test/LANGUAGE/AUTO/12-8-BYTE.TEST +++ b/internal/test/LANGUAGE/AUTO/12-8-BYTE.TEST @@ -1 +1,54 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.DFASL b/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.DFASL index 31f50c26..2370dd43 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.DFASL 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 index 896b530f..4424d376 100644 --- a/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.TEST +++ b/internal/test/LANGUAGE/AUTO/12-8-DEPOSIT-FIELD.TEST @@ -1 +1,60 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-8-DPB.DFASL b/internal/test/LANGUAGE/AUTO/12-8-DPB.DFASL index fed7ff8d..794ebcdb 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-8-DPB.DFASL 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 index 7249888e..b8a47628 100644 --- a/internal/test/LANGUAGE/AUTO/12-8-DPB.TEST +++ b/internal/test/LANGUAGE/AUTO/12-8-DPB.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.DFASL b/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.DFASL index b4ef2a98..3273a96a 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.DFASL 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 index d4585aaf..d67ccc67 100644 --- a/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.TEST +++ b/internal/test/LANGUAGE/AUTO/12-8-LDB-TEST.TEST @@ -1 +1,44 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-8-LDB.DFASL b/internal/test/LANGUAGE/AUTO/12-8-LDB.DFASL index 957524c6..65fd663d 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-8-LDB.DFASL 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 index 319c5d00..e006568a 100644 --- a/internal/test/LANGUAGE/AUTO/12-8-LDB.TEST +++ b/internal/test/LANGUAGE/AUTO/12-8-LDB.TEST @@ -1 +1,45 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.DFASL b/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.DFASL index fab175e1..ed4f0dd7 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.DFASL 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 index 0861ca6f..6349ce22 100644 --- a/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.TEST +++ b/internal/test/LANGUAGE/AUTO/12-8-MASK-FIELD.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.DFASL b/internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.DFASL index 9ee211fa..41a79273 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.DFASL 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 index 52fe7bf1..ef5d86ae 100644 --- a/internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.TEST +++ b/internal/test/LANGUAGE/AUTO/12-9-MAKE-RANDOM-STATE.TEST @@ -1 +1,50 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.DFASL b/internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.DFASL index 11ca6a9d..a6da667f 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.DFASL 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 index 05f7a3e0..67d793a4 100644 --- a/internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.TEST +++ b/internal/test/LANGUAGE/AUTO/12-9-RANDOM-STATE-P.TEST @@ -1 +1,45 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/12-9-RANDOM.DFASL b/internal/test/LANGUAGE/AUTO/12-9-RANDOM.DFASL index f0da6bfd..185f83ae 100644 Binary files a/internal/test/LANGUAGE/AUTO/12-9-RANDOM.DFASL 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 index 8f0cf36b..8ec81d34 100644 --- a/internal/test/LANGUAGE/AUTO/12-9-RANDOM.TEST +++ b/internal/test/LANGUAGE/AUTO/12-9-RANDOM.TEST @@ -1 +1,84 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.DFASL b/internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.DFASL index 6c3868e5..493e3feb 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.DFASL 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 index 6ba9f51f..491efbde 100644 --- a/internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.TEST +++ b/internal/test/LANGUAGE/AUTO/13-1-CHARACTERATTRIBUTES.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.DFASL index 1c17bc96..b0ce064a 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.DFASL 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 index 0fb11db3..bcf3e6a8 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-ALPHA-CHAR-P.TEST @@ -1 +1,42 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.DFASL index 03f20fe7..0af646e2 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.DFASL 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 index 5b30e9bc..47b9d504 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-ALPHANUMERIC-P.TEST @@ -1 +1,12 @@ -;;; 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 +;;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.DFASL index 7460aa14..c0ef6dba 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.DFASL 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 index 0700beb3..c6bb41a1 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-BOTH-CASE-P.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.DFASL index ee9d8667..186ebe7e 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.DFASL 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 index 24d1d0b1..30cfb00c 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-EQUAL.TEST @@ -1 +1,60 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.DFASL index 0af83b52..a2080e15 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.DFASL 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 index 2bac3b1c..19040c02 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GE.TEST @@ -1 +1,66 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.DFASL index 004d2407..d93efe6f 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.DFASL 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 index dd4ebb16..a69cc90c 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GREATERP.TEST @@ -1 +1,63 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.DFASL index 61e24482..e2436d8b 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.DFASL 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 index bb4015fe..2efaad76 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-GT.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.DFASL index fffa1b05..8f7e78de 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.DFASL 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 index 8e96b430..bd757409 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LE.TEST @@ -1 +1,66 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.DFASL index 4ff95024..bc0a1eef 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.DFASL 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 index 84faa429..1a7617c5 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LESSP.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.DFASL index 518f8fb7..c5b03f47 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.DFASL 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 index af782908..36bf0cee 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHAR-LT.TEST 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 index 985e335e..84496cf1 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-EQUAL.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-EQUAL.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.DFASL index 4d8353bc..a98bf402 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.DFASL 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 index ee495066..90689e76 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-GREATERP.TEST @@ -1 +1,70 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.DFASL index c54248ef..a9562549 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.DFASL 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 index 05d2709c..0ee068f0 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAR-NOT-LESSP.TEST @@ -1 +1,71 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.DFASL index 9afb4d4b..64a7b32b 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.DFASL 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 index 046f6742..c1d9033d 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-CHAREQ.TEST @@ -1 +1,51 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.DFASL b/internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.DFASL index b5f19e2b..bf02dd21 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.DFASL 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 index 34e231f9..b1445883 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-CHARNEQ.TEST @@ -1 +1,48 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.DFASL index fd9cb597..00f66e35 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.DFASL 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 index 4e55389a..348ba5fc 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-DIGIT-CHAR-P.TEST @@ -1 +1,97 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.DFASL index 09672706..837b8b45 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.DFASL 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 index c0c7c8e0..b182fe4f 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-GRAPHIC-CHAR-P.TEST @@ -1 +1,33 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.DFASL index d44f218c..444297a0 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.DFASL 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 index 3f6309a2..ce8f9671 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-LOWER-CASE-P.TEST @@ -1 +1,50 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.DFASL index 2fe40eb4..0b684ca9 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.DFASL 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 index a2fbb065..4d5fe93c 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-STANDARD-CHAR-P.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.DFASL index 4883752b..9d7d13a6 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.DFASL 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 index 98491d60..fe3a05a6 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-STRING-CHAR-P.TEST @@ -1 +1,30 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.DFASL b/internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.DFASL index c7e6f071..604a7c58 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.DFASL 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 index 9e3cee26..f9b7bc8e 100644 --- a/internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.TEST +++ b/internal/test/LANGUAGE/AUTO/13-2-UPPER-CASE-P.TEST @@ -1 +1,51 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.DFASL b/internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.DFASL index 08ec313d..162c730a 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.DFASL 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 index 68b2f87b..35f57e50 100644 --- a/internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.TEST +++ b/internal/test/LANGUAGE/AUTO/13-3-CHAR-BITS.TEST @@ -1 +1,14 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.DFASL b/internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.DFASL index cd743c45..9a3f5433 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.DFASL 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 index b9695335..6e3bea2a 100644 --- a/internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.TEST +++ b/internal/test/LANGUAGE/AUTO/13-3-CHAR-CODE.TEST @@ -1 +1,14 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.DFASL b/internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.DFASL index 9c5db677..c94f2de7 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.DFASL 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 index 1fecd176..fa5f4d3c 100644 --- a/internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.TEST +++ b/internal/test/LANGUAGE/AUTO/13-3-CHAR-FONT.TEST @@ -1 +1,12 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.DFASL index e2b1f7f3..bb3524d0 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.DFASL 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 index 54459050..daff5a69 100644 --- a/internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.TEST +++ b/internal/test/LANGUAGE/AUTO/13-3-CODE-CHAR.TEST @@ -1 +1,12 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.DFASL index 53298896..a5554531 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.DFASL 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 index 75c49c63..f7c3292c 100644 --- a/internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.TEST +++ b/internal/test/LANGUAGE/AUTO/13-3-MAKE-CHAR.TEST @@ -1 +1,12 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.DFASL b/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.DFASL index 17376176..76cd2d8c 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.DFASL 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 index 3b12e93b..16bf5bdb 100644 --- a/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.TEST +++ b/internal/test/LANGUAGE/AUTO/13-4-CHAR-DOWNCASE.TEST @@ -1 +1,43 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.DFASL b/internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.DFASL index 30fed284..b09334d5 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.DFASL 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 index c02df2ee..4b871eda 100644 --- a/internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.TEST +++ b/internal/test/LANGUAGE/AUTO/13-4-CHAR-INT.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.DFASL b/internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.DFASL index 673ff432..6ec79c02 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.DFASL 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 index 402a040e..1d2dcfef 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-4-CHAR-NAME.TEST 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 index b602c632..98f3d3cc 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.DFASL 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 index d7e69c5b..04359293 100644 --- a/internal/test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.TEST +++ b/internal/test/LANGUAGE/AUTO/13-4-CHAR-UPCASE.TEST @@ -1 +1,44 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-4-CHARACTER.DFASL b/internal/test/LANGUAGE/AUTO/13-4-CHARACTER.DFASL index bfa3a3f3..24533be1 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-4-CHARACTER.DFASL 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 index c8557934..7294ddcd 100644 --- a/internal/test/LANGUAGE/AUTO/13-4-CHARACTER.TEST +++ b/internal/test/LANGUAGE/AUTO/13-4-CHARACTER.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.DFASL index c52b48f7..57e1d83d 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.DFASL 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 index 0c2d5284..9bbd9905 100644 --- a/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.TEST +++ b/internal/test/LANGUAGE/AUTO/13-4-DIGIT-CHAR.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.DFASL index 2c13d0e5..bc6b6c72 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.DFASL 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 index 3d8b8ca8..cd809073 100644 --- a/internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.TEST +++ b/internal/test/LANGUAGE/AUTO/13-4-INT-CHAR.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.DFASL index b270db6f..8f9847e7 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.DFASL 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 index f68dacbf..8810bcd5 100644 --- a/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.TEST +++ b/internal/test/LANGUAGE/AUTO/13-4-NAME-CHAR.TEST @@ -1 +1,34 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.DFASL b/internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.DFASL index 5281db2d..f394cd6c 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.DFASL 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 index 31e39e3f..c8257bc5 100644 --- a/internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.TEST +++ b/internal/test/LANGUAGE/AUTO/13-5-CHAR-BIT.TEST @@ -1 +1,40 @@ -;; 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 +;; 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 index 1fe2e865..333b56fe 100644 Binary files a/internal/test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.DFASL 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 index d8c11c42..dc4cf42f 100644 --- a/internal/test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.TEST +++ b/internal/test/LANGUAGE/AUTO/13-5-SET-CHAR-BIT.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.DFASL b/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.DFASL index ae17143b..c122a12f 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.DFASL 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 index e140b9fa..775328c4 100644 --- a/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.TEST +++ b/internal/test/LANGUAGE/AUTO/14-1-COPY-SEQ.TEST @@ -1 +1,42 @@ -;; 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 +;; 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 index e965aa7c..ef0e9ff6 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-1-ELT.DFASL 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 index 51ae7a5c..9e0d70af 100644 --- a/internal/test/LANGUAGE/AUTO/14-1-ELT.TEST +++ b/internal/test/LANGUAGE/AUTO/14-1-ELT.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 index bdc81e2f..b6e5be8f 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-1-LENGTH.DFASL 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 index 898c347c..a5f54e2c 100644 --- a/internal/test/LANGUAGE/AUTO/14-1-LENGTH.TEST +++ b/internal/test/LANGUAGE/AUTO/14-1-LENGTH.TEST @@ -1 +1,56 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.DFASL b/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.DFASL index d3b90b60..3a9dcf24 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.DFASL 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 index abd1b5b3..6a830be7 100644 --- a/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.TEST +++ b/internal/test/LANGUAGE/AUTO/14-1-MAKE-SEQUENCE.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 index 3ffc5f5e..a2a0a438 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-1-NREVERSE.DFASL 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 index 75aa0b76..82670eb4 100644 --- a/internal/test/LANGUAGE/AUTO/14-1-NREVERSE.TEST +++ b/internal/test/LANGUAGE/AUTO/14-1-NREVERSE.TEST @@ -1 +1,70 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/14-1-REVERSE.DFASL b/internal/test/LANGUAGE/AUTO/14-1-REVERSE.DFASL index 7df65acf..26b9e150 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-1-REVERSE.DFASL 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 index 9498370a..30514695 100644 --- a/internal/test/LANGUAGE/AUTO/14-1-REVERSE.TEST +++ b/internal/test/LANGUAGE/AUTO/14-1-REVERSE.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.DFASL b/internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.DFASL index d3673a22..45285ad7 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.DFASL 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 index 702c210f..7d2041e4 100644 --- a/internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.TEST +++ b/internal/test/LANGUAGE/AUTO/14-1-SUBSEQ.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.DFASL b/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.DFASL index 08352fa3..d2378299 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.DFASL 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 index 46c369b2..7b7941f0 100644 --- a/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.TEST +++ b/internal/test/LANGUAGE/AUTO/14-2-CONCATENATE.TEST @@ -1 +1,102 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/14-2-EVERY.DFASL b/internal/test/LANGUAGE/AUTO/14-2-EVERY.DFASL index 2bb6ef00..3637c0d1 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-2-EVERY.DFASL 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 index e6aada0e..5caf49a4 100644 --- a/internal/test/LANGUAGE/AUTO/14-2-EVERY.TEST +++ b/internal/test/LANGUAGE/AUTO/14-2-EVERY.TEST @@ -1 +1,172 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/14-2-MAP.DFASL b/internal/test/LANGUAGE/AUTO/14-2-MAP.DFASL index 61fe2602..bc3c25c2 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-2-MAP.DFASL 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 index 14a6add4..ff494b93 100644 --- a/internal/test/LANGUAGE/AUTO/14-2-MAP.TEST +++ b/internal/test/LANGUAGE/AUTO/14-2-MAP.TEST @@ -1 +1,98 @@ -;; 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 +;; 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 + + + + + + + + + + + diff --git a/internal/test/LANGUAGE/AUTO/14-2-NOTANY.DFASL b/internal/test/LANGUAGE/AUTO/14-2-NOTANY.DFASL index 91a6e80c..2a0c93e7 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-2-NOTANY.DFASL 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 index 1912c143..91c80e39 100644 --- a/internal/test/LANGUAGE/AUTO/14-2-NOTANY.TEST +++ b/internal/test/LANGUAGE/AUTO/14-2-NOTANY.TEST @@ -1 +1,174 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.DFASL b/internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.DFASL index 2345bddc..855a8325 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.DFASL 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 index 06096cd3..9c470f44 100644 --- a/internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.TEST +++ b/internal/test/LANGUAGE/AUTO/14-2-NOTEVERY.TEST @@ -1 +1,171 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/14-2-REDUCE.DFASL b/internal/test/LANGUAGE/AUTO/14-2-REDUCE.DFASL index 296f84e8..92e364a6 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-2-REDUCE.DFASL 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 index 3402dd19..584f4cb8 100644 --- a/internal/test/LANGUAGE/AUTO/14-2-REDUCE.TEST +++ b/internal/test/LANGUAGE/AUTO/14-2-REDUCE.TEST @@ -1 +1,128 @@ -;; 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 +;; 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 + + + + + diff --git a/internal/test/LANGUAGE/AUTO/14-2-SOME.DFASL b/internal/test/LANGUAGE/AUTO/14-2-SOME.DFASL index 77aa73b1..81e23d2b 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-2-SOME.DFASL 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 index 2170078f..39147005 100644 --- a/internal/test/LANGUAGE/AUTO/14-2-SOME.TEST +++ b/internal/test/LANGUAGE/AUTO/14-2-SOME.TEST @@ -1 +1,165 @@ -;; 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 +;; 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 index 8cc60703..9c2870e8 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.DFASL 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 index 8adae10f..6e466a7b 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-DELETE-DUPLICATES.TEST @@ -1 +1,98 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.DFASL index 3cbc8a1e..6b95a83d 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.DFASL 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 index 0a7b32a2..a7ba8d25 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF-NOT.TEST @@ -1 +1,110 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.DFASL index 94bb6452..9aa0e646 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.DFASL 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 index 970cc9cd..1d45e967 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-DELETE-IF.TEST 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 index 4e0a3089..5f15952e 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-DELETE.DFASL 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 index e121b4fe..fb0fbb37 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-DELETE.TEST 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 index 5ff39112..9033a7ca 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-FILL.DFASL 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 index 52b9ae32..8248dbeb 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-FILL.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-FILL.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 index 0d298644..719ef0fe 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.DFASL 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 index 8b70b167..1a3a6a46 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-FIND-IF-NOT.TEST @@ -1 +1,89 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/14-3-FIND-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-FIND-IF.DFASL index a2f7c4b9..bb7525d8 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-FIND-IF.DFASL 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 index 304d86da..cdd2de9f 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-FIND-IF.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-FIND-IF.TEST @@ -1 +1,94 @@ -;; 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 +;; 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 + + + + + diff --git a/internal/test/LANGUAGE/AUTO/14-3-FIND.DFASL b/internal/test/LANGUAGE/AUTO/14-3-FIND.DFASL index 8f806d47..2e8f2aab 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-FIND.DFASL 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 index a0cc9b79..e773fa8e 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-FIND.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-FIND.TEST @@ -1 +1,99 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.DFASL index 6e5737c1..7a83127d 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.DFASL 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 index b0ece777..ecc6b93a 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF-NOT.TEST @@ -1 +1,119 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.DFASL index 6c69f9ae..8b1d245d 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.DFASL 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 index 21c5bed5..24323cfe 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE-IF.TEST @@ -1 +1,117 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.DFASL b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.DFASL index 83ed1a49..3aec7846 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.DFASL 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 index d513af5c..2b8fef19 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-NSUBSTITUTE.TEST @@ -1 +1,113 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.DFASL index 13ed8013..aa9ad85f 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.DFASL 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 index 3d02b322..615f1f0e 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF-NOT.TEST @@ -1 +1,118 @@ -;; 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 +;; 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 + + + + + + diff --git a/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.DFASL index 9c87410c..40107c18 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.DFASL 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 index c83cabb7..7ecdd7ee 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-POSITION-IF.TEST @@ -1 +1,114 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/14-3-POSITION.DFASL b/internal/test/LANGUAGE/AUTO/14-3-POSITION.DFASL index adaca5a2..7f4d4b22 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-POSITION.DFASL 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 index 13a09b16..d3faa709 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-POSITION.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-POSITION.TEST @@ -1 +1,120 @@ -;; 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 +;; 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 + + + + + diff --git a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.DFASL b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.DFASL index 893d50d6..c0ac6caa 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.DFASL 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 index c07cd640..45b35b2a 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-DUPLICATES.TEST @@ -1 +1,107 @@ -;; 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 +;; 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 + + + + + + diff --git a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.DFASL index 35a1777e..f62a7c24 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.DFASL 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 index 2f3d448f..c58212dc 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF-NOT.TEST @@ -1 +1,116 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.DFASL index 84483dd3..b8643edc 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.DFASL 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 index d01873f3..bdfd7a5a 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-REMOVE-IF.TEST @@ -1 +1,92 @@ -;; 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 +;; 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 index b311a9a2..19ad2e65 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-REMOVE.DFASL 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 index f3819eb8..309482ad 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-REMOVE.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-REMOVE.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 index 7f6844c2..d05c1b57 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-REPLACE.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-REPLACE.TEST @@ -1 +1,93 @@ -;; 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 +;; 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 index 3fe3649e..d8e7e225 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.DFASL 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 index 78f01f1c..6ac75aa2 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF-NOT.TEST @@ -1 +1,124 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.DFASL index 0e383f7f..a85c1ef0 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.DFASL 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 index 322124da..5f417389 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE-IF.TEST @@ -1 +1,125 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.DFASL b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.DFASL index b472e39f..e450681e 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.DFASL 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 index e287df81..02b83568 100644 --- a/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.TEST +++ b/internal/test/LANGUAGE/AUTO/14-3-SUBSTITUTE.TEST @@ -1 +1,115 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.DFASL index fb21e499..f7721acb 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.DFASL 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 index dbf5f110..ddc6bc72 100644 --- a/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF-NOT.TEST @@ -1 +1,113 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF.DFASL b/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF.DFASL index f8f63656..55a79904 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-4-COUNT-IF.DFASL 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 index 0b107f52..49cd45c4 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-4-COUNT.DFASL 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 index d08abd12..60ecb60b 100644 --- a/internal/test/LANGUAGE/AUTO/14-4-COUNT.TEST +++ b/internal/test/LANGUAGE/AUTO/14-4-COUNT.TEST @@ -1 +1,123 @@ -;; 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 +;; 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 + + + + + diff --git a/internal/test/LANGUAGE/AUTO/14-4-MISMATCH.DFASL b/internal/test/LANGUAGE/AUTO/14-4-MISMATCH.DFASL index 8b06e578..ffb3c5fb 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-4-MISMATCH.DFASL 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 index 60398a9c..a9715e36 100644 --- a/internal/test/LANGUAGE/AUTO/14-4-MISMATCH.TEST +++ b/internal/test/LANGUAGE/AUTO/14-4-MISMATCH.TEST @@ -1 +1,94 @@ -;; 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 +;; 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 index f090eb3e..ff7e231c 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-5-MERGE.DFASL 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 index 99fa3c5b..fd41d2a4 100644 --- a/internal/test/LANGUAGE/AUTO/14-5-MERGE.TEST +++ b/internal/test/LANGUAGE/AUTO/14-5-MERGE.TEST @@ -1 +1,107 @@ -;; 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 +;; 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 index 32004db0..0c11b04e 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-5-SORT.DFASL 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 index 56d3bdfb..d65a5ac9 100644 --- a/internal/test/LANGUAGE/AUTO/14-5-SORT.TEST +++ b/internal/test/LANGUAGE/AUTO/14-5-SORT.TEST @@ -1 +1,156 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.DFASL b/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.DFASL index 785ac9f0..91dd26f0 100644 Binary files a/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.DFASL 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 index d7ed26dc..e52d2b11 100644 --- a/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.TEST +++ b/internal/test/LANGUAGE/AUTO/14-5-STABLE-SORT.TEST @@ -1 +1,98 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAAAAR.DFASL index 2f483266..02bfe946 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CAAAAR.DFASL 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 index 2db29870..e1708fed 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CAAAAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CAAAAR.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAAADR.DFASL index ddc25ddb..0753b74f 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CAAADR.DFASL 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 index 26a19832..ad2462aa 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CAAADR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CAAADR.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAAAR.DFASL index 9ecac730..c942deeb 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CAAAR.DFASL 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 index 17819440..d1cabcf9 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CAAAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CAAAR.TEST @@ -1 +1,76 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAADAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAADAR.DFASL index 59157e15..38abdc9e 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CAADAR.DFASL 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 index 9a6226ee..d36534d3 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CAADAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CAADAR.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAADDR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAADDR.DFASL index 2b69dbc1..84784c6a 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CAADDR.DFASL 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 index c00f9de0..303a6d9a 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CAADDR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CAADDR.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAADR.DFASL index 70078129..8f456c8a 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CAADR.DFASL 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 index 92712bd2..dce96c67 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CAADR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CAADR.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAAR.DFASL index 82e127bc..38a7356d 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CAAR.DFASL 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 index d45459f5..1e3b213a 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CAAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CAAR.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 index 2fe9cd5d..7381f0fb 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CADAA.DFASL 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 index 06be23f3..fba61714 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CADAA.TEST 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 index a9bb5f4c..e5452d38 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CADAAR.TEST 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 index 79c60435..197d350a 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CADADR.DFASL 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 index a886ba3f..fc7f79de 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CADADR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CADADR.TEST @@ -1 +1,66 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADAR.DFASL index 36270493..29e25b64 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CADAR.DFASL 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 index fd81655c..d20f5a7d 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CADAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CADAR.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADDAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADDAR.DFASL index a79e5440..ed74645d 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CADDAR.DFASL 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 index 3d678e30..8bbae889 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CADDAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CADDAR.TEST @@ -1 +1,83 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.DFASL index e3be0ee9..1e3ea00e 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.DFASL 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 index 28e2c183..e06988b1 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CADDDR-AND-FOURTH.TEST @@ -1 +1,110 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.DFASL index 6258cff0..9768c1ca 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.DFASL 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 index 1916213f..02cdea7c 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CADDR-AND-THIRD.TEST @@ -1 +1,81 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.DFASL index fb67df9d..5f199b7c 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.DFASL 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 index 9a047fe4..09098044 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CADR-AND-SECOND.TEST @@ -1 +1,91 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.DFASL index 07dffbd6..94612f6e 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.DFASL 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 index 1b674a6e..f6576869 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CAR-AND-FIRST.TEST @@ -1 +1,106 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDAAAR.DFASL index 10945608..53caf882 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDAAAR.DFASL 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 index 03373f82..e23b7f29 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDAAAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDAAAR.TEST @@ -1 +1,75 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDAADR.DFASL index d5ecead4..fb353f83 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDAADR.DFASL 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 index c9f4d558..c8543990 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDAADR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDAADR.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDAAR.DFASL index b3292959..9c6658c7 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDAAR.DFASL 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 index 3bcdfb95..7b3c95e3 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDAAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDAAR.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDADAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDADAR.DFASL index 61bcf3d3..d4c2326c 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDADAR.DFASL 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 index 972abdf6..3d51c31a 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDADAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDADAR.TEST @@ -1 +1,81 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDADDR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDADDR.DFASL index 811d414d..d71c0c56 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDADDR.DFASL 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 index 0423da6c..91d3316e 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDADDR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDADDR.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDADR.DFASL index 30251c7f..402439af 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDADR.DFASL 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 index 90abcdcb..5ef3b471 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDADR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDADR.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDAR.DFASL index d3d29282..416b6b3c 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDAR.DFASL 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 index 4441d256..251ef2a0 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDAR.TEST @@ -1 +1,82 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDAAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDAAR.DFASL index c4b575c1..da6483a6 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDDAAR.DFASL 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 index b7c4faa1..5bb62f30 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDDAAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDAAR.TEST @@ -1 +1,82 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDADR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDADR.DFASL index aebb80ca..30a06de0 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDDADR.DFASL 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 index 985e174d..8525db8a 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDDADR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDADR.TEST @@ -1 +1,81 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDAR.DFASL index c1a41d87..9a977772 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDDAR.DFASL 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 index cd616524..45ac1bd2 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDDAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDAR.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDDAR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDDAR.DFASL index 94ed026d..b2f27c78 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDDDAR.DFASL 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 index ed7b0b40..8f5a1011 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDDDAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDDAR.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDDDR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDDDR.DFASL index 12022832..1481a503 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDDDDR.DFASL 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 index f31feeaf..8367bd55 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDDDDR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDDDR.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDDR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDDR.DFASL index b254f2b2..c3f055f6 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDDDR.DFASL 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 index aaccb9ce..d71970de 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDDDR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDDR.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDDR.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDDR.DFASL index 9c734942..23e84b13 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDDR.DFASL 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 index 453f5ae4..ad00e3fa 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDDR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDDR.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.DFASL index cd3c2746..ce9d1a89 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.DFASL 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 index 55226dff..e72a30c9 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CDR-AND-REST.TEST @@ -1 +1,99 @@ -;; 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 +;; 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 + + + + + diff --git a/internal/test/LANGUAGE/AUTO/15-1-CONS.DFASL b/internal/test/LANGUAGE/AUTO/15-1-CONS.DFASL index 3e912be7..9fe83c3c 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-CONS.DFASL 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 index fdc8b63a..a4a28b19 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-CONS.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-CONS.TEST @@ -1 +1,70 @@ -;; 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 +;; 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 index cbd39569..a5ba6c57 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-1-TREE-EQUAL.DFASL 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 index e2d9d5af..79f887fb 100644 --- a/internal/test/LANGUAGE/AUTO/15-1-TREE-EQUAL.TEST +++ b/internal/test/LANGUAGE/AUTO/15-1-TREE-EQUAL.TEST @@ -1 +1,136 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-APPEND.DFASL b/internal/test/LANGUAGE/AUTO/15-2-APPEND.DFASL index b131ffc7..6ae45755 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-APPEND.DFASL 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 index d5d9ff6c..0032e705 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-APPEND.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-APPEND.TEST @@ -1 +1,125 @@ -;; 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 +;; 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 index a1f1295f..89b01571 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-BUTLAST.DFASL 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 index 64972995..6ee08d69 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-BUTLAST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-BUTLAST.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.DFASL index 6a20c9c8..471ba6f8 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.DFASL 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 index cde32c74..6d60b28a 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-COPY-ALIST.TEST @@ -1 +1,149 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.DFASL index 0799dcbf..32514ba5 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.DFASL 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 index 3322b2a7..ab9bcfab 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-COPY-LIST.TEST @@ -1 +1,111 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.DFASL b/internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.DFASL index 693e62e3..e39dad97 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.DFASL 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 index 8266135c..d7d5a55d 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-COPY-TREE.TEST @@ -1 +1,205 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.DFASL index 811b59c5..09320077 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.DFASL 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 index 6fadd61c..bf24f8a8 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-EIGHTH.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-ENDP.DFASL b/internal/test/LANGUAGE/AUTO/15-2-ENDP.DFASL index 70daa331..0ad04fcc 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-ENDP.DFASL 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 index db9ef8a2..63fade9d 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-ENDP.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-ENDP.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-FIFTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-FIFTH.DFASL index 6018e168..ccdd2b86 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-FIFTH.DFASL 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 index bb6a08f6..236ae2e7 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-FIFTH.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-FIFTH.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 index 061c0e61..3c1aed00 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-FIRST.DFASL 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 index 06dfcebe..ec755136 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-FIRST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-FIRST.TEST @@ -1 +1,45 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-FOURTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-FOURTH.DFASL index 15ebd05e..874fdf13 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-FOURTH.DFASL 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 index a46241b8..4d1910f4 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-FOURTH.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-FOURTH.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-LAST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LAST.DFASL index 83a50e00..9bb81343 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-LAST.DFASL 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 index 1070043d..43c2d19d 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-LAST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-LAST.TEST @@ -1 +1,63 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-LDIFF.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LDIFF.DFASL index 24ff19c7..d9728a35 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-LDIFF.DFASL 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 index 39fdab24..856461c6 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-LDIFF.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-LDIFF.TEST @@ -1 +1,95 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.DFASL index 3c7f9b64..c263c75b 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.DFASL 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 index 4c9cb4ae..ced3671c 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-LIST-LENGTH.TEST @@ -1 +1,107 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-LIST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LIST.DFASL index 278b2db7..7e0ce613 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-LIST.DFASL 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 index 9fded9c0..96a351e0 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-LIST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-LIST.TEST @@ -1 +1,94 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.DFASL b/internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.DFASL index 62c279a7..730c72d9 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.DFASL 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 index 0d749cc5..d2f86ce8 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-LISTSTAR.TEST @@ -1 +1,91 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.DFASL index a8a1cc2c..c97b57d8 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.DFASL 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 index d3f6f51e..4fdc39da 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-MAKE-LIST.TEST @@ -1 +1,87 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.DFASL index cfa91506..57b9bd4d 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.DFASL 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 index d39ec692..be77dc05 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-NBUTLAST.TEST @@ -1 +1,120 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-NCONC.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NCONC.DFASL index 48332cb2..863ba763 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-NCONC.DFASL 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 index 27d75656..7b0ff9ba 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-NCONC.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-NCONC.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 index 63b52607..c135e5d0 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-NINTH.DFASL 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 index 910353f4..d6f196ac 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-NINTH.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-NINTH.TEST @@ -1 +1,110 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-NRECONC.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NRECONC.DFASL index d2c53b6e..be1daab3 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-NRECONC.DFASL 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 index e23d2263..a8994f79 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-NRECONC.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-NRECONC.TEST @@ -1 +1,72 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-NTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-NTH.DFASL index 94b9fbeb..2c4369cc 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-NTH.DFASL 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 index 5446f229..ed67b710 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-NTH.TEST 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 index fc4147d3..b6f785fc 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-NTHCDR.DFASL 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 index 86d02e65..d05fd8cd 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-NTHCDR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-NTHCDR.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-POP.DFASL b/internal/test/LANGUAGE/AUTO/15-2-POP.DFASL index 3ffff2ad..21ace673 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-POP.DFASL 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 index 79da7ff4..a2004194 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-POP.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-POP.TEST @@ -1 +1,74 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-PUSH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-PUSH.DFASL index 28997814..7e0ada9b 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-PUSH.DFASL 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 index 544f85db..29753275 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-PUSH.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-PUSH.TEST @@ -1 +1,97 @@ -;; 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 +;; 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 index 9fa449b0..99ceade1 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.DFASL 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 index 6c799b68..54f31ac7 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-PUSHNEW.TEST @@ -1 +1,97 @@ -;; 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 +;; 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 index 1451af98..75fa6403 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-REST.DFASL 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 index 9e8b6a2d..cb519d35 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-REST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-REST.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.DFASL b/internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.DFASL index cec96f52..df228666 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.DFASL 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 index 699a1689..2c6541f4 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-REVAPPEND.TEST @@ -1 +1,73 @@ -;; 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 +;; 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 index f0ee10ca..3a101986 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-SECOND.DFASL 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 index 663182fe..1e64f41d 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-SECOND.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-SECOND.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-SEVENTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-SEVENTH.DFASL index 322d19ff..5eed9f01 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-SEVENTH.DFASL 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 index 65935dd9..a8297ac3 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-SEVENTH.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-SEVENTH.TEST @@ -1 +1,107 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-SIXTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-SIXTH.DFASL index 4b588856..7809807f 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-SIXTH.DFASL 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 index fc9a6f47..824027b8 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-SIXTH.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-SIXTH.TEST @@ -1 +1,93 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-TENTH.DFASL b/internal/test/LANGUAGE/AUTO/15-2-TENTH.DFASL index c8779109..a13312c9 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-TENTH.DFASL 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 index eb5e02b1..3c6dd5af 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-TENTH.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-TENTH.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-2-THIRD.DFASL b/internal/test/LANGUAGE/AUTO/15-2-THIRD.DFASL index b4471332..a3a35a8c 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-2-THIRD.DFASL 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 index 35544af1..74f1ad49 100644 --- a/internal/test/LANGUAGE/AUTO/15-2-THIRD.TEST +++ b/internal/test/LANGUAGE/AUTO/15-2-THIRD.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-3-RPLACA.DFASL b/internal/test/LANGUAGE/AUTO/15-3-RPLACA.DFASL index 285a517f..7725b754 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-3-RPLACA.DFASL 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 index 498662db..fb7ec66b 100644 --- a/internal/test/LANGUAGE/AUTO/15-3-RPLACA.TEST +++ b/internal/test/LANGUAGE/AUTO/15-3-RPLACA.TEST @@ -1 +1,90 @@ -;; 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 +;; 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 index c6b9d939..751d323d 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-3-RPLACD.DFASL 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 index 108c1aec..ae672926 100644 --- a/internal/test/LANGUAGE/AUTO/15-3-RPLACD.TEST +++ b/internal/test/LANGUAGE/AUTO/15-3-RPLACD.TEST @@ -1 +1,89 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.DFASL b/internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.DFASL index 2017879c..44c1f299 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.DFASL 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 index 6f10300b..96c18567 100644 --- a/internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.TEST +++ b/internal/test/LANGUAGE/AUTO/15-4-NSUBLIS.TEST @@ -1 +1,103 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.DFASL index 5caf36f5..e0c5fb82 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.DFASL 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 index ba503349..a251e08a 100644 --- a/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF-NOT.TEST @@ -1 +1,97 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.DFASL b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.DFASL index c3b81427..ffff879d 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.DFASL 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 index a9e158bc..757d6f71 100644 --- a/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.TEST +++ b/internal/test/LANGUAGE/AUTO/15-4-NSUBST-IF.TEST @@ -1 +1,92 @@ -;; 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 +;; 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 index 8ad40d9c..2ce2d60e 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-4-NSUBST.DFASL 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 index 49f804c8..a8b64c73 100644 --- a/internal/test/LANGUAGE/AUTO/15-4-NSUBST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-4-NSUBST.TEST @@ -1 +1,115 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-4-SUBLIS.DFASL b/internal/test/LANGUAGE/AUTO/15-4-SUBLIS.DFASL index f1744803..2941c418 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-4-SUBLIS.DFASL 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 index 7822dba4..4ce4dd22 100644 --- a/internal/test/LANGUAGE/AUTO/15-4-SUBLIS.TEST +++ b/internal/test/LANGUAGE/AUTO/15-4-SUBLIS.TEST @@ -1 +1,165 @@ -;; 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 +;; 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 index 4d136c38..4be5a0d8 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.DFASL 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 index ec080eb9..fecaf46d 100644 --- a/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF-NOT.TEST @@ -1 +1,132 @@ -;; 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 +;; 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 index d1a16712..65f2b4e4 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF.DFASL 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 index bae6a2c8..2743f23d 100644 --- a/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF.TEST +++ b/internal/test/LANGUAGE/AUTO/15-4-SUBST-IF.TEST @@ -1 +1,143 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-4-SUBST.DFASL b/internal/test/LANGUAGE/AUTO/15-4-SUBST.DFASL index bb44393c..7785f185 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-4-SUBST.DFASL 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 index a89e7d9b..317703ea 100644 --- a/internal/test/LANGUAGE/AUTO/15-4-SUBST.TEST +++ b/internal/test/LANGUAGE/AUTO/15-4-SUBST.TEST @@ -1 +1,199 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-ADJOIN.DFASL b/internal/test/LANGUAGE/AUTO/15-5-ADJOIN.DFASL index 041094fb..30a6a30f 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-ADJOIN.DFASL 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 index 1ffecac0..28f3cf8c 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-ADJOIN.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-ADJOIN.TEST @@ -1 +1,102 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.DFASL b/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.DFASL index 076afc56..f3333617 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.DFASL 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 index a38e06aa..10e9b43a 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-INTERSECTION.TEST @@ -1 +1,156 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.DFASL index 7e72823e..fc1cfb22 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.DFASL 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 index a3643836..249a5d2b 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF-NOT.TEST @@ -1 +1,101 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.DFASL b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.DFASL index 39132cd0..e2161933 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.DFASL 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 index 91e6cd47..2952e1e7 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-MEMBER-IF.TEST @@ -1 +1,96 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-MEMBER.DFASL b/internal/test/LANGUAGE/AUTO/15-5-MEMBER.DFASL index e8bce7a8..dae67e28 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-MEMBER.DFASL 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 index f9c350f9..f542cd9d 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-MEMBER.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-MEMBER.TEST @@ -1 +1,116 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.DFASL b/internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.DFASL index 028f1516..13da9cb0 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.DFASL 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 index 8296be08..d8bc6812 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-NINTERSECTION.TEST @@ -1 +1,143 @@ -;; 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 +;; 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 index ea73eaec..f6cc3d62 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.DFASL 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 index f2e3cd0d..23df84a7 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-NSET-DIFFERENCE.TEST @@ -1 +1,234 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.DFASL b/internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.DFASL index 5e89174e..56a5050f 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.DFASL 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 index d82c3e71..f7fb46b3 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-NSET-EXCLUSIVE-OR.TEST @@ -1 +1,237 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/15-5-NUNION.DFASL b/internal/test/LANGUAGE/AUTO/15-5-NUNION.DFASL index 20f59342..c9058eb7 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-NUNION.DFASL 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 index f61c1bf5..23c8aeda 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-NUNION.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-NUNION.TEST @@ -1 +1,160 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.DFASL b/internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.DFASL index f5e38556..01d3ba8c 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.DFASL 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 index c5a83454..d775a8d2 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-SET-DIFFERENCE.TEST @@ -1 +1,235 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.DFASL b/internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.DFASL index cf4cb82d..2e881127 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.DFASL 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 index 25d653dc..bfdf157e 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-SET-EXCLUSIVE-OR.TEST @@ -1 +1,236 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.DFASL b/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.DFASL index 26fff79b..c0640a86 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.DFASL 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 index e5dc5abc..f3d4a478 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-SUBSETP.TEST @@ -1 +1,92 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-TAILP.DFASL b/internal/test/LANGUAGE/AUTO/15-5-TAILP.DFASL index 3e6f228e..b3de14c8 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-TAILP.DFASL 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 index 2e0cd1c1..cd334fbd 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-TAILP.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-TAILP.TEST @@ -1 +1,71 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-5-UNION.DFASL b/internal/test/LANGUAGE/AUTO/15-5-UNION.DFASL index 85bcc9db..ddac497c 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-5-UNION.DFASL 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 index 172f1a64..5b9d0105 100644 --- a/internal/test/LANGUAGE/AUTO/15-5-UNION.TEST +++ b/internal/test/LANGUAGE/AUTO/15-5-UNION.TEST @@ -1 +1,169 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-6-ACONS.DFASL b/internal/test/LANGUAGE/AUTO/15-6-ACONS.DFASL index 3ea747c5..20c78767 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-6-ACONS.DFASL 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 index 5808af45..38173222 100644 --- a/internal/test/LANGUAGE/AUTO/15-6-ACONS.TEST +++ b/internal/test/LANGUAGE/AUTO/15-6-ACONS.TEST @@ -1 +1,507 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.DFASL index 8f9a90c1..7c42692d 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.DFASL 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 index ca024c6e..cdd1ebf4 100644 --- a/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF-NOT.TEST @@ -1 +1,128 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.DFASL b/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.DFASL index 08d5bc71..db03afb2 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.DFASL 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 index 4e5c903a..f570a215 100644 --- a/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.TEST +++ b/internal/test/LANGUAGE/AUTO/15-6-ASSOC-IF.TEST @@ -1 +1,128 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-6-ASSOC.DFASL b/internal/test/LANGUAGE/AUTO/15-6-ASSOC.DFASL index 64006e24..9e8fb61f 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-6-ASSOC.DFASL 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 index a4c544e6..b7ecd130 100644 --- a/internal/test/LANGUAGE/AUTO/15-6-ASSOC.TEST +++ b/internal/test/LANGUAGE/AUTO/15-6-ASSOC.TEST @@ -1 +1,153 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.DFASL b/internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.DFASL index 57e879c7..42730c19 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.DFASL 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 index f7354cc2..d57695ea 100644 --- a/internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.TEST +++ b/internal/test/LANGUAGE/AUTO/15-6-PAIRLIS.TEST @@ -1 +1,843 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.DFASL b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.DFASL index e2c0db5b..b7bbdc18 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.DFASL 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 index af7006da..08846b9a 100644 --- a/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF-NOT.TEST @@ -1 +1,83 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.DFASL b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.DFASL index aad11bf8..903416a2 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.DFASL 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 index f937f1e9..27e163ed 100644 --- a/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.TEST +++ b/internal/test/LANGUAGE/AUTO/15-6-RASSOC-IF.TEST @@ -1 +1,82 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/15-6-RASSOC.DFASL b/internal/test/LANGUAGE/AUTO/15-6-RASSOC.DFASL index c5609923..906ec18e 100644 Binary files a/internal/test/LANGUAGE/AUTO/15-6-RASSOC.DFASL 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 index a943d7fd..59772c2a 100644 --- a/internal/test/LANGUAGE/AUTO/15-6-RASSOC.TEST +++ b/internal/test/LANGUAGE/AUTO/15-6-RASSOC.TEST @@ -1 +1,142 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/16-1-CLRHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-1-CLRHASH.DFASL index 8de3af0b..0e2cecba 100644 Binary files a/internal/test/LANGUAGE/AUTO/16-1-CLRHASH.DFASL 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 index 0bd3de14..d3eb5903 100644 --- a/internal/test/LANGUAGE/AUTO/16-1-CLRHASH.TEST +++ b/internal/test/LANGUAGE/AUTO/16-1-CLRHASH.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 index 5a3d0137..aa8859cf 100644 Binary files a/internal/test/LANGUAGE/AUTO/16-1-GETHASH.DFASL 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 index bccc0f21..165e58fa 100644 --- a/internal/test/LANGUAGE/AUTO/16-1-GETHASH.TEST +++ b/internal/test/LANGUAGE/AUTO/16-1-GETHASH.TEST @@ -1 +1,50 @@ -;; 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 +;; 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 + + + + + + + diff --git a/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.DFASL b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.DFASL index 486fef64..20618df2 100644 Binary files a/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.DFASL 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 index ec36ed7f..b3320cbd 100644 --- a/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.TEST +++ b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-COUNT.TEST @@ -1 +1,49 @@ - ;; 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 + + +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.DFASL b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.DFASL index 498bbcb8..fabac651 100644 Binary files a/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.DFASL 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 index 309a7c4b..2743b59c 100644 --- a/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.TEST +++ b/internal/test/LANGUAGE/AUTO/16-1-HASH-TABLE-P.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 + + + + + diff --git a/internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.DFASL b/internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.DFASL index d3ad9392..12218987 100644 Binary files a/internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.DFASL 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 index af990a4e..23481494 100644 --- a/internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.TEST +++ b/internal/test/LANGUAGE/AUTO/16-1-MAKE-HASH-TABLE.TEST @@ -1 +1,55 @@ -;; 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 +;; 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 + + + + + diff --git a/internal/test/LANGUAGE/AUTO/16-1-MAPHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-1-MAPHASH.DFASL index 1bb34f08..274ee8f3 100644 Binary files a/internal/test/LANGUAGE/AUTO/16-1-MAPHASH.DFASL 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 index ef3f10b9..f9d5e187 100644 --- a/internal/test/LANGUAGE/AUTO/16-1-MAPHASH.TEST +++ b/internal/test/LANGUAGE/AUTO/16-1-MAPHASH.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/16-1-REMHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-1-REMHASH.DFASL index 37b7b36b..55e25a8f 100644 Binary files a/internal/test/LANGUAGE/AUTO/16-1-REMHASH.DFASL 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 index f88d638a..7b002433 100644 --- a/internal/test/LANGUAGE/AUTO/16-1-REMHASH.TEST +++ b/internal/test/LANGUAGE/AUTO/16-1-REMHASH.TEST @@ -1 +1,48 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/16-2-SXHASH.DFASL b/internal/test/LANGUAGE/AUTO/16-2-SXHASH.DFASL index 5fb1d339..3c40eada 100644 Binary files a/internal/test/LANGUAGE/AUTO/16-2-SXHASH.DFASL 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 index 73003850..3190798e 100644 --- a/internal/test/LANGUAGE/AUTO/16-2-SXHASH.TEST +++ b/internal/test/LANGUAGE/AUTO/16-2-SXHASH.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.DFASL b/internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.DFASL index 675f7c6e..b550eea8 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.DFASL 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 index d6063c27..a8349951 100644 --- a/internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.TEST +++ b/internal/test/LANGUAGE/AUTO/17-1-MAKE-ARRAY.TEST @@ -1 +1,90 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/17-1-VECTOR.DFASL b/internal/test/LANGUAGE/AUTO/17-1-VECTOR.DFASL index d1e80647..ace97b94 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-1-VECTOR.DFASL 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 index 0e1f5758..0f56619e 100644 --- a/internal/test/LANGUAGE/AUTO/17-1-VECTOR.TEST +++ b/internal/test/LANGUAGE/AUTO/17-1-VECTOR.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 index fe350ac3..50add7a0 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-2-AREF.DFASL 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 index ffa81763..25737792 100644 --- a/internal/test/LANGUAGE/AUTO/17-2-AREF.TEST +++ b/internal/test/LANGUAGE/AUTO/17-2-AREF.TEST @@ -1 +1,84 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/17-2-SVREF.DFASL b/internal/test/LANGUAGE/AUTO/17-2-SVREF.DFASL index 0bff00f8..e2b3afec 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-2-SVREF.DFASL 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 index 83186fc2..7aca6daf 100644 --- a/internal/test/LANGUAGE/AUTO/17-2-SVREF.TEST +++ b/internal/test/LANGUAGE/AUTO/17-2-SVREF.TEST @@ -1 +1,49 @@ -;; 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 +;; 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 index 7160a5bd..8d6b964c 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-3-ADJUSTABLE-ARRAY-P.DFASL 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 index 9847736a..298e0e2e 100644 --- a/internal/test/LANGUAGE/AUTO/17-3-ADJUSTABLE-ARRAY-P.TEST +++ b/internal/test/LANGUAGE/AUTO/17-3-ADJUSTABLE-ARRAY-P.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.DFASL index a7da2773..fd5414c0 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.DFASL 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 index 79ec7a45..97a9f060 100644 --- a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.TEST +++ b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSION.TEST @@ -1 +1,49 @@ -;; 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 +;; 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 index 3f22f31a..bb24cbc4 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.DFASL 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 index c129f905..533182b0 100644 --- a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.TEST +++ b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-DIMENSIONS.TEST @@ -1 +1,40 @@ -;; 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 +;; 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 index f64e73b3..ad5cf0cf 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ELEMENT-TYPE.DFASL 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 index c7d6edc2..093676af 100644 --- a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ELEMENT-TYPE.TEST +++ b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ELEMENT-TYPE.TEST @@ -1 +1,63 @@ -;; 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 +;; 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 + + 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 index 620c9c30..8abc3ad9 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.DFASL 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 index 21f5c6d4..2cac627f 100644 --- a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.TEST +++ b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-IN-BOUNDS-P.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 index ab325979..88d2360d 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-RANK.DFASL 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 index d60245ae..7f6dd83b 100644 --- a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-RANK.TEST +++ b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-RANK.TEST @@ -1 +1,35 @@ -;; 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 +;; 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 + + 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 index 9e3211ef..a6334a6b 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.DFASL 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 index f4826b1f..360cdabf 100644 --- a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.TEST +++ b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-ROW-MAJOR-INDEX.TEST @@ -1 +1,57 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.DFASL b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.DFASL index 0101ba7d..c158b2da 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.DFASL 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 index 1658f86f..56394101 100644 --- a/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.TEST +++ b/internal/test/LANGUAGE/AUTO/17-3-ARRAY-TOTAL-SIZE.TEST @@ -1 +1,42 @@ -;; 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 +;; 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 index 019b065d..038c2a49 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT-AND.DFASL 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 index bed57802..37149a0c 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT-AND.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-AND.TEST @@ -1 +1,56 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.DFASL index 5788b48f..5e8d3c23 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.DFASL 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 index b7df0b8c..b21a7d98 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC1.TEST @@ -1 +1,59 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.DFASL index 258b779c..5a067c82 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.DFASL 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 index 5db40ae8..8debd803 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-ANDC2.TEST @@ -1 +1,60 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.DFASL index 9ea46e53..51192295 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.DFASL 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 index 53e3384f..564ee646 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-EQV.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.DFASL index 50cbd1c7..262edbf9 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.DFASL 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 index 63f97d35..1e67b97c 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-IOR.TEST @@ -1 +1,57 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.DFASL index 97c5aa7f..5316b067 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.DFASL 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 index c110bcfb..9eb81b2e 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-NAND.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.DFASL index 348e3021..98d70304 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.DFASL 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 index 8af6e987..20c1e8c1 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-NOR.TEST @@ -1 +1,57 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.DFASL index a72ccd2b..e0a85e10 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.DFASL 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 index a7888845..7a3c40f3 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-NOT.TEST @@ -1 +1,55 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.DFASL index 676f4ac6..9c1bbd9f 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.DFASL 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 index 8b3efc6c..2d863935 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC1.TEST @@ -1 +1,60 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.DFASL index 3ae1a89c..d2499024 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.DFASL 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 index 22c576a6..212f0f8b 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-ORC2.TEST @@ -1 +1,59 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.DFASL index b9d23795..f9dbe6b7 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.DFASL 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 index a5beaa48..09fa91ea 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT-XOR.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-4-BIT.DFASL b/internal/test/LANGUAGE/AUTO/17-4-BIT.DFASL index 2025ec2a..3d4b99d2 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-BIT.DFASL 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 index fb0bf382..c5b165a8 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-BIT.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-BIT.TEST @@ -1 +1,61 @@ -;; 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 +;; 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 index 6b8ee2cb..fc2aa092 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-4-SBIT.DFASL 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 index be82d0ed..36125e3b 100644 --- a/internal/test/LANGUAGE/AUTO/17-4-SBIT.TEST +++ b/internal/test/LANGUAGE/AUTO/17-4-SBIT.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 index b5f4a714..7d60c557 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-5-ARRAY-HAS-FILL-POINTER-P.DFASL 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 index cf7d974f..1c2a9c8b 100644 --- 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 @@ -1 +1,46 @@ -;; 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 +;; 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 index 9bedb1f7..0f51edb3 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-5-FILL-POINTER.DFASL 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 index 6cecc824..108b563d 100644 --- a/internal/test/LANGUAGE/AUTO/17-5-FILL-POINTER.TEST +++ b/internal/test/LANGUAGE/AUTO/17-5-FILL-POINTER.TEST @@ -1 +1,35 @@ -;; 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 +;; 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 index 0511c4e5..a4e8f5a6 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-POP.DFASL 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 index 3260d089..1fe00149 100644 --- a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-POP.TEST +++ b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-POP.TEST @@ -1 +1,59 @@ -;; 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 +;; 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 + + + + + + diff --git a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.DFASL b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.DFASL index 761ec79b..1d74b73e 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.DFASL 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 index d1604cb6..eec1782e 100644 --- a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.TEST +++ b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH-EXTEND.TEST @@ -1 +1,86 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.DFASL b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.DFASL index b1a05adf..f73aabf1 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.DFASL 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 index 7cc60c4c..448c2706 100644 --- a/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.TEST +++ b/internal/test/LANGUAGE/AUTO/17-5-VECTOR-PUSH.TEST @@ -1 +1,48 @@ -;; 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 +;; 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 index 78d1b3d1..e0150599 100644 Binary files a/internal/test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.DFASL 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 index 7d98cd49..ca568306 100644 --- a/internal/test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.TEST +++ b/internal/test/LANGUAGE/AUTO/17-6-ADJUST-ARRAY.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 index 9f6a81ea..590e1eea 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-1-CHAR.DFASL 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 index 1e3948a1..cbbd6086 100644 --- a/internal/test/LANGUAGE/AUTO/18-1-CHAR.TEST +++ b/internal/test/LANGUAGE/AUTO/18-1-CHAR.TEST @@ -1 +1,94 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-1-SCHAR.DFASL b/internal/test/LANGUAGE/AUTO/18-1-SCHAR.DFASL index 415202ab..dc9b3ae4 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-1-SCHAR.DFASL 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 index dc9e57ca..1f94626e 100644 --- a/internal/test/LANGUAGE/AUTO/18-1-SCHAR.TEST +++ b/internal/test/LANGUAGE/AUTO/18-1-SCHAR.TEST @@ -1 +1,63 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.DFASL index b691b9b3..e8e0a9c1 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.DFASL 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 index a876b91f..aa99dd60 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQ.TEST @@ -1 +1,110 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.DFASL index f09e785c..bc41ecd9 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.DFASL 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 index e2a31638..682cc617 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-EQUAL.TEST @@ -1 +1,140 @@ -;; 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 +;; 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 index 81e063ec..e1332d95 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-GE.DFASL 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 index 8da811e9..289d5301 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-GE.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-GE.TEST @@ -1 +1,101 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.DFASL index 24196377..4cc2b26a 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.DFASL 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 index 3d4ee62e..ece83730 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-GREATERP.TEST @@ -1 +1,100 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.DFASL index 9321bb41..761963ec 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.DFASL 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 index ce920762..febdbe96 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-GT.TEST @@ -1 +1,102 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-LE.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-LE.DFASL index 047a9221..408ecbbb 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-LE.DFASL 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 index 4297f1e2..c0e9b23c 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-LE.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-LE.TEST @@ -1 +1,102 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.DFASL index 0a0e017b..8d667bab 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.DFASL 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 index c5b91b3f..e0393916 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-LESSP.TEST @@ -1 +1,94 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-LT.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-LT.DFASL index 5a7c32b4..eb495883 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-LT.DFASL 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 index 2b525511..3ff8b68c 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-LT.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-LT.TEST @@ -1 +1,96 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.DFASL index 6fbcf3e4..7bb4d7d8 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.DFASL 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 index a0072a97..1c1ecadb 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-NEQ.TEST @@ -1 +1,48 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.DFASL index d28f1f91..4e6f49b8 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.DFASL 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 index fdf82187..95aab6e2 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-EQUAL.TEST @@ -1 +1,48 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.DFASL index 615c8a7b..a1f171fa 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.DFASL 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 index 2b8d445a..b2f6815a 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-GREATERP.TEST @@ -1 +1,98 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.DFASL b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.DFASL index b7ecdd94..7adfc623 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.DFASL 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 index ef6d5eed..fd83023a 100644 --- a/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.TEST +++ b/internal/test/LANGUAGE/AUTO/18-2-STRING-NOT-LESSP.TEST @@ -1 +1,101 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.DFASL b/internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.DFASL index 11c9bff8..35371611 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.DFASL 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 index ed283579..33ef9707 100644 --- a/internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.TEST +++ b/internal/test/LANGUAGE/AUTO/18-3-MAKE-STRING.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.DFASL index 402fe0c0..7e64e81e 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.DFASL 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 index b99edf24..f23a0708 100644 --- a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.TEST +++ b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-CAPITALIZE.TEST @@ -1 +1,59 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.DFASL index aef1aced..d0e49a2e 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.DFASL 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 index d8339999..7e2681e4 100644 --- a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.TEST +++ b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-DOWNCASE.TEST @@ -1 +1,61 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.DFASL index 870d016a..0edca1cc 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.DFASL 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 index fe140aa0..9e8695e2 100644 --- a/internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.TEST +++ b/internal/test/LANGUAGE/AUTO/18-3-NSTRING-UPCASE.TEST @@ -1 +1,57 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.DFASL index 57f962a0..44829ad1 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.DFASL 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 index 054552f4..28bf4f58 100644 --- a/internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.TEST +++ b/internal/test/LANGUAGE/AUTO/18-3-STRING-CAPITALIZE.TEST @@ -1 +1,40 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.DFASL index fc979a19..8256595b 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.DFASL 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 index b58d570e..34e1c7ad 100644 --- a/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.TEST +++ b/internal/test/LANGUAGE/AUTO/18-3-STRING-DOWNCASE.TEST @@ -1 +1,51 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.DFASL index d3edceb4..1cc8e33b 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.DFASL 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 index 7452492e..008a03f6 100644 --- a/internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.TEST +++ b/internal/test/LANGUAGE/AUTO/18-3-STRING-LEFT-TRIM.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.DFASL index 73ec7291..43d90dd5 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.DFASL 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 index 2b83dfce..2c34dddc 100644 --- a/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.TEST +++ b/internal/test/LANGUAGE/AUTO/18-3-STRING-RIGHT-TRIM.TEST @@ -1 +1,66 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.DFASL index 86f0308b..55f39626 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.DFASL 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 index 8c606cf4..c0ae8a6b 100644 --- a/internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.TEST +++ b/internal/test/LANGUAGE/AUTO/18-3-STRING-TRIM.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.DFASL index 9a59a064..d4c7055b 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.DFASL 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 index 16797e06..1bda60b0 100644 --- a/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.TEST +++ b/internal/test/LANGUAGE/AUTO/18-3-STRING-UPCASE.TEST @@ -1 +1,50 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/18-3-STRING.DFASL b/internal/test/LANGUAGE/AUTO/18-3-STRING.DFASL index 1880be5d..b1121f2f 100644 Binary files a/internal/test/LANGUAGE/AUTO/18-3-STRING.DFASL 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 index 98281d43..0862091e 100644 --- a/internal/test/LANGUAGE/AUTO/18-3-STRING.TEST +++ b/internal/test/LANGUAGE/AUTO/18-3-STRING.TEST @@ -1 +1,79 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/19-DEFSTRUCT.TEST b/internal/test/LANGUAGE/AUTO/19-DEFSTRUCT.TEST index 3b46f054..d2114432 100644 Binary files a/internal/test/LANGUAGE/AUTO/19-DEFSTRUCT.TEST 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 index 9da2986b..0929ed33 100644 Binary files a/internal/test/LANGUAGE/AUTO/20-1-APPLYHOOK.DFASL 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 index 2991f22d..c30c379a 100644 Binary files a/internal/test/LANGUAGE/AUTO/20-1-CONSTANTP.DFASL 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 index 00325f1c..d9f7f8c7 100644 --- a/internal/test/LANGUAGE/AUTO/20-1-CONSTANTP.TEST +++ b/internal/test/LANGUAGE/AUTO/20-1-CONSTANTP.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/20-1-EVAL.DFASL b/internal/test/LANGUAGE/AUTO/20-1-EVAL.DFASL index da2e3e87..7e365c90 100644 Binary files a/internal/test/LANGUAGE/AUTO/20-1-EVAL.DFASL 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 index 9b2f8068..bda5e6e5 100644 --- a/internal/test/LANGUAGE/AUTO/20-1-EVAL.TEST +++ b/internal/test/LANGUAGE/AUTO/20-1-EVAL.TEST @@ -1 +1,72 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/21-STREAMS.TEST b/internal/test/LANGUAGE/AUTO/21-STREAMS.TEST index 2dbbd02b..b88a8a6a 100644 --- a/internal/test/LANGUAGE/AUTO/21-STREAMS.TEST +++ b/internal/test/LANGUAGE/AUTO/21-STREAMS.TEST @@ -1,846 +1,6 @@ -;; This is a listing of the 21-Streams.NoteFile. It tests all of the functions in chapter 21 of Common Lisp the Language by Guy Steele. The individual test files for each of the functions have been appended together in this big file to share routines for testing a stream and to gain diagnostic information by testing the functions in a particular order. -;; -;; The source for this text file is the NoteCards database at {eris}cml>test>21-Streams.NoteFile. Changes are NOT made directly to the listing: -;;Filed As: {eris}cml>test>21-streams.test -;; -(do-test "setup stream source and sink names" -;; Note: implementation dependent file names below. For -;; portability the stream names at minimum use the file -;; name "TEST". Thus they are a function of the current -;; connected directory at the time the test is run!!! -(test-setq stream-io-names -(nconc (list "TEST") -(cond -((string-equal (lisp-implementation-type) "Xerox") -(when nil -(list "{core}test" "{dsk}test") -; ignored for testing test -) -(when nil -(list "{erinyes}test" " {pele:}test" -"{10.0.0.56}" -; SUMEX requires loading TCP and -; having an account on SUMEX -*terminal-io* *debug-io* -*query-io* -; testing these means hand typing -; appropriate response -"{VAXC}/user/xais/test/test")))))) -;; the following may be useful in some tests if set up correctly -(test-setq stream-source-names -(append stream-io-names (when nil (list *standard-input* "string")))) -(test-setq stream-sink-names -(append stream-io-names -(when nil (list *standard-output* *error-output* "string"))))) -(do-test "defun setup-input-streams" -(test-defun setup-input-streams (stream-names) -(mapcar -#'(lambda (stream-name) -(if (string-equal stream-name "string") -(make-string-input-stream test-string) -(let ((astream (open stream-name :direction :output -:if-does-not-exist :create :if-exists -:supersede))) -;; put something in the sources -(output-test astream) -;; open them for input -(open stream-name)))) stream-names))) -(do-test "define error logger" -(defun print-stream-error (fun-name &optional (stream-name "")) -(print (concatenate 'string fun-name " failed" -(unless (string-equal stream-name "") -(concatenate 'string " on " stream-name))) -*error-output*))) -;; Functions To Be Tested: streamp input-stream-p -;; output-stream-p and stream-element-type -;; -;; Source: CLtL p. 329-332 -;; -;; Chapter 21: Streams Section 21-2&3: Creating New -;; Streams and Operations on Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> n MonthName << 86 -;; -;; Filed As: {eris}cml>test>21-streams.def -;; -;; Function To Be Tested: streamp -;; -;; Source: CLtL p. 332 -;; Chapter 21: Streams Section 21-3: Operations on -;; Streams -;; -;; Syntax: streamp object -;; -;; Function Description: streamp is true if its argument is a -;; stream, and otherwise is false. (streamp x) = (typep x -;; `stream) -;; -;; Argument(s): object -;; -;; Returns: true or false -;; -;; Function To Be Tested: input-stream-p -;; -;; Syntax: input-stream-p stream -;; -;; Function Description: This predicate is true if its -;; argument (which must be a stream) can handle input -;; operations, and otherwise is false. -;; -;; Argument(s): stream -;; -;; Returns: true or false -;; -;; Function To Be Tested: stream-element-type -;; -;; Syntax: stream-element-type stream -;; -;; Function Description: A type specifier is returned to -;; indicate what objects may be read from or written to the -;; argument stream, which must be a stream. streams -;; created by open will have an element type restricted to a -;; subset of character or integer, but in principle a stream -;; may conduct transactions using any LISP objects. -;; -;; Argument(s): stream -;; -;; Returns: type specifier -;; -;; Function To Be Tested: output-stream-p -;; -;; Syntax: output-stream-p stream -;; -;; Function Description: This predicate is true if its -;; argument (which must be a stream) can handle output -;; operations, and otherwise is false. -;; -;; Argument(s): stream -;; -;; Returns: true or false -;; -(do-test "stream predicates" -(defun input-test (astream &key keep-open dont-test-for-eof) -(and (streamp astream) -(input-stream-p astream) -(or (subtypep (stream-element-type astream) 'integer) -(subtypep (stream-element-type astream) 'character)) -(equal (read astream) 'hello) -(or dont-test-for-eof (read astream nil t)) -(or keep-open (close astream)))) -(defun mult-input-test (streamlist options) -(if options -(if (atom streamlist) t -(and (input-test (car streamlist)) -(mult-input-test (cdr streamlist) nil))) -(if (atom streamlist) t -(and (input-test (car streamlist) :keep-open :dont-test-for-eof) -(mult-input-test (cdr streamlist) t))))) -(defun output-test (astream &key keep-open) -(and (streamp astream) -(output-stream-p astream) -(or (subtypep (stream-element-type astream) 'integer) -(subtypep (stream-element-type astream) 'character)) -(print 'hello astream) -(or keep-open (close astream)))) -(test-setq test-string "hello")) -;; Function To Be Tested: make-string-input-stream -;; -;; Source: CLtL p. 330 -;; Chapter 21: Streams Section 21-2: Creating New Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> n MonthName << 86 -;; -;; Filed As: {eris}cml>test>21-2-make-string-input-stream.test -;; -;; -;; Syntax: make-string-input-stream string &optional start end -;; -;; Function Description: This returns an input stream. The input stream will supply, in order, the characters in the substring of string delimited by start and end; after the last character has been supplied, the stream will then be at end-of-file. -;; -;; Argument(s): string, start -- integer, end -- integer -;; -;; Returns: output stream -;; -(do-test-group "make-string-input-stream" -(do-test make-string-input-stream-simple-test -(and (test-setq astream (make-string-input-stream test-string)) -(input-test astream))) -(do-test make-string-input-stream-bounded-test -(and (test-setq astream (make-string-input-stream test-string 0 5)) -(input-test astream))) -(do-test make-string-input-stream-bounded-test -(and (test-setq astream -(make-string-input-stream (concatenate 'string "well " -test-string " hi") -5 (+ 5 (length test-string)))) -(input-test astream)))) -;; Function To Be Tested: make-string-output-stream and get-output-stream-string -;; -;; Source: CLtL p. 330 -;; Chapter 21: Streams Section 21-2: Creating New Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> n MonthName << 86 -;; -;; Filed As: {eris}cml>test>21-2-make-string-output-stream.test -;; -;; -;; Syntax: make-string-output-stream -;; -;; Function Description: This retruns an output stream that will accumulate all output given it for the benefit of the function get-output-stream-string. -;; -;; Argument(s): none -;; -;; Returns: output-stream -;; -;; -;; Syntax: get-output-stream-string string-output-stream -;; -;; Function Description: Given a stream produced by make-string-output-stream, this returns a string containing all the characters output to the stream so far. The stream is then reset; thus each call to get-output-stream-string gets only the characters since the last such call (or the creation of the stream, if no such previous call has been made). -;; -;; Argument(s): string-output-stream -;; -;; Returns: string -;; -(do-test-group -("make-string-output-stream group" :after -(progn (close astream) -(close bstream))) -(do-test "make-string-output-stream" -(and (test-setq astream (make-string-output-stream)) -(output-test astream :keep-open t) -(test-setq bstream -(make-string-input-stream (get-output-stream-string astream))) -(print "somemore" astream) -(input-test bstream) -(test-setq bstream -(make-string-input-stream (get-output-stream-string astream))) -(string-equal (read bstream) "somemore") -(close astream) -(read-char bstream nil t) -(close bstream)))) -;; Function To Be Tested: with-input-from-string [Macro] -;; -;; Source: CLtL p. 330 -;; Chapter 21: Streams Section 21-2: Creating New Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> day month << 86 -;; -;; Filed As: {eris}cml>test>21-2-with-input-from-string.test -;; -;; -;; Syntax: with-input-from-string (var string {keyword value}*) {declaration}* {form}* -;; -;; Function Description: The body is executed as an implicit progn with the variable var bound to a character input stream that supplies successive characters from the value of the form string. with-input-from-string returns the results from the last form of the body. See CLtL p 330-331 for more info. -;; -;; Argument(s): var - variable; string -- form; -;; keyword -- :index -- form of place acceptable to setf -;; :start, :end -- form resolving to non-negative integers -;; -;; Returns: result of last form of the body -;; -(do-test-group "with-input-from-string" -(do-test with-input-from-string-simple-test -(with-input-from-string (astream test-string) -(input-test astream))) -(do-test with-input-from-string-book-test -;; from the CLtL book -(and (with-input-from-string (astream "Animal Crackers" :index j :start 6) -(read astream)) -(eql j 15))) -(do-test with-input-from-string-bounded-test -(and (with-input-from-string (astream (concatenate 'string "well " -test-string " hi") -:index j :start 5 :end 11) -(input-test astream :keep-open t)) -(eql j 11)))) -;; Function To Be Tested: with-output-to-string [Macro] -;; -;; Source: CLtL p. 331 -;; Chapter 21: Streams Section 21-2: Creating New Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> day month << 86 -;; -;; Filed As: {eris}cml>test>21-2-with-output-to-string.test -;; -;; -;; Syntax: with-output-to-string (var [string]) {declaration}* {form}* -;; -;; Function Description: The body is executed as an implicit progn with the variable var bound to a character output strema. All output to that stream is saved in a string. See CLtL page 331 for more. -;; -;; Argument(s): var -- variable; string -- form; declarations; forms; -;; -;; Returns: if no string is specified, then string. Otherwise value of last form. -;; -(do-test-group "with-output-to-string" -(do-test with-output-to-string-simple-test -(input-test -(make-string-input-stream -(with-output-to-string (astream) -(output-test astream :keep-open t))))) -(do-test with-output-to-string-supplied-test -(let (astring) -(and (with-output-to-string (astream (setq astring -(make-array 14 -:element-type -'string-char -:fill-pointer 0))) -(print 'hello astream)) -(string-equal " -hello " astring)))) -(do-test with-output-to-string-supplied-test2 -(let (astring) -(and (with-output-to-string (astream (setq astring -(make-array 14 -:element-type -'string-char -:fill-pointer 0))) -(output-test astream :keep-open t)) -(input-test (make-string-input-stream astring)))))) -;; Function To Be Tested: with-open-stream [Macro] -;; -;; Source: CLtL p. 330 -;; Chapter 21: Streams Section 21-2: Creating New Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> day month << 86 -;; -;; Syntax: with-open-stream (var stream) {declaration}* {form}* -;; -;; Function Description: The form stream is evaluated and must produce a stream. The variable var is bound with the stream as its value, and then the forms of the body are executed as an implicit progn; the results of evaluating the last form are returned as the value of the with-open-stream form. The stream is automatically closed on exit from the with-open-stream form, no matter whether the exit is normal or abnormal. The stream should be regarded as having dynamic extent. -;; -;; Argument(s): local variable, stream form, declarations, and forms -;; -;; Returns: result of last form -;; -(do-test-group -("with-open-stream" :after -(dolist (stream-name stream-source-names) -(delete-file (probe-file stream-name)))) -(do-test with-open-stream-output-test -(dolist (stream-name stream-sink-names t) -(declare (special stream-name)) -(with-open-stream -(astream (open stream-name :direction :output :if-exists -:new-version :if-does-not-exist :create)) -(or (output-test astream :keep-open t) -(print-stream-error -"WITH-OPEN-STREAM-OUTPUT-TEST" -stream-name))) -;; make sure it got closed -(or (close (open stream-name)) -(print-stream-error "WITH-OPEN-STREAM-OUTPUT-TEST" -stream-name)))) -(do-test with-open-stream-input-test -;; note this test assumes with-open-stream-output-test -;; has been run -(dolist (stream-name stream-source-names t) -(declare (special stream-name)) -(with-open-stream (astream (open stream-name)) -(or (input-test astream :keep-open t) -(print-stream-error -"WITH-OPEN-STREAM-INPUT-TEST" -stream-name))) -;; make sure it got closed -(or (close (open stream-name)) -(print-stream-error "WITH-OPEN-STREAM-INPUT-TEST" -stream-name))))) -;; Function To Be Tested: make-broadcast-stream -;; -;; Source: CLtL p. 329 -;; Chapter 21: Streams Section 21-2: Creating New Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> day month << 86 -;; -;; Filed As: {eris}cml>test>21-2-make-broadcast-stream.test -;; -;; -;; Syntax: make-broadcast-stream streams -;; -;; Function Description: This returns a stream that only works in the output direction. Any output sent to this stream will be sent to all of the streams given. The set of operations that may be performed on the new stream is the intersection of those for the given streams. The results returned by a stream operation are the values resulting from performing the operation on the last stream in streams, the results of performing the operation on all preceding streams are discarded. If no streams are given as arguments, then the result is a "bit sink"; all output to the resulting stream is discarded. -;; -;; Argument(s): stream(s) -;; -;; Returns: stream -;; -(do-test-group -(make-broadcast-stream-test :before -(test-setq output-streams -(mapcar #'(lambda (stream-name) -(open stream-name :direction :output :if-exists -:new-version :if-does-not-exist :create)) -stream-sink-names)) :after -(progn (mapcar #'close output-streams) -(dolist (stream-name stream-sink-names) -(delete-file (probe-file stream-name))) -;; note each of the following tests must be done in -;; sequence -)) -(do-test make-broadcast-stream-creation-test -(test-setq astream (apply #'make-broadcast-stream output-streams))) -(do-test make-broadcast-stream-list-test -(expect-errors (error) (make-broadcast-stream '(some random list)))) -(do-test make-broadcast-stream-output-test (output-test astream)) -(do-test make-broadcast-stream-results-test (mapcar #'close output-streams) -(test-setq output-streams (mapcar #'open stream-sink-names)) -(or (mult-input-test output-streams nil) -(print-stream-error "MAKE-BROADCAST-STREAM-TEST" -(namestring astream))))) -;; Function To Be Tested: make-concatenated-stream -;; -;; Source: CLtL p. 329 -;; Chapter 21: Streams Section 21-2: Creating New Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> n MonthName << 86 -;; -;; Filed As: {eris}cml>test>21-2-make-concatenated-stream.test -;; -;; -;; Syntax: make-concatenated-stream &rest streams -;; -;; Function Description: This returns a stream that only works in the inut direction. Input is taken from the first of the streams until it reaches end-of-file; then that stream is discarded, and input is taken from the next of the streams, and so on. If no arguments are given, the result is a stream with no content; any input attempt will result in end-of-file. -;; -;; Argument(s): streams -;; -;; Returns: stream -;; -(do-test-group "make-concatenated-stream" -(do-test make-concatenated-stream-simple-test -(setq astream -(open "test" :direction :output :if-exists :new-version -:if-does-not-exist :create)) -(output-test astream) -(setq original-stream (open "test")) -(prog1 -(and (setq astream (make-concatenated-stream original-stream)) -(input-test astream)) -(close original-stream) -(close astream) -; just in case -(delete-file (probe-file "test")))) -(do-test make-concatenated-stream-string-test -(setq original-stream (make-string-input-stream test-string)) -(and (setq astream (make-concatenated-stream original-stream)) -(input-test astream))) -(do-test "MAKE-CONCATENATED-STREAM" -(setq input-streams (setup-input-streams stream-io-names)) -(prog1 -(and (setq concatenated-stream -(apply #'make-concatenated-stream input-streams)) -(dolist (astream input-streams t) -(or (input-test concatenated-stream :keep-open t -:dont-test-for-eof t) -(print-stream-error -"MAKE-CONCATENATED-STREAM" -(namestring astream)))) -(close concatenated-stream)) -(mapcar #'close input-streams) -(dolist (stream-name input-streams) -(delete-file (probe-file stream-name))))) -(do-test make-concatenated-stream-closed-test -(and (close (setq closed.file.stream -(open "emptyfile" :direction :output :if-exists -:new-version :if-does-not-exist :create))) -(delete-file (probe-file "emptyfile")) -(setq concatenated-stream -(make-concatenated-stream closed.file.stream)) -(expect-errors (error) (read-char closed.file.stream)) -(expect-errors (error) (close concatenated-stream)))) -(do-test make-concatenated-stream-empty-test -(and (setq empty-stream (make-concatenated-stream)) -(read empty-stream nil t) -(close empty-stream))) -(do-test make-concatenated-stream-string-test -(setq astream (make-string-input-stream test-string)) -(and (setq concatenated-stream (make-concatenated-stream astream)) -(input-test astream)))) -;; Function To Be Tested: make-two-way-stream -;; -;; Source: CLtL p. 329 -;; Chapter 21: Streams Section 21-2: Creating New Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> n MonthName << 86 -;; -;; Filed As: {eris}cml>test>21-2-make-two-way-stream.test -;; -;; -;; Syntax: make-two-way-stream input-stream output-stream -;; -;; Function Description: This returns a bidirectional strem that gets its input from input-stream and sends its output to output-stream. -;; -;; Argument(s): input-stream output-stream -;; -;; Returns: stream -;; -(do-test-group "make-two-way-stream" -(do-test make-two-way-stream-file-test -(dolist (stream-name stream-io-names t) -(test-setq instream -(open stream-name :direction :output :if-exists -:new-version :if-does-not-exist :create)) -(output-test instream) -(test-setq instream (open instream)) -(test-setq outstream -(open "testout" :direction :output :if-exists :new-version -:if-does-not-exist :create)) -(unless -(prog1 -(and (test-setq two-way-stream -(make-two-way-stream instream -outstream)) -(streamp two-way-stream) -(input-stream-p two-way-stream) -(output-stream-p two-way-stream) -(equal (read two-way-stream) 'hello) -(print "it works" two-way-stream) -(expect-errors (end-of-file) (read two-way-stream)) -(close two-way-stream) -;; should instream and outstream be -;; closed? if so, should test here -) -(close instream) -(close outstream) -(delete-file stream-name) -(delete-file (probe-file "testout"))) -(print-stream-error "make-two-way-stream-file-test" -stream-name)))) -(do-test make-two-way-stream-string-test -(test-setq astream (make-string-input-stream test-string)) -(test-setq bstream (make-string-output-stream)) -(and (test-setq two-way-stream -(make-two-way-stream astream bstream)) -(streamp two-way-stream) -(output-stream-p two-way-stream) -(input-test two-way-stream :keep-open t) -(prin1 'garbage two-way-stream) -(string-equal "garbage" (get-output-stream-string bstream)) -(close two-way-stream) -(close astream) -(close bstream))) -(do-test make-two-way-stream-closed-test -(test-setq astream (make-string-input-stream test-string)) -(close (test-setq closed.file.stream -(open "emptyfile" :direction :output :if-exists -:new-version :if-does-not-exist :create))) -(delete-file (probe-file "emptyfile")) -(and (test-setq two-way-stream -(make-two-way-stream astream closed.file.stream)) -(expect-errors (error) (print "any random thing" two-way-stream)) -(close two-way-stream) -(close astream))) -(do-test make-two-way-stream-backwards-test -(test-setq instream (make-string-input-stream test-string)) -(test-setq outstream (make-string-output-stream)) -(and (test-setq two-way-stream -(make-two-way-stream outstream instream)) -(expect-errors (error) (print "backwards" two-way-stream)) -(expect-errors (error) (read two-way-stream)) -(close two-way-stream) -(close instream) -(close outstream)))) -;; Function To Be Tested: make-echo-stream -;; -;; Source: CLtL p. 330 -;; Chapter 21: Streams Section 21-2: Creating New Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> n MonthName << 86 -;; -;; Filed As: {eris}cml>test>21-2-make-echo-stream.test -;; -;; -;; Syntax: make-echo-stream input-stream output-stream -;; -;; Function Description: This returns a bidirectional stream that gets its input from input-stream and sends its output to output-stream. In addition, all input taken from input-stream is echoed to output-stream. -;; -;; Argument(s): input-stream output-stream -;; -;; Returns: stream -;; -(do-test-group "make-echo-stream" -(do-test make-echo-stream-file-test -(dolist (stream-name stream-io-names t) -(test-setq instream -(open stream-name :direction :output :if-exists -:new-version :if-does-not-exist :create)) -(output-test instream) -(test-setq instream (open stream-name)) -(test-setq outstream -(open "testout" :direction :output :if-does-not-exist -:create)) -(unless (prog1 (and (test-setq echo-stream -(make-echo-stream instream -outstream)) -(output-stream-p echo-stream) -(input-test echo-stream :keep-open t -:dont-test-for-eof t) -(output-test echo-stream :keep-open t) -(read echo-stream nil t) -(close echo-stream) -(test-setq outstream (open "testout")) -(input-test outstream)) -(close echo-stream) -(close instream) -(close outstream) -(delete-file (probe-file stream-name)) -(delete-file (probe-file "testout"))) -(print-stream-error "make-ECHO-stream-file-test" -stream-name)))) -(do-test make-echo-stream-string-test -;; DEPENDS ON TEST-STRING SETUP WITH -;; STREAM PREDICATES -(test-setq astream (make-string-input-stream test-string)) -(test-setq bstream (make-string-output-stream)) -(prog1 -(and (test-setq echo-stream (make-echo-stream astream bstream)) -(streamp echo-stream) -(output-stream-p echo-stream) -(input-test echo-stream :keep-open t) -(string-equal "HELLO" (get-output-stream-string bstream)) -(close echo-stream) -(close astream) -(close bstream)) -;; just in case -(close echo-stream) -(close astream) -(close bstream))) -(do-test make-echo-stream-closed-test -(test-setq astream (make-string-input-stream test-string)) -(close (test-setq closed.file.stream -(open "emptyfile" :direction :output :if-exists -:new-version :if-does-not-exist :create))) -(delete-file (probe-file "emptyfile")) -(and (test-setq echo-stream -(make-echo-stream astream closed.file.stream)) -(expect-errors (error) (print "any random thing" echo-stream)) -(close echo-stream) -(close astream)))) -;; Function To Be Tested: make-synonym-stream -;; -;; Source: CLtL p. 329 -;; Chapter 21: Streams Section 21-2: Creating New Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> n MonthName << 86 -;; -;; Filed As: {eris}cml>test>21-2-make-synonym-stream.test -;; -;; -;; Syntax: make-synonym-stream symbol -;; -;; Function Description: Creates and returns a "synonym stream." Any operations on the new stream will be performed on the stream that is then the value of the dynamic variable named by the symbol. If the value of the variable should change or be bound, then the synonym stream will operate on the new stream. -;; -;; -;; Argument(s): symbol -;; -;; Returns: stream -;; -(do-test-group "make-synonym-stream" -(do-test make-synonym-stream-test -(dolist (stream-name stream-io-names t) -(test-setq original-stream -(open stream-name :direction :output :if-exists -:new-version :if-does-not-exist :create)) -(or (and (test-setq astream (make-synonym-stream 'original-stream)) -(output-test astream)) -(print-stream-error "MAKE-SYNONYM-STREAM-output-TEST" -stream-name)) -;; make sure the actual stream did not get closed. -(or (write "1" :stream original-stream) -(print-stream-error -"MAKE-SYNONYM-STREAM-output-close-TEST" -stream-name)) -(close original-stream) -(test-setq original-stream (open stream-name)) -(or (and (test-setq astream (make-synonym-stream 'original-stream)) -(input-test astream :dont-test-for-eof t)) -(print-stream-error "MAKE-SYNONYM-STREAM-input-TEST" -stream-name)) -;; make sure the actual stream did not get closed. -(or (string-equal "1" (ignore-errors (read original-stream))) -(print-stream-error -"MAKE-SYNONYM-STREAM-input-close-TEST" -stream-name)) -(close original-stream) -(delete-file (probe-file stream-name)))) -(do-test "MAKE-SYNONYM-STREAM with declare special" -(dolist (stream-name stream-io-names t) -(declare (special stream-name)) -(unless -(and (with-open-file -(afilestream stream-name :direction :output -:if-exists :new-version :if-does-not-exist -:create) -(declare (special afilestream)) -(and (test-setq astream -(make-synonym-stream 'afilestream)) -(output-test astream))) -(with-open-file (afilestream stream-name) -(declare (special afilestream)) -(and (test-setq astream -(make-synonym-stream 'afilestream)) -(input-test astream)))) -(print-stream-error -"MAKE-SYNONYM-STREAM with-open-file declare special TEST" -stream-name)) -(delete-file (probe-file stream-name))))) -;; Function To Be Tested: close -;; -;; Source: CLtL p. 332 -;; Chapter 21: Streams Section 21-3: Operations on Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 31 October 86 -;; -;; Last Update: >> day month << 86 -;; -;; Filed As: {eris}cml>test>21-3-close.test -;; -;; -;; Syntax: close stream &key :abort -;; -;; Function Description: The argument must be a stream. The stream is closed. No further i/o operations may be performed on it. However, certain inquiry operations may still be performed, and it is permissible to close an already closed stream. -;; If the :abort parameter is not nil (it defaults to nil), it indicates an abnormal termination of the use of the stream. An attempt is made to clean up any side effects ofhaving created the stream in the first place. For example, if the stream performs output to a file that was newly created when the stream was created, then if possible the file is deleted and any previously existing file is not superceded. -;; -;; Argument(s): stream -- stream -;; :abort nil / t -;; -;; Returns: t always? -;; The simple case of close is tested in all the other stream tests. Here we test the abort condition. -;; -(do-test-group ("close") -(do-test "close abort delete output file" -(dolist (stream-name stream-sink-names t) -(let ((astream (open stream-name :direction :output :if-exists -:new-version :if-does-not-exist :create))) -(output-test astream :keep-open t) -(unless -(and (close astream :abort t) -;; make sure the file got deleted -(expect-errors (error) (open (pathname astream)))) -(print-stream-error "close abort delete output file" -stream-name) -(delete-file (probe-file (pathname astream))))))) -(do-test "close abort input" -(dolist (stream-name stream-io-names t) -(let ((astream (open stream-name :direction :output :if-exists -:new-version :if-does-not-exist :create))) -(output-test astream)) -(let ((astream (open stream-name))) -(unless -(and (close astream :abort t) -;; make sure the stream got closed -(close (open (pathname astream) :direction :output -:if-exists :append))) -(print-stream-error "close abort input" stream-name)) -(delete-file (probe-file (pathname astream))))))) -;; Definition To Be Tested: finish-output, force-output, and clear-output -;; -;; Source: Xerox LIsp Manual -;; Chapter 22-3-1: Input/Output Output to Character Streams -;; -;; Created By: Kirk Kelley -;; -;; Creation Date: 21 November 86 -;; -;; Last Update: >> day month << 86 -;; -;; Filed As: {eris}cml>test>22-3-1-finish-output.test -;; -;; -;; Syntax: finish-output &optional output-stream -;; -;; Function Description: The function finish-output attempts to ensure that all output sent to output-stream has reached its destination, and only then returns nil. force-output initiates the emptying of any internal buffers but returns nil without waiting for completion or acknowledgment. The function clear-output, on the other hand, attempts to abort any outstanding output operation in progress in order to allow as little output as possible to continue to the desitnation. -;; -;; Argument(s): output-stream -;; -;; Returns: nil -;; -;; These tests just test that the functions dont break for a variety of devices. It could be improved by putting out a huge string or simulating a slow channel by advising \bufferedbout (whatever its called) and do some elapsed time tests after each type of output. Then do an input-test to see if all the characters made it (or not in the case of clear-output). Try calling finish/force-output on a stream to a file server and then killing the connection. -;; -(do-test "finish-output" -(dolist (stream-name stream-io-names t) -(with-open-file (astream stream-name :direction :output) -(output-test astream :keep-open t) -(finish-output astream) -(close astream) -(with-open-file (astream stream-name) -(unless (input-test astream) -(print-stream-error "finish-output" -stream-name))))) -;; cleanup -(dolist (stream-name stream-io-names t) -(delete-file stream-name))) -(do-test "clear-output" -(dolist (stream-name stream-io-names t) -(with-open-file (astream stream-name :direction :output) -(output-test astream :keep-open t) -(clear-output astream) -(close astream))) -;; cleanup -(dolist (stream-name stream-io-names t) -(delete-file stream-name))) -(do-test "force-output" -(dolist (stream-name stream-io-names t) -(with-open-file (astream stream-name :direction :output) -(output-test astream :keep-open t) -(force-output astream) -(close astream) -(with-open-file (astream stream-name) -(unless (input-test astream) -(print-stream-error "finish-output" -stream-name))))) -;; cleanup -(dolist (stream-name stream-io-names t) -(delete-file stream-name))) -STOP -J(Ź(\(†( (Ł(Ś(}(ľ((ú(ł(l(’(î(v(_(o(Œ((R(=(+(œ(…(K(‹(x(d(ˆ(.(N(™(ű(Î(›(“(ä(:(‰(€(0((Ă(ó(C(1(Z(?(T(H(((J(–(z(6(((´(k(W(V(7(i({(U(‚(g(S(P(<((((G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8))M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10))  HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8))G9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) HELVETICA HELVETICAJˆŰJJ›J *JJ.I8I6I7I3IHGF3E D CBE D7A@!@AA @!@A#I?I?FI?>?J%I/HG=,<'<0;&;::::&J9@8/7&6+5444+33$33<4%3333"33)33;34$33 3;4 33*33@4<4 3333(33+331339474'3333(33/33633;4=464>4>443333)34,332339484'3333(3J9=82261522,2!9,8 02#/)02A/)9,82261522!9!J3JJJ@JJJJ!JJ(JJNJJJNJJúJJ:JJ'JJ*I..@-I/.D-I/.D7,+-JQJJJ@JJJJ!JJ(JJOJJJ5JJšJJJJ'JJJIJJbJJ&JJ JJI**)I%H5G#GF?GGGF?G)GGGJ=JJJ@JJJJ!JJ&JJLJJJfJJ1JJ2J>J>JJ9JJ(I,..(I*HHK'& -I-.C%;$#-J=JJJ@JJJJ!JJ&JJKJJJXJJËJJIJJ`JJ'I+H GF!#'I-H G3"!! -! I.H G3"!! -! $4J3JJJ@JJJJ!JJ&JJMJJăJJFJJ-JJI**)I&H*GGF9*F)GG23I%H6H -H,GG/F(GG22J0JJJ@JJJJ!JJ&JJKJJJ8JJ`JJJJ JJI$H 0*<H'G(E(G2G I-.DI).EIBIL.=.)1(J3JJJ@JJJJ!JJ(JJNJJJAJJoJJJJ JJ*I.HG8HH%HG?GGC -G$I..>.?-I$H;HG2F"3FGG$E*I..%0+-'-=/-7-6I-.4--I..6.C-J.JJJ@JJJJ!JJ(JJIJJJIJJ‰JJ,JJ JJ%I'H(G0*GG%G;GF#  !%"4#!D&F4 -I).;.0.D'--!-)- -<---I).;.% 0C+.'.D2-B--I,.<.2.D*-;-.---J+JJJ@JJJJ!JJ(JJFJJJFJJÖJJ,JJ JJ"I$.(2 0C*22(2 6C 2+    % '   ' '&1I&H#HH;H0HG@&:G -GGGI&.;.% 0C+.'.D/-?--J.JJJ@JJJJ!JJ(JJIJJJ5JJ9JJJJJ JJ%I"H(G0*GD/26G0G*F(GG/GD/+25G0G@F'GG)I4H(GGF,+ $*$F:G*J JJJAJJJJ!JJ&JJ;JJJ3JJřJŸJJ"JJJ#JhJJI*H*G;+F#F35 -2IH(G;+FG F 36F2JJJJ%J=JJJJ"JJ&JJEJJJ@JJáJJJJJJĚJJI(H9#& $II(JI(9#II(JI(H9#& $I I(wĆÜzş \ No newline at end of file +;; This is a listing of the 21-Streams.NoteFile. It tests all of the functions in chapter 21 of Common Lisp the Language by Guy Steele. The individual test files for each of the functions have been appended together in this big file to share routines for testing a stream and to gain diagnostic information by testing the functions in a particular order. ;; ;; The source for this text file is the NoteCards database at {eris}cml>test>21-Streams.NoteFile. Changes are NOT made directly to the listing: ;;Filed As: {eris}cml>test>21-streams.test ;; (do-test "setup stream source and sink names" ;; Note: implementation dependent file names below. For ;; portability the stream names at minimum use the file ;; name "TEST". Thus they are a function of the current ;; connected directory at the time the test is run!!! (test-setq stream-io-names (nconc (list "TEST") (cond ((string-equal (lisp-implementation-type) "Xerox") (when nil (list "{core}test" "{dsk}test") ; ignored for testing test ) (when nil (list "{erinyes}test" " {pele:}test" "{10.0.0.56}" ; SUMEX requires loading TCP and ; having an account on SUMEX *terminal-io* *debug-io* *query-io* ; testing these means hand typing ; appropriate response "{VAXC}/user/xais/test/test")))))) ;; the following may be useful in some tests if set up correctly (test-setq stream-source-names (append stream-io-names (when nil (list *standard-input* "string")))) (test-setq stream-sink-names (append stream-io-names (when nil (list *standard-output* *error-output* "string"))))) (do-test "defun setup-input-streams" (test-defun setup-input-streams (stream-names) (mapcar #'(lambda (stream-name) (if (string-equal stream-name "string") (make-string-input-stream test-string) (let ((astream (open stream-name :direction :output :if-does-not-exist :create :if-exists :supersede))) ;; put something in the sources (output-test astream) ;; open them for input (open stream-name)))) stream-names))) (do-test "define error logger" (defun print-stream-error (fun-name &optional (stream-name "")) (print (concatenate 'string fun-name " failed" (unless (string-equal stream-name "") (concatenate 'string " on " stream-name))) *error-output*))) ;; Functions To Be Tested: streamp input-stream-p ;; output-stream-p and stream-element-type ;; ;; Source: CLtL p. 329-332 ;; ;; Chapter 21: Streams Section 21-2&3: Creating New ;; Streams and Operations on Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> n MonthName << 86 ;; ;; Filed As: {eris}cml>test>21-streams.def ;; ;; Function To Be Tested: streamp ;; ;; Source: CLtL p. 332 ;; Chapter 21: Streams Section 21-3: Operations on ;; Streams ;; ;; Syntax: streamp object ;; ;; Function Description: streamp is true if its argument is a ;; stream, and otherwise is false. (streamp x) = (typep x ;; `stream) ;; ;; Argument(s): object ;; ;; Returns: true or false ;; ;; Function To Be Tested: input-stream-p ;; ;; Syntax: input-stream-p stream ;; ;; Function Description: This predicate is true if its ;; argument (which must be a stream) can handle input ;; operations, and otherwise is false. ;; ;; Argument(s): stream ;; ;; Returns: true or false ;; ;; Function To Be Tested: stream-element-type ;; ;; Syntax: stream-element-type stream ;; ;; Function Description: A type specifier is returned to ;; indicate what objects may be read from or written to the ;; argument stream, which must be a stream. streams ;; created by open will have an element type restricted to a ;; subset of character or integer, but in principle a stream ;; may conduct transactions using any LISP objects. ;; ;; Argument(s): stream ;; ;; Returns: type specifier ;; ;; Function To Be Tested: output-stream-p ;; ;; Syntax: output-stream-p stream ;; ;; Function Description: This predicate is true if its ;; argument (which must be a stream) can handle output ;; operations, and otherwise is false. ;; ;; Argument(s): stream ;; ;; Returns: true or false ;; (do-test "stream predicates" (defun input-test (astream &key keep-open dont-test-for-eof) (and (streamp astream) (input-stream-p astream) (or (subtypep (stream-element-type astream) 'integer) (subtypep (stream-element-type astream) 'character)) (equal (read astream) 'hello) (or dont-test-for-eof (read astream nil t)) (or keep-open (close astream)))) (defun mult-input-test (streamlist options) (if options (if (atom streamlist) t (and (input-test (car streamlist)) (mult-input-test (cdr streamlist) nil))) (if (atom streamlist) t (and (input-test (car streamlist) :keep-open :dont-test-for-eof) (mult-input-test (cdr streamlist) t))))) (defun output-test (astream &key keep-open) (and (streamp astream) (output-stream-p astream) (or (subtypep (stream-element-type astream) 'integer) (subtypep (stream-element-type astream) 'character)) (print 'hello astream) (or keep-open (close astream)))) (test-setq test-string "hello")) ;; Function To Be Tested: make-string-input-stream ;; ;; Source: CLtL p. 330 ;; Chapter 21: Streams Section 21-2: Creating New Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> n MonthName << 86 ;; ;; Filed As: {eris}cml>test>21-2-make-string-input-stream.test ;; ;; ;; Syntax: make-string-input-stream string &optional start end ;; ;; Function Description: This returns an input stream. The input stream will supply, in order, the characters in the substring of string delimited by start and end; after the last character has been supplied, the stream will then be at end-of-file. ;; ;; Argument(s): string, start -- integer, end -- integer ;; ;; Returns: output stream ;; (do-test-group "make-string-input-stream" (do-test make-string-input-stream-simple-test (and (test-setq astream (make-string-input-stream test-string)) (input-test astream))) (do-test make-string-input-stream-bounded-test (and (test-setq astream (make-string-input-stream test-string 0 5)) (input-test astream))) (do-test make-string-input-stream-bounded-test (and (test-setq astream (make-string-input-stream (concatenate 'string "well " test-string " hi") 5 (+ 5 (length test-string)))) (input-test astream)))) ;; Function To Be Tested: make-string-output-stream and get-output-stream-string ;; ;; Source: CLtL p. 330 ;; Chapter 21: Streams Section 21-2: Creating New Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> n MonthName << 86 ;; ;; Filed As: {eris}cml>test>21-2-make-string-output-stream.test ;; ;; ;; Syntax: make-string-output-stream ;; ;; Function Description: This retruns an output stream that will accumulate all output given it for the benefit of the function get-output-stream-string. ;; ;; Argument(s): none ;; ;; Returns: output-stream ;; ;; ;; Syntax: get-output-stream-string string-output-stream ;; ;; Function Description: Given a stream produced by make-string-output-stream, this returns a string containing all the characters output to the stream so far. The stream is then reset; thus each call to get-output-stream-string gets only the characters since the last such call (or the creation of the stream, if no such previous call has been made). ;; ;; Argument(s): string-output-stream ;; ;; Returns: string ;; (do-test-group ("make-string-output-stream group" :after (progn (close astream) (close bstream))) (do-test "make-string-output-stream" (and (test-setq astream (make-string-output-stream)) (output-test astream :keep-open t) (test-setq bstream (make-string-input-stream (get-output-stream-string astream))) (print "somemore" astream) (input-test bstream) (test-setq bstream (make-string-input-stream (get-output-stream-string astream))) (string-equal (read bstream) "somemore") (close astream) (read-char bstream nil t) (close bstream)))) ;; Function To Be Tested: with-input-from-string [Macro] ;; ;; Source: CLtL p. 330 ;; Chapter 21: Streams Section 21-2: Creating New Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>21-2-with-input-from-string.test ;; ;; ;; Syntax: with-input-from-string (var string {keyword value}*) {declaration}* {form}* ;; ;; Function Description: The body is executed as an implicit progn with the variable var bound to a character input stream that supplies successive characters from the value of the form string. with-input-from-string returns the results from the last form of the body. See CLtL p 330-331 for more info. ;; ;; Argument(s): var - variable; string -- form; ;; keyword -- :index -- form of place acceptable to setf ;; :start, :end -- form resolving to non-negative integers ;; ;; Returns: result of last form of the body ;; (do-test-group "with-input-from-string" (do-test with-input-from-string-simple-test (with-input-from-string (astream test-string) (input-test astream))) (do-test with-input-from-string-book-test ;; from the CLtL book (and (with-input-from-string (astream "Animal Crackers" :index j :start 6) (read astream)) (eql j 15))) (do-test with-input-from-string-bounded-test (and (with-input-from-string (astream (concatenate 'string "well " test-string " hi") :index j :start 5 :end 11) (input-test astream :keep-open t)) (eql j 11)))) ;; Function To Be Tested: with-output-to-string [Macro] ;; ;; Source: CLtL p. 331 ;; Chapter 21: Streams Section 21-2: Creating New Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>21-2-with-output-to-string.test ;; ;; ;; Syntax: with-output-to-string (var [string]) {declaration}* {form}* ;; ;; Function Description: The body is executed as an implicit progn with the variable var bound to a character output strema. All output to that stream is saved in a string. See CLtL page 331 for more. ;; ;; Argument(s): var -- variable; string -- form; declarations; forms; ;; ;; Returns: if no string is specified, then string. Otherwise value of last form. ;; (do-test-group "with-output-to-string" (do-test with-output-to-string-simple-test (input-test (make-string-input-stream (with-output-to-string (astream) (output-test astream :keep-open t))))) (do-test with-output-to-string-supplied-test (let (astring) (and (with-output-to-string (astream (setq astring (make-array 14 :element-type 'string-char :fill-pointer 0))) (print 'hello astream)) (string-equal " hello " astring)))) (do-test with-output-to-string-supplied-test2 (let (astring) (and (with-output-to-string (astream (setq astring (make-array 14 :element-type 'string-char :fill-pointer 0))) (output-test astream :keep-open t)) (input-test (make-string-input-stream astring)))))) ;; Function To Be Tested: with-open-stream [Macro] ;; ;; Source: CLtL p. 330 ;; Chapter 21: Streams Section 21-2: Creating New Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> day month << 86 ;; ;; Syntax: with-open-stream (var stream) {declaration}* {form}* ;; ;; Function Description: The form stream is evaluated and must produce a stream. The variable var is bound with the stream as its value, and then the forms of the body are executed as an implicit progn; the results of evaluating the last form are returned as the value of the with-open-stream form. The stream is automatically closed on exit from the with-open-stream form, no matter whether the exit is normal or abnormal. The stream should be regarded as having dynamic extent. ;; ;; Argument(s): local variable, stream form, declarations, and forms ;; ;; Returns: result of last form ;; (do-test-group ("with-open-stream" :after (dolist (stream-name stream-source-names) (delete-file (probe-file stream-name)))) (do-test with-open-stream-output-test (dolist (stream-name stream-sink-names t) (declare (special stream-name)) (with-open-stream (astream (open stream-name :direction :output :if-exists :new-version :if-does-not-exist :create)) (or (output-test astream :keep-open t) (print-stream-error "WITH-OPEN-STREAM-OUTPUT-TEST" stream-name))) ;; make sure it got closed (or (close (open stream-name)) (print-stream-error "WITH-OPEN-STREAM-OUTPUT-TEST" stream-name)))) (do-test with-open-stream-input-test ;; note this test assumes with-open-stream-output-test ;; has been run (dolist (stream-name stream-source-names t) (declare (special stream-name)) (with-open-stream (astream (open stream-name)) (or (input-test astream :keep-open t) (print-stream-error "WITH-OPEN-STREAM-INPUT-TEST" stream-name))) ;; make sure it got closed (or (close (open stream-name)) (print-stream-error "WITH-OPEN-STREAM-INPUT-TEST" stream-name))))) ;; Function To Be Tested: make-broadcast-stream ;; ;; Source: CLtL p. 329 ;; Chapter 21: Streams Section 21-2: Creating New Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>21-2-make-broadcast-stream.test ;; ;; ;; Syntax: make-broadcast-stream streams ;; ;; Function Description: This returns a stream that only works in the output direction. Any output sent to this stream will be sent to all of the streams given. The set of operations that may be performed on the new stream is the intersection of those for the given streams. The results returned by a stream operation are the values resulting from performing the operation on the last stream in streams, the results of performing the operation on all preceding streams are discarded. If no streams are given as arguments, then the result is a "bit sink"; all output to the resulting stream is discarded. ;; ;; Argument(s): stream(s) ;; ;; Returns: stream ;; (do-test-group (make-broadcast-stream-test :before (test-setq output-streams (mapcar #'(lambda (stream-name) (open stream-name :direction :output :if-exists :new-version :if-does-not-exist :create)) stream-sink-names)) :after (progn (mapcar #'close output-streams) (dolist (stream-name stream-sink-names) (delete-file (probe-file stream-name))) ;; note each of the following tests must be done in ;; sequence )) (do-test make-broadcast-stream-creation-test (test-setq astream (apply #'make-broadcast-stream output-streams))) (do-test make-broadcast-stream-list-test (expect-errors (error) (make-broadcast-stream '(some random list)))) (do-test make-broadcast-stream-output-test (output-test astream)) (do-test make-broadcast-stream-results-test (mapcar #'close output-streams) (test-setq output-streams (mapcar #'open stream-sink-names)) (or (mult-input-test output-streams nil) (print-stream-error "MAKE-BROADCAST-STREAM-TEST" (namestring astream))))) ;; Function To Be Tested: make-concatenated-stream ;; ;; Source: CLtL p. 329 ;; Chapter 21: Streams Section 21-2: Creating New Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> n MonthName << 86 ;; ;; Filed As: {eris}cml>test>21-2-make-concatenated-stream.test ;; ;; ;; Syntax: make-concatenated-stream &rest streams ;; ;; Function Description: This returns a stream that only works in the inut direction. Input is taken from the first of the streams until it reaches end-of-file; then that stream is discarded, and input is taken from the next of the streams, and so on. If no arguments are given, the result is a stream with no content; any input attempt will result in end-of-file. ;; ;; Argument(s): streams ;; ;; Returns: stream ;; (do-test-group "make-concatenated-stream" (do-test make-concatenated-stream-simple-test (setq astream (open "test" :direction :output :if-exists :new-version :if-does-not-exist :create)) (output-test astream) (setq original-stream (open "test")) (prog1 (and (setq astream (make-concatenated-stream original-stream)) (input-test astream)) (close original-stream) (close astream) ; just in case (delete-file (probe-file "test")))) (do-test make-concatenated-stream-string-test (setq original-stream (make-string-input-stream test-string)) (and (setq astream (make-concatenated-stream original-stream)) (input-test astream))) (do-test "MAKE-CONCATENATED-STREAM" (setq input-streams (setup-input-streams stream-io-names)) (prog1 (and (setq concatenated-stream (apply #'make-concatenated-stream input-streams)) (dolist (astream input-streams t) (or (input-test concatenated-stream :keep-open t :dont-test-for-eof t) (print-stream-error "MAKE-CONCATENATED-STREAM" (namestring astream)))) (close concatenated-stream)) (mapcar #'close input-streams) (dolist (stream-name input-streams) (delete-file (probe-file stream-name))))) (do-test make-concatenated-stream-closed-test (and (close (setq closed.file.stream (open "emptyfile" :direction :output :if-exists :new-version :if-does-not-exist :create))) (delete-file (probe-file "emptyfile")) (setq concatenated-stream (make-concatenated-stream closed.file.stream)) (expect-errors (error) (read-char closed.file.stream)) (expect-errors (error) (close concatenated-stream)))) (do-test make-concatenated-stream-empty-test (and (setq empty-stream (make-concatenated-stream)) (read empty-stream nil t) (close empty-stream))) (do-test make-concatenated-stream-string-test (setq astream (make-string-input-stream test-string)) (and (setq concatenated-stream (make-concatenated-stream astream)) (input-test astream)))) ;; Function To Be Tested: make-two-way-stream ;; ;; Source: CLtL p. 329 ;; Chapter 21: Streams Section 21-2: Creating New Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> n MonthName << 86 ;; ;; Filed As: {eris}cml>test>21-2-make-two-way-stream.test ;; ;; ;; Syntax: make-two-way-stream input-stream output-stream ;; ;; Function Description: This returns a bidirectional strem that gets its input from input-stream and sends its output to output-stream. ;; ;; Argument(s): input-stream output-stream ;; ;; Returns: stream ;; (do-test-group "make-two-way-stream" (do-test make-two-way-stream-file-test (dolist (stream-name stream-io-names t) (test-setq instream (open stream-name :direction :output :if-exists :new-version :if-does-not-exist :create)) (output-test instream) (test-setq instream (open instream)) (test-setq outstream (open "testout" :direction :output :if-exists :new-version :if-does-not-exist :create)) (unless (prog1 (and (test-setq two-way-stream (make-two-way-stream instream outstream)) (streamp two-way-stream) (input-stream-p two-way-stream) (output-stream-p two-way-stream) (equal (read two-way-stream) 'hello) (print "it works" two-way-stream) (expect-errors (end-of-file) (read two-way-stream)) (close two-way-stream) ;; should instream and outstream be ;; closed? if so, should test here ) (close instream) (close outstream) (delete-file stream-name) (delete-file (probe-file "testout"))) (print-stream-error "make-two-way-stream-file-test" stream-name)))) (do-test make-two-way-stream-string-test (test-setq astream (make-string-input-stream test-string)) (test-setq bstream (make-string-output-stream)) (and (test-setq two-way-stream (make-two-way-stream astream bstream)) (streamp two-way-stream) (output-stream-p two-way-stream) (input-test two-way-stream :keep-open t) (prin1 'garbage two-way-stream) (string-equal "garbage" (get-output-stream-string bstream)) (close two-way-stream) (close astream) (close bstream))) (do-test make-two-way-stream-closed-test (test-setq astream (make-string-input-stream test-string)) (close (test-setq closed.file.stream (open "emptyfile" :direction :output :if-exists :new-version :if-does-not-exist :create))) (delete-file (probe-file "emptyfile")) (and (test-setq two-way-stream (make-two-way-stream astream closed.file.stream)) (expect-errors (error) (print "any random thing" two-way-stream)) (close two-way-stream) (close astream))) (do-test make-two-way-stream-backwards-test (test-setq instream (make-string-input-stream test-string)) (test-setq outstream (make-string-output-stream)) (and (test-setq two-way-stream (make-two-way-stream outstream instream)) (expect-errors (error) (print "backwards" two-way-stream)) (expect-errors (error) (read two-way-stream)) (close two-way-stream) (close instream) (close outstream)))) ;; Function To Be Tested: make-echo-stream ;; ;; Source: CLtL p. 330 ;; Chapter 21: Streams Section 21-2: Creating New Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> n MonthName << 86 ;; ;; Filed As: {eris}cml>test>21-2-make-echo-stream.test ;; ;; ;; Syntax: make-echo-stream input-stream output-stream ;; ;; Function Description: This returns a bidirectional stream that gets its input from input-stream and sends its output to output-stream. In addition, all input taken from input-stream is echoed to output-stream. ;; ;; Argument(s): input-stream output-stream ;; ;; Returns: stream ;; (do-test-group "make-echo-stream" (do-test make-echo-stream-file-test (dolist (stream-name stream-io-names t) (test-setq instream (open stream-name :direction :output :if-exists :new-version :if-does-not-exist :create)) (output-test instream) (test-setq instream (open stream-name)) (test-setq outstream (open "testout" :direction :output :if-does-not-exist :create)) (unless (prog1 (and (test-setq echo-stream (make-echo-stream instream outstream)) (output-stream-p echo-stream) (input-test echo-stream :keep-open t :dont-test-for-eof t) (output-test echo-stream :keep-open t) (read echo-stream nil t) (close echo-stream) (test-setq outstream (open "testout")) (input-test outstream)) (close echo-stream) (close instream) (close outstream) (delete-file (probe-file stream-name)) (delete-file (probe-file "testout"))) (print-stream-error "make-ECHO-stream-file-test" stream-name)))) (do-test make-echo-stream-string-test ;; DEPENDS ON TEST-STRING SETUP WITH ;; STREAM PREDICATES (test-setq astream (make-string-input-stream test-string)) (test-setq bstream (make-string-output-stream)) (prog1 (and (test-setq echo-stream (make-echo-stream astream bstream)) (streamp echo-stream) (output-stream-p echo-stream) (input-test echo-stream :keep-open t) (string-equal "HELLO" (get-output-stream-string bstream)) (close echo-stream) (close astream) (close bstream)) ;; just in case (close echo-stream) (close astream) (close bstream))) (do-test make-echo-stream-closed-test (test-setq astream (make-string-input-stream test-string)) (close (test-setq closed.file.stream (open "emptyfile" :direction :output :if-exists :new-version :if-does-not-exist :create))) (delete-file (probe-file "emptyfile")) (and (test-setq echo-stream (make-echo-stream astream closed.file.stream)) (expect-errors (error) (print "any random thing" echo-stream)) (close echo-stream) (close astream)))) ;; Function To Be Tested: make-synonym-stream ;; ;; Source: CLtL p. 329 ;; Chapter 21: Streams Section 21-2: Creating New Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> n MonthName << 86 ;; ;; Filed As: {eris}cml>test>21-2-make-synonym-stream.test ;; ;; ;; Syntax: make-synonym-stream symbol ;; ;; Function Description: Creates and returns a "synonym stream." Any operations on the new stream will be performed on the stream that is then the value of the dynamic variable named by the symbol. If the value of the variable should change or be bound, then the synonym stream will operate on the new stream. ;; ;; ;; Argument(s): symbol ;; ;; Returns: stream ;; (do-test-group "make-synonym-stream" (do-test make-synonym-stream-test (dolist (stream-name stream-io-names t) (test-setq original-stream (open stream-name :direction :output :if-exists :new-version :if-does-not-exist :create)) (or (and (test-setq astream (make-synonym-stream 'original-stream)) (output-test astream)) (print-stream-error "MAKE-SYNONYM-STREAM-output-TEST" stream-name)) ;; make sure the actual stream did not get closed. (or (write "1" :stream original-stream) (print-stream-error "MAKE-SYNONYM-STREAM-output-close-TEST" stream-name)) (close original-stream) (test-setq original-stream (open stream-name)) (or (and (test-setq astream (make-synonym-stream 'original-stream)) (input-test astream :dont-test-for-eof t)) (print-stream-error "MAKE-SYNONYM-STREAM-input-TEST" stream-name)) ;; make sure the actual stream did not get closed. (or (string-equal "1" (ignore-errors (read original-stream))) (print-stream-error "MAKE-SYNONYM-STREAM-input-close-TEST" stream-name)) (close original-stream) (delete-file (probe-file stream-name)))) (do-test "MAKE-SYNONYM-STREAM with declare special" (dolist (stream-name stream-io-names t) (declare (special stream-name)) (unless (and (with-open-file (afilestream stream-name :direction :output :if-exists :new-version :if-does-not-exist :create) (declare (special afilestream)) (and (test-setq astream (make-synonym-stream 'afilestream)) (output-test astream))) (with-open-file (afilestream stream-name) (declare (special afilestream)) (and (test-setq astream (make-synonym-stream 'afilestream)) (input-test astream)))) (print-stream-error "MAKE-SYNONYM-STREAM with-open-file declare special TEST" stream-name)) (delete-file (probe-file stream-name))))) ;; Function To Be Tested: close ;; ;; Source: CLtL p. 332 ;; Chapter 21: Streams Section 21-3: Operations on Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 31 October 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>21-3-close.test ;; ;; ;; Syntax: close stream &key :abort ;; ;; Function Description: The argument must be a stream. The stream is closed. No further i/o operations may be performed on it. However, certain inquiry operations may still be performed, and it is permissible to close an already closed stream. ;; If the :abort parameter is not nil (it defaults to nil), it indicates an abnormal termination of the use of the stream. An attempt is made to clean up any side effects ofhaving created the stream in the first place. For example, if the stream performs output to a file that was newly created when the stream was created, then if possible the file is deleted and any previously existing file is not superceded. ;; ;; Argument(s): stream -- stream ;; :abort nil / t ;; ;; Returns: t always? ;; The simple case of close is tested in all the other stream tests. Here we test the abort condition. ;; (do-test-group ("close") (do-test "close abort delete output file" (dolist (stream-name stream-sink-names t) (let ((astream (open stream-name :direction :output :if-exists :new-version :if-does-not-exist :create))) (output-test astream :keep-open t) (unless (and (close astream :abort t) ;; make sure the file got deleted (expect-errors (error) (open (pathname astream)))) (print-stream-error "close abort delete output file" stream-name) (delete-file (probe-file (pathname astream))))))) (do-test "close abort input" (dolist (stream-name stream-io-names t) (let ((astream (open stream-name :direction :output :if-exists :new-version :if-does-not-exist :create))) (output-test astream)) (let ((astream (open stream-name))) (unless (and (close astream :abort t) ;; make sure the stream got closed (close (open (pathname astream) :direction :output :if-exists :append))) (print-stream-error "close abort input" stream-name)) (delete-file (probe-file (pathname astream))))))) ;; Definition To Be Tested: finish-output, force-output, and clear-output ;; ;; Source: Xerox LIsp Manual ;; Chapter 22-3-1: Input/Output Output to Character Streams ;; ;; Created By: Kirk Kelley ;; ;; Creation Date: 21 November 86 ;; ;; Last Update: >> day month << 86 ;; ;; Filed As: {eris}cml>test>22-3-1-finish-output.test ;; ;; ;; Syntax: finish-output &optional output-stream ;; ;; Function Description: The function finish-output attempts to ensure that all output sent to output-stream has reached its destination, and only then returns nil. force-output initiates the emptying of any internal buffers but returns nil without waiting for completion or acknowledgment. The function clear-output, on the other hand, attempts to abort any outstanding output operation in progress in order to allow as little output as possible to continue to the desitnation. ;; ;; Argument(s): output-stream ;; ;; Returns: nil ;; ;; These tests just test that the functions dont break for a variety of devices. It could be improved by putting out a huge string or simulating a slow channel by advising \bufferedbout (whatever its called) and do some elapsed time tests after each type of output. Then do an input-test to see if all the characters made it (or not in the case of clear-output). Try calling finish/force-output on a stream to a file server and then killing the connection. ;; (do-test "finish-output" (dolist (stream-name stream-io-names t) (with-open-file (astream stream-name :direction :output) (output-test astream :keep-open t) (finish-output astream) (close astream) (with-open-file (astream stream-name) (unless (input-test astream) (print-stream-error "finish-output" stream-name))))) ;; cleanup (dolist (stream-name stream-io-names t) (delete-file stream-name))) (do-test "clear-output" (dolist (stream-name stream-io-names t) (with-open-file (astream stream-name :direction :output) (output-test astream :keep-open t) (clear-output astream) (close astream))) ;; cleanup (dolist (stream-name stream-io-names t) (delete-file stream-name))) (do-test "force-output" (dolist (stream-name stream-io-names t) (with-open-file (astream stream-name :direction :output) (output-test astream :keep-open t) (force-output astream) (close astream) (with-open-file (astream stream-name) (unless (input-test astream) (print-stream-error "finish-output" stream-name))))) ;; cleanup (dolist (stream-name stream-io-names t) (delete-file stream-name))) STOP J(Ź(\(†( (Ł(Ś(}(ľ((ú(ł(l(’(î(v(_(o(Œ((R(=(+(œ(…(K(‹(x(d(ˆ(.(N(™(ű(Î(›(“(ä(:(‰(€(0((Ă(ó(C(1(Z(?(T(H(((J(–(z(6(((´(k(W(V(7(i({(U(‚(g(S(P(<((((G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8))M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10)) + HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8))G9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) HELVETICA HELVETICAJˆŰJJ›J *JJ.I8I6I7I3IHGF3E +D CBE +D7A@!@AA @!@A#I?I?FI?>?J%I/HG=,<'<0;&;::::&J9@8/7&6+5444+33$33<4%3333"33)33;34$33 3;4 33*33@4<4 3333(33+331339474'3333(33/33633;4=464>4>443333)34,332339484'3333(3J9=82261522,2!9,8 02#/)02A/)9,82261522!9!J3JJJ@JJJJ!JJ(JJNJJJNJJúJJ:JJ'JJ*I..@-I/.D-I/.D7,+-JQJJJ@JJJJ!JJ(JJOJJJ5JJšJJJJ'JJJIJJbJJ&JJ JJI**)I%H5G#GF?GGGF?G)GGGJ=JJJ@JJJJ!JJ&JJLJJJfJJ1JJ2J>J>JJ9JJ(I,..(I*HHK'& I-.C%;$#-J=JJJ@JJJJ!JJ&JJKJJJXJJËJJIJJ`JJ'I+H GF!#'I-H G3"!! ! I.H G3"!! ! $4J3JJJ@JJJJ!JJ&JJMJJăJJFJJ-JJI**)I&H*GGF9*F)GG23I%H6H H,GG/F(GG22J0JJJ@JJJJ!JJ&JJKJJJ8JJ`JJJJ JJI$H 0*<H'G(E(G2G I-.DI).EIBIL.=.)1(J3JJJ@JJJJ!JJ(JJNJJJAJJoJJJJ JJ*I.HG8HH%HG?GGC G$I..>.?-I$H;HG2F"3FGG$E*I..%0+-'-=/-7-6I-.4--I..6.C-J.JJJ@JJJJ!JJ(JJIJJJIJJ‰JJ,JJ JJ%I'H(G0*GG%G;GF#  !%"4#!D&F4 I).;.0.D'--!-)- -<---I).;.% 0C+.'.D2-B--I,.<.2.D*-;-.---J+JJJ@JJJJ!JJ(JJFJJJFJJÖJJ,JJ JJ"I$.(2 0C*22(2 6C +2+  +   % '   ' '&1I&H#HH;H0HG@&:G GGGI&.;.% 0C+.'.D/-?--J.JJJ@JJJJ!JJ(JJIJJJ5JJ9JJJJJ JJ%I"H(G0*GD/26G0G*F(GG/GD/+25G0G@F'GG)I4H(GGF,+ $*$F:G*J JJJAJJJJ!JJ&JJ;JJJ3JJřJŸJJ"JJJ#JhJJI*H*G;+F#F35 2IH(G;+FG F 36F2JJJJ%J=JJJJ"JJ&JJEJJJ@JJáJJJJJJĚJJI(H9#& $II(JI(9#II(JI(H9#& $I I(wĆÜzş \ No newline at end of file diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.DFASL b/internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.DFASL index 73f41b07..35acff81 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.DFASL 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 index 513115bf..7233fd01 100644 --- a/internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.TEST +++ b/internal/test/LANGUAGE/AUTO/22-1-5-COPY-READTABLE.TEST @@ -1 +1,103 @@ -;; 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 +;; 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 + 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 index 5d093244..c0f4d231 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL 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 index c99ae066..8b4bcae0 100644 --- 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 @@ -1 +1,85 @@ -;; 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 +;; 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 + 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 index 49061ee0..143d4c4f 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-1-5-GET-MACRO-CHARACTER.DFASL 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 index 7d55ddf2..533a7364 100644 --- a/internal/test/LANGUAGE/AUTO/22-1-5-GET-MACRO-CHARACTER.TEST +++ b/internal/test/LANGUAGE/AUTO/22-1-5-GET-MACRO-CHARACTER.TEST @@ -1 +1,81 @@ -;; 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 +;; 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 + + 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 index 572b506f..68021f3a 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL 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 index 8b810733..ba80c5e3 100644 --- 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 @@ -1 +1,90 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.DFASL b/internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.DFASL index e7a29899..ef40068b 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.DFASL 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 index 8999ca0e..a43481f6 100644 --- a/internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.TEST +++ b/internal/test/LANGUAGE/AUTO/22-1-5-READTABLEP.TEST @@ -1 +1,56 @@ -;; 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 +;; 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 + 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 index bf369439..4e2ab468 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL 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 index 7d82235d..b78cb053 100644 --- 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 @@ -1 +1,90 @@ -;; 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 +;; 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 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 index 9b3e2743..b34ab990 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-1-5-SET-MACRO-CHARACTER.DFASL 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 index 54ab5232..af407401 100644 --- a/internal/test/LANGUAGE/AUTO/22-1-5-SET-MACRO-CHARACTER.TEST +++ b/internal/test/LANGUAGE/AUTO/22-1-5-SET-MACRO-CHARACTER.TEST @@ -1 +1,116 @@ -;; 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 +;; 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 + + 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 index 861d7759..ede03ef2 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.DFASL 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 index a68478a3..7741f5f8 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-1-5-SET-SYNTAX-FROM-CHAR.TEST 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 index 356b0dac..f2c7bccb 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-LISTEN.DFASL 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 index ac3bbeea..75087725 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-LISTEN.TEST 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 index 64b1c42f..2a3ab164 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.DFASL 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 index c9b0a42f..fd5629a5 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-PARSE-INTEGER.TEST 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 index b528233b..25029bdc 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.DFASL 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 index 2f81f947..f232dc61 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-PEEK-CHAR.TEST 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 index a603cd0d..c7067d4b 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR-NO-HANG.DFASL 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 index d635b077..0a1084b3 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR-NO-HANG.TEST 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 index d5edee26..b726f5c2 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR.DFASL 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 index 06cf6d8d..7a1e2436 100644 --- a/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR.TEST +++ b/internal/test/LANGUAGE/AUTO/22-2-1-READ-CHAR.TEST @@ -1 +1,85 @@ -;; 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 +;; 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 + 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 index e9ada3b3..0690cdd5 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-READ-DELIMITED-LIST.DFASL 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 index ce9528ca..b167ba9a 100644 --- a/internal/test/LANGUAGE/AUTO/22-2-1-READ-DELIMITED-LIST.TEST +++ b/internal/test/LANGUAGE/AUTO/22-2-1-READ-DELIMITED-LIST.TEST @@ -1 +1,59 @@ -;; 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 +;; 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 + 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 index aaf6ce39..e3b44771 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-READ-FROM-STRING.TEST 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 index fa5ea2b4..d66fe4b5 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-READ-PRESERVING-WHITESPACE.DFASL 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 index 84631a1d..2907d0c4 100644 --- a/internal/test/LANGUAGE/AUTO/22-2-1-READ-PRESERVING-WHITESPACE.TEST +++ b/internal/test/LANGUAGE/AUTO/22-2-1-READ-PRESERVING-WHITESPACE.TEST @@ -1 +1,75 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-READ.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-READ.DFASL index ef6a5aff..aaf29d4b 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-READ.DFASL 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 index df83a9ce..df2a0278 100644 --- a/internal/test/LANGUAGE/AUTO/22-2-1-READ.TEST +++ b/internal/test/LANGUAGE/AUTO/22-2-1-READ.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.DFASL index 6024e6d7..ec3d7cfb 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.DFASL 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 index baaf68b6..a0537ad4 100644 --- a/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.TEST +++ b/internal/test/LANGUAGE/AUTO/22-2-1-UNREAD-CHAR.TEST @@ -1 +1,67 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.DFASL index 7ae5cdc1..5c7d0b9d 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.DFASL 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 index 1de5d522..df3d8981 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-FINISH-OUTPUT.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 index 7e5e6648..59729313 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-FRESH-LINE.DFASL 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 index 2ab4ad5a..f382d524 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-FRESH-LINE.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-FRESH-LINE.TEST @@ -1 +1,100 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.DFASL index 182ad503..47caf54b 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.DFASL 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 index 6398d30c..8483b58f 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-PPRINT.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 + 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 index 87392812..4b20fad4 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1-TO-STRING.DFASL 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 index c9ffe3a3..ddecfbb5 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1-TO-STRING.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1-TO-STRING.TEST @@ -1 +1,104 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.DFASL index 506b2308..bec05ef2 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.DFASL 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 index 5fbcfb26..a6763dec 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-PRIN1.TEST @@ -1 +1,85 @@ -;; 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 +;; 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 + 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 index 733874a1..e6ba80f1 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.DFASL 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 index 2bf8b3e8..1d2b311f 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-PRINC-TO-STRING.TEST @@ -1 +1,119 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRINC.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PRINC.DFASL index b01ccf24..59541789 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-PRINC.DFASL 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 index 7f8567cc..9658fdfc 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-PRINC.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-PRINC.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-PRINT.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-PRINT.DFASL index a01fe223..762f0243 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-PRINT.DFASL 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 index bfb6eb2f..aab9848f 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-PRINT.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-PRINT.TEST @@ -1 +1,92 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.DFASL index 3576b03a..0ca41af3 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.DFASL 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 index 0bc433d5..162c7f18 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-TERPRI.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.DFASL index 3c021f9c..87df1cdd 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.DFASL 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 index 7c51263a..f31fee22 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-CHAR.TEST @@ -1 +1,57 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.DFASL index a49afc60..040d0e30 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.DFASL 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 index 88fc2811..35b25859 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-LINE.TEST @@ -1 +1,114 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.DFASL b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.DFASL index 026dd632..c9ef035a 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.DFASL 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 index 95543859..78d39954 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-1-WRITE-STRING.TEST @@ -1 +1,114 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.DFASL b/internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.DFASL index e0b92d1b..2c62ecb7 100644 Binary files a/internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.DFASL 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 index 6c480bde..4689b30a 100644 --- a/internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.TEST +++ b/internal/test/LANGUAGE/AUTO/22-3-3-FORMAT.TEST @@ -1 +1,607 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.TEST b/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.TEST index 03a87c48..88366f41 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.TEST +++ b/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.TEST @@ -1 +1,111 @@ -;; 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 +;; 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 index 96439b8e..067c60b9 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-MAKE-PATHNAME.X @@ -1 +1,93 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-MERGE-PATHNAME.X b/internal/test/LANGUAGE/AUTO/23-1-2-MERGE-PATHNAME.X index 2b549251..d437eacd 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-MERGE-PATHNAME.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-MERGE-PATHNAME.X @@ -1 +1,78 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-NAMESTRING.X b/internal/test/LANGUAGE/AUTO/23-1-2-NAMESTRING.X index 89590449..4df27466 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-NAMESTRING.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-NAMESTRING.X @@ -1 +1,116 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PARSE-NAMESTRING.X b/internal/test/LANGUAGE/AUTO/23-1-2-PARSE-NAMESTRING.X index ca07f46a..21b4958c 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-PARSE-NAMESTRING.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PARSE-NAMESTRING.X @@ -1 +1,148 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DEVICE.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DEVICE.X index 7fc34957..b22c50bb 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DEVICE.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DEVICE.X @@ -1 +1,79 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DIRECTORY.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DIRECTORY.X index 5a8a3b2a..e1712344 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DIRECTORY.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-DIRECTORY.X @@ -1 +1,183 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-HOST.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-HOST.X index dea52dd5..2d09cd13 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-HOST.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-HOST.X @@ -1 +1,201 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-NAME.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-NAME.X index 483648a7..6b939e96 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-NAME.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-NAME.X @@ -1 +1,133 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-TYPE.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-TYPE.X index cf47c8e2..c784fa10 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-TYPE.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-TYPE.X @@ -1 +1,120 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-VERSION.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-VERSION.X index b95e6135..b2f15300 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-VERSION.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME-VERSION.X @@ -1 +1,105 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME.X index 595ace2a..a9c92e7c 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAME.X @@ -1 +1,80 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAMEP.X b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAMEP.X index c2aae103..6ccb5968 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAMEP.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-PATHNAMEP.X @@ -1 +1,120 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-1-2-TRUENAME.X b/internal/test/LANGUAGE/AUTO/23-1-2-TRUENAME.X index 356d4e7d..13937602 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-TRUENAME.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-TRUENAME.X @@ -1 +1,62 @@ -;; 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 +;; 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 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 index 97e8a32a..eeaf1b77 100644 --- a/internal/test/LANGUAGE/AUTO/23-1-2-USER-HOMEDIR-PATHNAME.X +++ b/internal/test/LANGUAGE/AUTO/23-1-2-USER-HOMEDIR-PATHNAME.X @@ -1 +1,37 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-2-OPEN.X b/internal/test/LANGUAGE/AUTO/23-2-OPEN.X index 0c48fea4..3101458d 100644 --- a/internal/test/LANGUAGE/AUTO/23-2-OPEN.X +++ b/internal/test/LANGUAGE/AUTO/23-2-OPEN.X @@ -1 +1,88 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-2-WITH-OPEN-FILE.X b/internal/test/LANGUAGE/AUTO/23-2-WITH-OPEN-FILE.X index fbded6be..d606de9f 100644 --- a/internal/test/LANGUAGE/AUTO/23-2-WITH-OPEN-FILE.X +++ b/internal/test/LANGUAGE/AUTO/23-2-WITH-OPEN-FILE.X @@ -1 +1,96 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-3-DELETE-FILE.X b/internal/test/LANGUAGE/AUTO/23-3-DELETE-FILE.X index 83445c26..a9423129 100644 --- a/internal/test/LANGUAGE/AUTO/23-3-DELETE-FILE.X +++ b/internal/test/LANGUAGE/AUTO/23-3-DELETE-FILE.X @@ -1 +1,116 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-3-FILE-AUTHOR.X b/internal/test/LANGUAGE/AUTO/23-3-FILE-AUTHOR.X index e5eddf73..6a303fbf 100644 --- a/internal/test/LANGUAGE/AUTO/23-3-FILE-AUTHOR.X +++ b/internal/test/LANGUAGE/AUTO/23-3-FILE-AUTHOR.X @@ -1 +1,87 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-3-FILE-LENGTH.X b/internal/test/LANGUAGE/AUTO/23-3-FILE-LENGTH.X index e1112d42..77514b1d 100644 --- a/internal/test/LANGUAGE/AUTO/23-3-FILE-LENGTH.X +++ b/internal/test/LANGUAGE/AUTO/23-3-FILE-LENGTH.X @@ -1 +1,107 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-3-FILE-POSITION.X b/internal/test/LANGUAGE/AUTO/23-3-FILE-POSITION.X index 1741b057..82264f6c 100644 --- a/internal/test/LANGUAGE/AUTO/23-3-FILE-POSITION.X +++ b/internal/test/LANGUAGE/AUTO/23-3-FILE-POSITION.X @@ -1 +1,110 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-3-FILE-WRITE-DATE.X b/internal/test/LANGUAGE/AUTO/23-3-FILE-WRITE-DATE.X index e406446e..12fc9ca8 100644 --- a/internal/test/LANGUAGE/AUTO/23-3-FILE-WRITE-DATE.X +++ b/internal/test/LANGUAGE/AUTO/23-3-FILE-WRITE-DATE.X @@ -1 +1,114 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-3-PROBE-FILE.X b/internal/test/LANGUAGE/AUTO/23-3-PROBE-FILE.X index 0c4c9141..c8542ec6 100644 --- a/internal/test/LANGUAGE/AUTO/23-3-PROBE-FILE.X +++ b/internal/test/LANGUAGE/AUTO/23-3-PROBE-FILE.X @@ -1 +1,143 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-3-RENAME-FILE.X b/internal/test/LANGUAGE/AUTO/23-3-RENAME-FILE.X index b1842f4f..28b2f433 100644 --- a/internal/test/LANGUAGE/AUTO/23-3-RENAME-FILE.X +++ b/internal/test/LANGUAGE/AUTO/23-3-RENAME-FILE.X @@ -1 +1,142 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-4-LOAD.X b/internal/test/LANGUAGE/AUTO/23-4-LOAD.X index efae9ef0..8ec1e90b 100644 --- a/internal/test/LANGUAGE/AUTO/23-4-LOAD.X +++ b/internal/test/LANGUAGE/AUTO/23-4-LOAD.X @@ -1 +1,64 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-5-DIRECTORY.X b/internal/test/LANGUAGE/AUTO/23-5-DIRECTORY.X index 3095dd91..a033222e 100644 --- a/internal/test/LANGUAGE/AUTO/23-5-DIRECTORY.X +++ b/internal/test/LANGUAGE/AUTO/23-5-DIRECTORY.X @@ -1 +1,71 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/23-FUNCTIONS b/internal/test/LANGUAGE/AUTO/23-FUNCTIONS index a9d00161..1d421667 100644 --- a/internal/test/LANGUAGE/AUTO/23-FUNCTIONS +++ b/internal/test/LANGUAGE/AUTO/23-FUNCTIONS @@ -1 +1,1196 @@ -(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 +(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 diff --git a/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DEF b/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DEF index 03633f89..62ee4d4f 100644 --- a/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DEF +++ b/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DEF @@ -1 +1,206 @@ -;; 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 +;; 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)) + diff --git a/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DFASL b/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DFASL index b152cd21..3cd9f2f0 100644 Binary files a/internal/test/LANGUAGE/AUTO/23-FUNCTIONS.DFASL 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 index 19d14e50..4e7641c0 100644 Binary files a/internal/test/LANGUAGE/AUTO/24-1-BREAK.DFASL 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 index ecedf8b4..23f16332 100644 --- a/internal/test/LANGUAGE/AUTO/24-1-BREAK.TEST +++ b/internal/test/LANGUAGE/AUTO/24-1-BREAK.TEST @@ -1 +1,96 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/24-1-CERROR.DFASL b/internal/test/LANGUAGE/AUTO/24-1-CERROR.DFASL index 305bee87..695dd306 100644 Binary files a/internal/test/LANGUAGE/AUTO/24-1-CERROR.DFASL 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 index 685963ab..92650881 100644 --- a/internal/test/LANGUAGE/AUTO/24-1-CERROR.TEST +++ b/internal/test/LANGUAGE/AUTO/24-1-CERROR.TEST @@ -1 +1,140 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/24-1-CHECK-TYPE.TEST b/internal/test/LANGUAGE/AUTO/24-1-CHECK-TYPE.TEST index d69b96ba..0cceb4a4 100644 --- a/internal/test/LANGUAGE/AUTO/24-1-CHECK-TYPE.TEST +++ b/internal/test/LANGUAGE/AUTO/24-1-CHECK-TYPE.TEST @@ -1 +1,122 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/24-1-ERROR.DFASL b/internal/test/LANGUAGE/AUTO/24-1-ERROR.DFASL index e2872f60..6b686769 100644 Binary files a/internal/test/LANGUAGE/AUTO/24-1-ERROR.DFASL 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 index 2b3299b9..34b022c6 100644 --- a/internal/test/LANGUAGE/AUTO/24-1-ERROR.TEST +++ b/internal/test/LANGUAGE/AUTO/24-1-ERROR.TEST @@ -1 +1,61 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/24-1-WARN.DFASL b/internal/test/LANGUAGE/AUTO/24-1-WARN.DFASL index b8223d41..4a8410c4 100644 Binary files a/internal/test/LANGUAGE/AUTO/24-1-WARN.DFASL 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 index d44b458a..6db1180e 100644 --- a/internal/test/LANGUAGE/AUTO/24-1-WARN.TEST +++ b/internal/test/LANGUAGE/AUTO/24-1-WARN.TEST @@ -1 +1,84 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/24-2-ASSERT.DFASL b/internal/test/LANGUAGE/AUTO/24-2-ASSERT.DFASL index 373d67f9..9799d798 100644 Binary files a/internal/test/LANGUAGE/AUTO/24-2-ASSERT.DFASL 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 index 951a7605..e16f5b71 100644 --- a/internal/test/LANGUAGE/AUTO/24-2-ASSERT.TEST +++ b/internal/test/LANGUAGE/AUTO/24-2-ASSERT.TEST @@ -1 +1,111 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/24-3-CCASE.DFASL b/internal/test/LANGUAGE/AUTO/24-3-CCASE.DFASL index 4809f1cc..f48a153a 100644 Binary files a/internal/test/LANGUAGE/AUTO/24-3-CCASE.DFASL 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 index 32af5748..2cbf1830 100644 --- a/internal/test/LANGUAGE/AUTO/24-3-CCASE.TEST +++ b/internal/test/LANGUAGE/AUTO/24-3-CCASE.TEST @@ -1 +1,74 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.DFASL b/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.DFASL index ecaae617..fd898079 100644 Binary files a/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.DFASL 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 index 149819cf..4bb710a3 100644 --- a/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.TEST +++ b/internal/test/LANGUAGE/AUTO/24-3-CTYPECASE.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/24-3-ECASE.DFASL b/internal/test/LANGUAGE/AUTO/24-3-ECASE.DFASL index 4733e3fc..9e01696a 100644 Binary files a/internal/test/LANGUAGE/AUTO/24-3-ECASE.DFASL 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 index 8b8024ed..d5bc155a 100644 --- a/internal/test/LANGUAGE/AUTO/24-3-ECASE.TEST +++ b/internal/test/LANGUAGE/AUTO/24-3-ECASE.TEST @@ -1 +1,70 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.DFASL b/internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.DFASL index c623a3bf..a3e8999e 100644 Binary files a/internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.DFASL 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 index f46afc84..f35b7a49 100644 --- a/internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.TEST +++ b/internal/test/LANGUAGE/AUTO/24-3-ETYPECASE.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/24-ERRORSYSTEM.X b/internal/test/LANGUAGE/AUTO/24-ERRORSYSTEM.X index 4fbd6736..9c8a6f1b 100644 --- a/internal/test/LANGUAGE/AUTO/24-ERRORSYSTEM.X +++ b/internal/test/LANGUAGE/AUTO/24-ERRORSYSTEM.X @@ -1,735 +1,5 @@ -;; 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 +;; 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 index 21330442..e25970b6 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-1-COMPILE-FILE.DFASL 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 index f361e8e2..18675333 100644 --- a/internal/test/LANGUAGE/AUTO/25-1-COMPILE-FILE.TEST +++ b/internal/test/LANGUAGE/AUTO/25-1-COMPILE-FILE.TEST @@ -1 +1,107 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/25-1-COMPILE.DFASL b/internal/test/LANGUAGE/AUTO/25-1-COMPILE.DFASL index 7d0335ee..1917d686 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-1-COMPILE.DFASL 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 index 6a57fb98..bf6bbcbb 100644 --- a/internal/test/LANGUAGE/AUTO/25-1-COMPILE.TEST +++ b/internal/test/LANGUAGE/AUTO/25-1-COMPILE.TEST @@ -1 +1,91 @@ -;; 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 +;; 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 + + + + + diff --git a/internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.DFASL b/internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.DFASL index 2652bbce..5cc353ae 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.DFASL 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 index d949c136..050113df 100644 --- a/internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.TEST +++ b/internal/test/LANGUAGE/AUTO/25-1-DISASSEMBLE.TEST @@ -1 +1,48 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.DFASL b/internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.DFASL index 05156ceb..bc5ab603 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.DFASL 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 index eab61a6f..ad603885 100644 --- a/internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.TEST +++ b/internal/test/LANGUAGE/AUTO/25-2-DOCUMENTATION.TEST @@ -1 +1,81 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.DFASL b/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.DFASL index 407fc391..dd098801 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.DFASL 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 index 5c894ca2..358529d2 100644 --- a/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.TEST +++ b/internal/test/LANGUAGE/AUTO/25-3-APROPOS-LIST.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/25-3-APROPOS.DFASL b/internal/test/LANGUAGE/AUTO/25-3-APROPOS.DFASL index 3c468513..67bc0597 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-3-APROPOS.DFASL 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 index f5e077bb..356fbe4f 100644 --- a/internal/test/LANGUAGE/AUTO/25-3-APROPOS.TEST +++ b/internal/test/LANGUAGE/AUTO/25-3-APROPOS.TEST @@ -1 +1,59 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.DFASL b/internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.DFASL index 30effa98..0e995d95 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.DFASL 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 index 0f9e585a..dfabac45 100644 --- a/internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.TEST +++ b/internal/test/LANGUAGE/AUTO/25-3-DESCRIBE.TEST @@ -1 +1,92 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.DFASL b/internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.DFASL index 9a610f4a..c97d491e 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.DFASL 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 index 6729c282..4fca3a71 100644 --- a/internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.TEST +++ b/internal/test/LANGUAGE/AUTO/25-3-DRIBBLE.TEST @@ -1 +1,70 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/25-3-ED.DFASL b/internal/test/LANGUAGE/AUTO/25-3-ED.DFASL index 11c0d959..a8479285 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-3-ED.DFASL 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 index 40467198..b44bc0df 100644 --- a/internal/test/LANGUAGE/AUTO/25-3-ED.TEST +++ b/internal/test/LANGUAGE/AUTO/25-3-ED.TEST @@ -1 +1,42 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/25-3-INSPECT.DFASL b/internal/test/LANGUAGE/AUTO/25-3-INSPECT.DFASL index 55d58378..96241f23 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-3-INSPECT.DFASL 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 index ae01316a..564b107c 100644 --- a/internal/test/LANGUAGE/AUTO/25-3-INSPECT.TEST +++ b/internal/test/LANGUAGE/AUTO/25-3-INSPECT.TEST @@ -1 +1,43 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/25-3-ROOM.DFASL b/internal/test/LANGUAGE/AUTO/25-3-ROOM.DFASL index 23117622..d3b0d776 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-3-ROOM.DFASL 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 index ae0f49f1..aaf2699e 100644 --- a/internal/test/LANGUAGE/AUTO/25-3-ROOM.TEST +++ b/internal/test/LANGUAGE/AUTO/25-3-ROOM.TEST @@ -1 +1,99 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/25-3-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-3-TIME.DFASL index da40ef37..55a0fbd9 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-3-TIME.DFASL 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 index 9dea99cd..18afad2c 100644 --- a/internal/test/LANGUAGE/AUTO/25-3-TIME.TEST +++ b/internal/test/LANGUAGE/AUTO/25-3-TIME.TEST @@ -1 +1,43 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.DFASL index c57c6332..f70139b0 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.DFASL 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 index 75e3fbd1..7cabf208 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-DECODE-UNIVERSAL-TIME.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.DFASL index c81b0630..a4b675f5 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.DFASL 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 index 9a881b11..7a6aa026 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-ENCODE-UNIVERSAL-TIME.TEST @@ -1 +1,71 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.DFASL index eec97a32..00c7450f 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.DFASL 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 index 95523211..1c325b48 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-GET-DECODED-TIME.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 + + 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 index 3fe1009c..d89ff6f9 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-REAL-TIME.DFASL 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 index 33546de1..79fe1503 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-REAL-TIME.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-REAL-TIME.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 + + 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 index 1384490c..79bd1200 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-RUN-TIME.DFASL 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 index d0bd3f6d..07e5d435 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-RUN-TIME.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-GET-INTERNAL-RUN-TIME.TEST @@ -1 +1,45 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.DFASL index 390df6d3..89bbf5f8 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.DFASL 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 index 9b31f148..b5a66dd4 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-GET-UNIVERSAL-TIME.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.DFASL b/internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.DFASL index 9e2225e3..f23acaea 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.DFASL 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 index 3210deb3..e537bf9f 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-LISP-IMPLEMENTATION-VERSION.TEST @@ -1 +1,34 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.DFASL index 8181e2c4..b4cd9fff 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.DFASL 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 index a95f68df..d5a12f4c 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-LONG-SITE-NAME.TEST @@ -1 +1,33 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.DFASL b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.DFASL index 424df4b3..a241269c 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.DFASL 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 index 36b29e22..648f70a7 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-INSTANCE.TEST @@ -1 +1,34 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.DFASL b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.DFASL index a0734874..28075e81 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.DFASL 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 index 5859eafb..fb29cb96 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-TYPE.TEST @@ -1 +1,39 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.DFASL b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.DFASL index 402dccbe..14eb6bdd 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.DFASL 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 index b614cc65..aad55a92 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-MACHINE-VERSION.TEST @@ -1 +1,33 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.DFASL b/internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.DFASL index 7ff05ef3..65d2d9d4 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.DFASL 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 index 1289c09e..b6d7362e 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-SHORT-SITE-NAME.TEST @@ -1 +1,33 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-SLEEP.DFASL b/internal/test/LANGUAGE/AUTO/25-4-SLEEP.DFASL index a9a7c508..cca5f320 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-SLEEP.DFASL 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 index 9b8c2bf7..487e79dd 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-SLEEP.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-SLEEP.TEST @@ -1 +1,55 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.DFASL b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.DFASL index c1449780..7d2a7d47 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.DFASL 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 index 796b84db..afff2290 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-TYPE.TEST @@ -1 +1,34 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.DFASL b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.DFASL index f56800aa..b82aa4f1 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.DFASL 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 index 9f7df2bd..81a83cd9 100644 --- a/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.TEST +++ b/internal/test/LANGUAGE/AUTO/25-4-SOFTWARE-VERSION.TEST @@ -1 +1,33 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/25-5-IDENTITY.DFASL b/internal/test/LANGUAGE/AUTO/25-5-IDENTITY.DFASL index 9f5bf905..169c73e6 100644 Binary files a/internal/test/LANGUAGE/AUTO/25-5-IDENTITY.DFASL 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 index 7ce2612d..189692f5 100644 --- a/internal/test/LANGUAGE/AUTO/25-5-IDENTITY.TEST +++ b/internal/test/LANGUAGE/AUTO/25-5-IDENTITY.TEST @@ -1 +1,54 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/4-7-DEFTYPE.TEST b/internal/test/LANGUAGE/AUTO/4-7-DEFTYPE.TEST index f7dff256..4dbf21f7 100644 --- a/internal/test/LANGUAGE/AUTO/4-7-DEFTYPE.TEST +++ b/internal/test/LANGUAGE/AUTO/4-7-DEFTYPE.TEST @@ -1 +1,144 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/4-8-COERCE.DFASL b/internal/test/LANGUAGE/AUTO/4-8-COERCE.DFASL index 28ae008b..a5af9b07 100644 Binary files a/internal/test/LANGUAGE/AUTO/4-8-COERCE.DFASL 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 index 1a67285e..4edb3f22 100644 --- a/internal/test/LANGUAGE/AUTO/4-8-COERCE.TEST +++ b/internal/test/LANGUAGE/AUTO/4-8-COERCE.TEST @@ -1 +1,123 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.DFASL b/internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.DFASL index c1ede303..a9ea8edb 100644 Binary files a/internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.DFASL 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 index c02a3ecf..d3ae4301 100644 --- a/internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.TEST +++ b/internal/test/LANGUAGE/AUTO/4-9-TYPE-OF.TEST @@ -1 +1,59 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.DFASL b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.DFASL index 11384d54..c0030d01 100644 Binary files a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.DFASL 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 index 4230aceb..c7978464 100644 --- a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.TEST +++ b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-EXPRESSIONS.TEST @@ -1 +1,72 @@ -;; ;; ;; 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 +;; +;; +;; 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 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 index 807f1de5..914201a0 100644 Binary files a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.DFASL 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 index 9b933fec..66b06668 100644 --- a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.TEST +++ b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-LIST-KEYWORDS.TEST @@ -1 +1,16 @@ -;; ;; 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 +;; +;; 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 index acb6eb2b..f202b72d 100644 Binary files a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL 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 index 782fc1ea..da509f0a 100644 --- a/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.TEST +++ b/internal/test/LANGUAGE/AUTO/5-2-2-LAMBDA-PARAMETERS-LIMIT.TEST @@ -1 +1,10 @@ -;; ;; 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 +;; +;; 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 index af2275b2..2cc25d39 100644 Binary files a/internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.DFASL 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 index 83a158d8..f2e5bbad 100644 --- a/internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.TEST +++ b/internal/test/LANGUAGE/AUTO/5-3-1-DEFUN.TEST @@ -1 +1,186 @@ -;; ;; 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 +;; +;; 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 + + + + + + + + diff --git a/internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.DFASL b/internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.DFASL index 39ad15ba..2fb0ffcc 100644 Binary files a/internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.DFASL 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 index 0273d57e..1c8789e9 100644 --- a/internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.TEST +++ b/internal/test/LANGUAGE/AUTO/5-3-2-DEFCONSTANT.TEST @@ -1 +1,104 @@ -;; ;; 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 +;; +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.DFASL b/internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.DFASL index c4ed2745..7052034a 100644 Binary files a/internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.DFASL 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 index 2aa62a74..3951e8fa 100644 --- a/internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.TEST +++ b/internal/test/LANGUAGE/AUTO/5-3-2-DEFPARAMETER.TEST @@ -1 +1,106 @@ -;; ;; 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 +;; +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.DFASL b/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.DFASL index 0384a4b4..8b30d9e8 100644 Binary files a/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.DFASL 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 index ba7716d6..860a7eb3 100644 --- a/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.TEST +++ b/internal/test/LANGUAGE/AUTO/5-3-2-DEFVAR.TEST @@ -1 +1,109 @@ -;; ;; 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 +;; +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.DFASL b/internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.DFASL index b451ee23..06d02b0c 100644 Binary files a/internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.DFASL 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 index 45ba62db..8c3a59c0 100644 --- a/internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.TEST +++ b/internal/test/LANGUAGE/AUTO/5-3-3-EVAL-WHEN.TEST @@ -1 +1,38 @@ -;; ;; 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 +;; +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.DFASL index 50d7da4a..9e111f70 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.DFASL 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 index 572c22a6..72534555 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-1-SUBTYPEP.TEST @@ -1 +1,182 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.DFASL index 7d08bf8f..51572a36 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.DFASL 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 index 455bfd53..113543b8 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-1-TYPEP.TEST @@ -1 +1,84 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.DFASL index 2a6f6f03..e0201509 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.DFASL 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 index 8448fdc9..0f757d6d 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-ARRAYP.TEST @@ -1 +1,146 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-ATOM.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-ATOM.DFASL index 8a1a73cf..dfce77f4 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-ATOM.DFASL 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 index 2a0045a8..a530bf63 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-ATOM.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-ATOM.TEST @@ -1 +1,103 @@ -;; 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 +;; 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 + 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 index 68e20a7f..1bb9a799 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.DFASL 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 index 265b4530..4d885d28 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-BIT-VECTOR-P.TEST @@ -1 +1,118 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.DFASL index ca66bf3d..d41a151c 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.DFASL 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 index 4252d040..108c7803 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-CHARACTERP.TEST @@ -1 +1,57 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.DFASL index 36f6dd3c..224f6138 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.DFASL 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 index 35c3d5d1..ce8bb809 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-COMMONP.TEST @@ -1 +1,60 @@ -;; 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 +;; 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 + 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 index a950f0ee..bca9c27b 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-COMPILED-FUNCTION-P.DFASL 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 index 6deee8a7..d521b1ba 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-COMPILED-FUNCTION-P.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-COMPILED-FUNCTION-P.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.DFASL index c5a98ea5..860b15aa 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.DFASL 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 index 316f9ded..322c7c5d 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-COMPLEXP.TEST @@ -1 +1,102 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-CONSP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-CONSP.DFASL index ef5b15fa..b9f9d839 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-CONSP.DFASL 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 index 1c6aae22..d7c1fabc 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-CONSP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-CONSP.TEST @@ -1 +1,105 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.DFASL index 3d4d31e4..2ae00c2c 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.DFASL 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 index f2f9ac82..63b559e5 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-FLOATP.TEST @@ -1 +1,83 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.DFASL index a4b52c1a..959ce35e 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.DFASL 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 index 95268732..e20005d5 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-FUNCTIONP.TEST @@ -1 +1,55 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.DFASL index fa0a9055..ed35eb93 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.DFASL 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 index 0d97222e..52a95690 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-INTEGERP.TEST @@ -1 +1,79 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-LISTP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-LISTP.DFASL index 401a7c8c..72c3ed5f 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-LISTP.DFASL 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 index 3d40c65f..1e253826 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-LISTP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-LISTP.TEST @@ -1 +1,106 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-NULL.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-NULL.DFASL index 6b1face3..d9493029 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-NULL.DFASL 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 index 5cfb068b..1d492f8b 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-NULL.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-NULL.TEST @@ -1 +1,61 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.DFASL index 83aa69b5..dea2543b 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.DFASL 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 index f5b85dc7..7294e989 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-NUMBERP.TEST @@ -1 +1,75 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.DFASL index a8c62651..cf204bd9 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.DFASL 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 index 3300d250..410c0c3a 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-PACKAGEP.TEST @@ -1 +1,63 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.DFASL index e05a3796..aabffecd 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.DFASL 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 index eecb783b..062dc815 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-RATIONALP.TEST @@ -1 +1,79 @@ -;; 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 +;; 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 + 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 index 6b0dba36..14805882 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL 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 index 9b23529a..0c98cd76 100644 --- 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 @@ -1 +1,128 @@ -;; 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 +;; 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 + 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 index f0d741f4..93038dc3 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.DFASL 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 index f19c3720..737f393c 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-STRING-P.TEST @@ -1 +1,107 @@ -;; 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 +;; 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 + 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 index 07646e28..34f05395 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.DFASL 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 index b1e1454a..ea2feaf2 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-SIMPLE-VECTOR-P.TEST @@ -1 +1,104 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.DFASL index 194281d5..56edc526 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.DFASL 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 index 4d821219..6343310d 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-STRINGP.TEST @@ -1 +1,100 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.DFASL index b0fc45b3..c6d7419d 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.DFASL 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 index e7c33dfd..f769a830 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-SYMBOLP.TEST @@ -1 +1,59 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.DFASL b/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.DFASL index bbaa70d7..22dcefae 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.DFASL 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 index 6ac4b4e7..da4fdad4 100644 --- a/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-2-2-VECTORP.TEST @@ -1 +1,124 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQ.DFASL b/internal/test/LANGUAGE/AUTO/6-3-EQ.DFASL index a475379f..ddcc78e5 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-3-EQ.DFASL 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 index a81ee2e6..95397e88 100644 --- a/internal/test/LANGUAGE/AUTO/6-3-EQ.TEST +++ b/internal/test/LANGUAGE/AUTO/6-3-EQ.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQL.DFASL b/internal/test/LANGUAGE/AUTO/6-3-EQL.DFASL index 64251c99..25e931dc 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-3-EQL.DFASL 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 index c1f9bb66..009fefb3 100644 --- a/internal/test/LANGUAGE/AUTO/6-3-EQL.TEST +++ b/internal/test/LANGUAGE/AUTO/6-3-EQL.TEST @@ -1 +1,56 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQUAL.DFASL b/internal/test/LANGUAGE/AUTO/6-3-EQUAL.DFASL index 09e05934..82e9ecae 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-3-EQUAL.DFASL 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 index 251e098c..ed8eeadf 100644 --- a/internal/test/LANGUAGE/AUTO/6-3-EQUAL.TEST +++ b/internal/test/LANGUAGE/AUTO/6-3-EQUAL.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/6-3-EQUALP.DFASL b/internal/test/LANGUAGE/AUTO/6-3-EQUALP.DFASL index 69e63f83..67e20207 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-3-EQUALP.DFASL 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 index e5243f4e..01df6a25 100644 --- a/internal/test/LANGUAGE/AUTO/6-3-EQUALP.TEST +++ b/internal/test/LANGUAGE/AUTO/6-3-EQUALP.TEST @@ -1 +1,97 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/AUTO/6-4-AND.DFASL b/internal/test/LANGUAGE/AUTO/6-4-AND.DFASL index 4a994deb..86cd1ee0 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-4-AND.DFASL 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 index e1346b77..bbfc1d13 100644 --- a/internal/test/LANGUAGE/AUTO/6-4-AND.TEST +++ b/internal/test/LANGUAGE/AUTO/6-4-AND.TEST @@ -1 +1,97 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/6-4-NOT.DFASL b/internal/test/LANGUAGE/AUTO/6-4-NOT.DFASL index 989c43eb..ebf4b196 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-4-NOT.DFASL 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 index 592eae64..543714dc 100644 --- a/internal/test/LANGUAGE/AUTO/6-4-NOT.TEST +++ b/internal/test/LANGUAGE/AUTO/6-4-NOT.TEST @@ -1 +1,44 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/6-4-OR.DFASL b/internal/test/LANGUAGE/AUTO/6-4-OR.DFASL index 5d5f9bde..2c326617 100644 Binary files a/internal/test/LANGUAGE/AUTO/6-4-OR.DFASL 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 index e2b93290..e6cdaf58 100644 --- a/internal/test/LANGUAGE/AUTO/6-4-OR.TEST +++ b/internal/test/LANGUAGE/AUTO/6-4-OR.TEST @@ -1 +1,72 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.DFASL b/internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.DFASL index 50139375..92fb01fb 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.DFASL 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 index 0be1f22d..11aebab8 100644 --- a/internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.TEST +++ b/internal/test/LANGUAGE/AUTO/7-1-1-BOUNDP.TEST @@ -1 +1,56 @@ -;; 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 +;; 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 index 0990fc2e..db1909f5 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-1-FBOUNDP.DFASL 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 index acffe6a7..ab8aa623 100644 --- a/internal/test/LANGUAGE/AUTO/7-1-1-FBOUNDP.TEST +++ b/internal/test/LANGUAGE/AUTO/7-1-1-FBOUNDP.TEST @@ -1 +1,72 @@ -;; 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 +;; 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 index 58a41f51..fd3a9ac2 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.DFASL 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 index bb86457c..2265cb03 100644 --- a/internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.TEST +++ b/internal/test/LANGUAGE/AUTO/7-1-1-FUNCTION.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 index ae6cbcb6..d4fc9bd8 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.DFASL 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 index 13dc4bc5..5bfe5473 100644 --- a/internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.TEST +++ b/internal/test/LANGUAGE/AUTO/7-1-1-QUOTE.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 index 98eb79a3..d7a27d4b 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.DFASL 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 index 6f1cdbc3..86395d46 100644 --- a/internal/test/LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.TEST +++ b/internal/test/LANGUAGE/AUTO/7-1-1-SPECIAL-FORM-P.TEST @@ -1 +1,54 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.DFASL b/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.DFASL index 72ad45d2..cbbb307c 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.DFASL 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 index 38124414..553ff9aa 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-FUNCTION.TEST 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 index d05b978a..b6694a78 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.DFASL 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 index f0404e7c..499060d4 100644 --- a/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.TEST +++ b/internal/test/LANGUAGE/AUTO/7-1-1-SYMBOL-VALUE.TEST @@ -1 +1,80 @@ -;; ;; 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 +;; +;; 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 index 0d26c282..877ab0d9 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.DFASL 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 index 316761e6..3d618562 100644 --- a/internal/test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.TEST +++ b/internal/test/LANGUAGE/AUTO/7-1-2-FMAKUNBOUND.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 index 0fd7d9d0..5b0b7810 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.DFASL 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 index ef117865..dec034a2 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-2-MAKUNBOUND.TEST 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 index dc75ea23..c1abbce5 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.DFASL 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 index 7737ac4e..c6882b6b 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-2-PSETQ.TEST 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 index 4d37a885..d4735617 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-1-2-SET.DFASL 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 index c0391b6e..824bbef4 100644 --- a/internal/test/LANGUAGE/AUTO/7-1-2-SET.TEST +++ b/internal/test/LANGUAGE/AUTO/7-1-2-SET.TEST @@ -1 +1,63 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/7-1-2-SETQ.TEST b/internal/test/LANGUAGE/AUTO/7-1-2-SETQ.TEST index 6bea2f53..0bd05221 100644 --- a/internal/test/LANGUAGE/AUTO/7-1-2-SETQ.TEST +++ b/internal/test/LANGUAGE/AUTO/7-1-2-SETQ.TEST @@ -1 +1,55 @@ -;; 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 +;; 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 index 586ddb44..955b255e 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-10-CATCH.DFASL 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 index e37d61aa..a4fc9269 100644 --- a/internal/test/LANGUAGE/AUTO/7-10-CATCH.TEST +++ b/internal/test/LANGUAGE/AUTO/7-10-CATCH.TEST @@ -1 +1,215 @@ -;; 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 +;; 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 index 771f873b..b0fee100 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-10-THROW.DFASL 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 index 8a3e8520..91b589dd 100644 --- a/internal/test/LANGUAGE/AUTO/7-10-THROW.TEST +++ b/internal/test/LANGUAGE/AUTO/7-10-THROW.TEST @@ -1 +1,35 @@ -;; 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 +;; 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 index d8bc20a0..dbf9141b 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.DFASL 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 index e062d429..fe200ecd 100644 --- a/internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.TEST +++ b/internal/test/LANGUAGE/AUTO/7-10-UNWIND-PROTECT.TEST @@ -1 +1,154 @@ -;; 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 +;; 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 index 0e32d81c..fb44f204 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-2-DEFINE-MODIFY-MACRO.DFASL 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 index f7e6d693..d7b674cc 100644 --- a/internal/test/LANGUAGE/AUTO/7-2-DEFINE-MODIFY-MACRO.TEST +++ b/internal/test/LANGUAGE/AUTO/7-2-DEFINE-MODIFY-MACRO.TEST @@ -1 +1,105 @@ -;; 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 +;; 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 index 0c64a96a..295c0efb 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.DFASL 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 index 1ece12cf..6d6f39f4 100644 --- a/internal/test/LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.TEST +++ b/internal/test/LANGUAGE/AUTO/7-2-DEFINE-SETF-METHOD.TEST @@ -1 +1,84 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/7-2-DEFSETF.DFASL b/internal/test/LANGUAGE/AUTO/7-2-DEFSETF.DFASL index 6caf8138..22e7879b 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-2-DEFSETF.DFASL 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 index 81070a18..934edfeb 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-2-DEFSETF.TEST 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 index 87697dd3..1e5bd12d 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL 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 index 87ab1d32..ff901a34 100644 --- 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 @@ -1 +1,65 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.DFASL b/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.DFASL index a69f35f1..858e1e7b 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.DFASL 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 index 9eea1d27..7cf1e4a9 100644 --- a/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.TEST +++ b/internal/test/LANGUAGE/AUTO/7-2-GET-SETF-METHOD.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/7-2-PSETF.DFASL b/internal/test/LANGUAGE/AUTO/7-2-PSETF.DFASL index 659e61dd..b65a13d9 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-2-PSETF.DFASL 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 index cdcc2bae..8ab7c2af 100644 --- a/internal/test/LANGUAGE/AUTO/7-2-PSETF.TEST +++ b/internal/test/LANGUAGE/AUTO/7-2-PSETF.TEST @@ -1 +1,977 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.DFASL b/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.DFASL index 68cdc1bc..f89a816f 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.DFASL 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 index 9b3b2897..2eb6af0c 100644 --- a/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.TEST +++ b/internal/test/LANGUAGE/AUTO/7-2-ROTATEF.TEST @@ -1 +1,855 @@ -;; 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 +;; 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 + + + + + + diff --git a/internal/test/LANGUAGE/AUTO/7-2-SETF.DFASL b/internal/test/LANGUAGE/AUTO/7-2-SETF.DFASL index 298e4fe2..7b67205f 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-2-SETF.DFASL 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 index 8498c888..debf2edf 100644 --- a/internal/test/LANGUAGE/AUTO/7-2-SETF.TEST +++ b/internal/test/LANGUAGE/AUTO/7-2-SETF.TEST @@ -1 +1,385 @@ -(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 +(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 + diff --git a/internal/test/LANGUAGE/AUTO/7-2-SHIFTF.DFASL b/internal/test/LANGUAGE/AUTO/7-2-SHIFTF.DFASL index 7d4d6392..93139207 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-2-SHIFTF.DFASL 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 index 297eecb0..9fe1b06d 100644 --- a/internal/test/LANGUAGE/AUTO/7-2-SHIFTF.TEST +++ b/internal/test/LANGUAGE/AUTO/7-2-SHIFTF.TEST @@ -1 +1,428 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/7-3-APPLY.DFASL b/internal/test/LANGUAGE/AUTO/7-3-APPLY.DFASL index 71469a66..7d205a84 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-3-APPLY.DFASL 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 index c86dcb98..3d74ac11 100644 --- a/internal/test/LANGUAGE/AUTO/7-3-APPLY.TEST +++ b/internal/test/LANGUAGE/AUTO/7-3-APPLY.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 index 837eb021..86bd731b 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.DFASL 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 index bb4a6369..a383f4ec 100644 --- a/internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.TEST +++ b/internal/test/LANGUAGE/AUTO/7-3-CALL-ARGUMENTS-LIMIT.TEST @@ -1 +1,31 @@ -;; 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 +;; 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 index 0749e3f2..62a00206 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-3-FUNCALL.DFASL 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 index 8cf341d0..e387d9d9 100644 --- a/internal/test/LANGUAGE/AUTO/7-3-FUNCALL.TEST +++ b/internal/test/LANGUAGE/AUTO/7-3-FUNCALL.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 index 56335ae1..374001d1 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-4-PROG1.DFASL 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 index 455fb2b3..a3070d2b 100644 --- a/internal/test/LANGUAGE/AUTO/7-4-PROG1.TEST +++ b/internal/test/LANGUAGE/AUTO/7-4-PROG1.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 index 36ed2de8..e0661aac 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-4-PROG2.DFASL 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 index fc6e1f1c..48e4bde5 100644 --- a/internal/test/LANGUAGE/AUTO/7-4-PROG2.TEST +++ b/internal/test/LANGUAGE/AUTO/7-4-PROG2.TEST @@ -1 +1,43 @@ -;; 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 +;; 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 index 3b290f27..adedf42c 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-4-PROGN.DFASL 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 index 96e92f36..d37f7d0e 100644 --- a/internal/test/LANGUAGE/AUTO/7-4-PROGN.TEST +++ b/internal/test/LANGUAGE/AUTO/7-4-PROGN.TEST @@ -1 +1,50 @@ -;; 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 +;; 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 index 0cba7a15..21859193 100644 --- a/internal/test/LANGUAGE/AUTO/7-5-COMPILER-LET.TEST +++ b/internal/test/LANGUAGE/AUTO/7-5-COMPILER-LET.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 index bde2c130..3e634c0c 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-5-FLET.DFASL 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 index bbbdca3d..c77a4cd9 100644 --- a/internal/test/LANGUAGE/AUTO/7-5-FLET.TEST +++ b/internal/test/LANGUAGE/AUTO/7-5-FLET.TEST @@ -1 +1,136 @@ -;; 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 +;; 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 index 0d97e0f9..155340d9 100644 --- a/internal/test/LANGUAGE/AUTO/7-5-LABELS.TEST +++ b/internal/test/LANGUAGE/AUTO/7-5-LABELS.TEST @@ -1 +1,206 @@ -;; 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 +;; 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 index 39cd1c77..f854ccfe 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-5-LET.DFASL 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 index 9c7249d5..d524034d 100644 --- a/internal/test/LANGUAGE/AUTO/7-5-LET.TEST +++ b/internal/test/LANGUAGE/AUTO/7-5-LET.TEST @@ -1 +1,114 @@ -;; 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 +;; 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 index 84a5d023..fca261d2 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-5-LETSTAR.DFASL 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 index 9a9d42bc..a50f6a93 100644 --- a/internal/test/LANGUAGE/AUTO/7-5-LETSTAR.TEST +++ b/internal/test/LANGUAGE/AUTO/7-5-LETSTAR.TEST @@ -1 +1,114 @@ -;; 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 +;; 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 index 62082c99..6a6cf1a3 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-5-MACROLET.DFASL 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 index b3fb6180..fa3195d9 100644 --- a/internal/test/LANGUAGE/AUTO/7-5-MACROLET.TEST +++ b/internal/test/LANGUAGE/AUTO/7-5-MACROLET.TEST @@ -1 +1,244 @@ -;; 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 +;; 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 index 992be3ba..9ff0422e 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-5-PROGV.DFASL 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 index 9113ff90..771f6510 100644 --- a/internal/test/LANGUAGE/AUTO/7-5-PROGV.TEST +++ b/internal/test/LANGUAGE/AUTO/7-5-PROGV.TEST @@ -1 +1,104 @@ -;; 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 +;; 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 index 4d50ba83..3b0e50fb 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-6-CASE.DFASL 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 index 143034d0..6b5c7295 100644 --- a/internal/test/LANGUAGE/AUTO/7-6-CASE.TEST +++ b/internal/test/LANGUAGE/AUTO/7-6-CASE.TEST @@ -1 +1,141 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-6-COND.DFASL b/internal/test/LANGUAGE/AUTO/7-6-COND.DFASL index 0f38f99e..edf9d029 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-6-COND.DFASL 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 index 0e49b57b..8928e046 100644 --- a/internal/test/LANGUAGE/AUTO/7-6-COND.TEST +++ b/internal/test/LANGUAGE/AUTO/7-6-COND.TEST @@ -1 +1,124 @@ -;; 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 +;; 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 index c1f68434..f05c8fd8 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-6-IF.DFASL 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 index 4a3fb4c9..365cd772 100644 --- a/internal/test/LANGUAGE/AUTO/7-6-IF.TEST +++ b/internal/test/LANGUAGE/AUTO/7-6-IF.TEST @@ -1 +1,150 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-6-TYPECASE.DFASL b/internal/test/LANGUAGE/AUTO/7-6-TYPECASE.DFASL index bbb3b82f..bca0fbc5 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-6-TYPECASE.DFASL 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 index 17978ed5..9fab75a2 100644 --- a/internal/test/LANGUAGE/AUTO/7-6-TYPECASE.TEST +++ b/internal/test/LANGUAGE/AUTO/7-6-TYPECASE.TEST @@ -1 +1,228 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-6-UNLESS.DFASL b/internal/test/LANGUAGE/AUTO/7-6-UNLESS.DFASL index 1492a14c..d1d87fc3 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-6-UNLESS.DFASL 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 index 0d0ea169..62dacd53 100644 --- a/internal/test/LANGUAGE/AUTO/7-6-UNLESS.TEST +++ b/internal/test/LANGUAGE/AUTO/7-6-UNLESS.TEST @@ -1 +1,144 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-6-WHEN.DFASL b/internal/test/LANGUAGE/AUTO/7-6-WHEN.DFASL index 74efc0cf..3205edf5 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-6-WHEN.DFASL 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 index f4c37669..a0528c1e 100644 --- a/internal/test/LANGUAGE/AUTO/7-6-WHEN.TEST +++ b/internal/test/LANGUAGE/AUTO/7-6-WHEN.TEST @@ -1 +1,142 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-7-BLOCK.TEST b/internal/test/LANGUAGE/AUTO/7-7-BLOCK.TEST index cfbc9f8f..ac10166c 100644 --- a/internal/test/LANGUAGE/AUTO/7-7-BLOCK.TEST +++ b/internal/test/LANGUAGE/AUTO/7-7-BLOCK.TEST @@ -1 +1,120 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.DFASL b/internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.DFASL index e334df32..ce08f1ac 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.DFASL 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 index 5ea67b9d..4b94d65a 100644 --- a/internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.TEST +++ b/internal/test/LANGUAGE/AUTO/7-7-RETURN-FROM.TEST @@ -1 +1,212 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/7-7-RETURN.DFASL b/internal/test/LANGUAGE/AUTO/7-7-RETURN.DFASL index bf9496a1..5123f735 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-7-RETURN.DFASL 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 index 494b6a41..d9432650 100644 --- a/internal/test/LANGUAGE/AUTO/7-7-RETURN.TEST +++ b/internal/test/LANGUAGE/AUTO/7-7-RETURN.TEST @@ -1 +1,134 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/AUTO/7-8-1-LOOP.DFASL b/internal/test/LANGUAGE/AUTO/7-8-1-LOOP.DFASL index 22a10022..08ebac9c 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-1-LOOP.DFASL 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 index 2afdbd89..3916c36f 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-1-LOOP.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-1-LOOP.TEST @@ -1 +1,181 @@ -;; 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 +;; 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 index f3046468..e4f33c03 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-2-DO.DFASL 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 index a0f230e1..655ba73f 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-2-DO.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-2-DO.TEST @@ -1 +1,173 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.DFASL b/internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.DFASL index 23394660..ff072e48 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.DFASL 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 index 087657d3..bcf16dbc 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-2-DOSTAR.TEST @@ -1 +1,169 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.DFASL b/internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.DFASL index d5b0273a..49b43246 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.DFASL 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 index 16112402..5d868adb 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-3-DOLIST.TEST @@ -1 +1,169 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.DFASL b/internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.DFASL index 6624bf74..c1922702 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.DFASL 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 index 9a7db00e..f3b8b143 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-3-DOTIMES.TEST @@ -1 +1,195 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPC.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPC.DFASL index bdd73131..fb4081b8 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-4-MAPC.DFASL 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 index 1324a254..7e55059a 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-4-MAPC.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPC.TEST @@ -1 +1,170 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.DFASL index b4e27223..94ff4a7b 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.DFASL 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 index 5aaa6a64..ac7b2021 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAN.TEST @@ -1 +1,114 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.DFASL index 631f08d0..6466e94c 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.DFASL 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 index 46a4002e..50b7e585 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCAR.TEST @@ -1 +1,162 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.DFASL index 6ac055d2..8c96ef04 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.DFASL 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 index fa811802..998ed7eb 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPCON.TEST @@ -1 +1,116 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPL.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPL.DFASL index aec2214e..ff274a3c 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-4-MAPL.DFASL 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 index 5f4d4455..aca4cc07 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-4-MAPL.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPL.TEST @@ -1 +1,154 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.DFASL index 7f9dc3e7..181e6077 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.DFASL 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 index bbe93d9b..52b77ce4 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPLIST.TEST @@ -1 +1,135 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.DFASL b/internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.DFASL index e2da1955..4a1c1a86 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.DFASL 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 index 34766631..7c47307c 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-4-MAPPER.TEST @@ -1 +1,179 @@ -(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 +(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 diff --git a/internal/test/LANGUAGE/AUTO/7-8-5-GO.DFASL b/internal/test/LANGUAGE/AUTO/7-8-5-GO.DFASL index ee050df1..2ea34737 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-5-GO.DFASL 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 index 5fff190c..b2a7a60d 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-5-GO.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-5-GO.TEST @@ -1 +1,29 @@ -;; 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 +;; 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 index 79b8283d..2ca6d934 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-5-PROG.DFASL 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 index 5f0c3df4..6de66514 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-5-PROG.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-5-PROG.TEST @@ -1 +1,164 @@ -;; 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 +;; 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 + + + + + + + + + + diff --git a/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.DFASL b/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.DFASL index 8907c505..bc7f6749 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.DFASL 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 index 60baa5ca..c83a9e28 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-5-PROGSTAR.TEST @@ -1 +1,164 @@ -;; 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 +;; 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 + + + + + + + + + + diff --git a/internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.DFASL b/internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.DFASL index 241726d3..f034b2a6 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.DFASL 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 index 4cba6a14..1ce83aba 100644 --- a/internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.TEST +++ b/internal/test/LANGUAGE/AUTO/7-8-5-TAGBODY.TEST @@ -1 +1,184 @@ -;; 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 +;; 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 index bee2669d..63988a7f 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL 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 index 64700a3e..e5f906d9 100644 --- a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST +++ b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-BLOCK-CONSTRUCTS.TEST @@ -1 +1,232 @@ -;; ;; 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 +;; +;; 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 + + + + + + + + + + + + + diff --git a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.DFASL b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.DFASL index 0bad97fd..3f4a3390 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.DFASL 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 index bae10496..81ed26fa 100644 --- a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.TEST +++ b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CATCH.TEST @@ -1 +1,49 @@ -;; ;; 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 +;; +;; 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 index 673f42d5..bc96c936 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL 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 index 3884c15f..8d5d5b7e 100644 --- a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST +++ b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.TEST @@ -1 +1,252 @@ -;; 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 +;; 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 index 02adbd6f..e8d8a1df 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-EVALUATION-APPLICATION.DFASL 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 index 250b5f81..d396436b 100644 --- a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-EVALUATION-APPLICATION.TEST +++ b/internal/test/LANGUAGE/AUTO/7-9-2-MVR-EVALUATION-APPLICATION.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 index 934b8db0..ad8ac6d6 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-IMPLICIT-PROGN-1.DFASL 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 index 8cc4483a..ee6f56f4 100644 --- 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 @@ -1 +1,329 @@ -;; 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 +;; 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 + + + + + + + + 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 index 5589f140..196b0139 100644 --- 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 @@ -1 +1,697 @@ -;; 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 +;; 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 index 23c504b6..62f43149 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-9-2-MVR-MISC-SITUATIONS.DFASL 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 index f3178ae4..c562a3d7 100644 Binary files a/internal/test/LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.DFASL 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 index 1e4cc6a1..c0bbc0dd 100644 --- a/internal/test/LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.TEST +++ b/internal/test/LANGUAGE/AUTO/7-9-MULTIPLE-VALUES.TEST @@ -1 +1,263 @@ -;; 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 +;; 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 + 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 index ad9bed2a..0bd4cc6f 100644 --- a/internal/test/LANGUAGE/AUTO/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST +++ b/internal/test/LANGUAGE/AUTO/8-1-MACRO-FUNCTION-AND-DEFMACRO.TEST @@ -1 +1,484 @@ -;; 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 +;; 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 index 2eb5cc9e..107071fb 100644 Binary files a/internal/test/LANGUAGE/AUTO/8-1-PARSE-BODY.DFASL 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 index 1bd785af..decb5f7b 100644 --- a/internal/test/LANGUAGE/AUTO/8-1-PARSE-BODY.TEST +++ b/internal/test/LANGUAGE/AUTO/8-1-PARSE-BODY.TEST @@ -1 +1,20 @@ -(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 +(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 index 0df15b23..94635981 100644 --- a/internal/test/LANGUAGE/AUTO/8-2-MACROEXPAND-AND-MACROEXPAND-1.TEST +++ b/internal/test/LANGUAGE/AUTO/8-2-MACROEXPAND-AND-MACROEXPAND-1.TEST @@ -1 +1,141 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/8-MACRO-ARG-EVAL-ORDER.PRETEST b/internal/test/LANGUAGE/AUTO/8-MACRO-ARG-EVAL-ORDER.PRETEST index a6d244af..f7f6bc14 100644 --- a/internal/test/LANGUAGE/AUTO/8-MACRO-ARG-EVAL-ORDER.PRETEST +++ b/internal/test/LANGUAGE/AUTO/8-MACRO-ARG-EVAL-ORDER.PRETEST @@ -1 +1,539 @@ -;; ;; 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 +;; +;; 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 index 5b3b1319..f15678d8 100644 --- a/internal/test/LANGUAGE/AUTO/9-1-DECLARE.TEST +++ b/internal/test/LANGUAGE/AUTO/9-1-DECLARE.TEST @@ -1 +1,436 @@ -;; ;; 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 +;; +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/9-1-LOCALLY.TEST b/internal/test/LANGUAGE/AUTO/9-1-LOCALLY.TEST index 3b8c2abe..397ad549 100644 --- a/internal/test/LANGUAGE/AUTO/9-1-LOCALLY.TEST +++ b/internal/test/LANGUAGE/AUTO/9-1-LOCALLY.TEST @@ -1 +1,93 @@ -;; ;; 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 +;; +;; 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 + + + + + diff --git a/internal/test/LANGUAGE/AUTO/9-1-PROCLAIM.TEST b/internal/test/LANGUAGE/AUTO/9-1-PROCLAIM.TEST index 259ec9ce..7ca6dcbb 100644 --- a/internal/test/LANGUAGE/AUTO/9-1-PROCLAIM.TEST +++ b/internal/test/LANGUAGE/AUTO/9-1-PROCLAIM.TEST @@ -1 +1,152 @@ -;; ;; 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 +;; +;; 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 + + + + + + + + + + + + + diff --git a/internal/test/LANGUAGE/AUTO/9-3-THE.DFASL b/internal/test/LANGUAGE/AUTO/9-3-THE.DFASL index 18d23ece..496bdb2d 100644 Binary files a/internal/test/LANGUAGE/AUTO/9-3-THE.DFASL 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 index 9f478c52..72fe71a7 100644 --- a/internal/test/LANGUAGE/AUTO/9-3-THE.TEST +++ b/internal/test/LANGUAGE/AUTO/9-3-THE.TEST @@ -1 +1,75 @@ -;; 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 +;; 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 index 67e70820..d510519b 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR-TEST-CASES.DFASL 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 index 4a9a78a7..cd5fe582 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR-TEST-CASES.TEST 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 index c6dd5179..c16f9b19 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR5741.DFASL 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 index 96f707a5..925a88fd 100644 --- a/internal/test/LANGUAGE/AUTO/AR5741.TEST +++ b/internal/test/LANGUAGE/AUTO/AR5741.TEST @@ -1 +1 @@ -(do-test "prog scoping" (prog ((foo (return t))) nil)) \ No newline at end of file +(do-test "prog scoping" (prog ((foo (return t))) nil)) diff --git a/internal/test/LANGUAGE/AUTO/AR6150.DFASL b/internal/test/LANGUAGE/AUTO/AR6150.DFASL index 65070bb2..f3e08eb4 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR6150.DFASL 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 index 804b5294..eedd7d2c 100644 --- a/internal/test/LANGUAGE/AUTO/AR6150.TEST +++ b/internal/test/LANGUAGE/AUTO/AR6150.TEST @@ -1 +1,15 @@ -;;; 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 +;;; 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 index 011aa31d..d0e9d361 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR6247.DFASL 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 index 673ed6c7..0181c27d 100644 --- a/internal/test/LANGUAGE/AUTO/AR6247.TEST +++ b/internal/test/LANGUAGE/AUTO/AR6247.TEST @@ -1 +1,21 @@ -;; 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 +;; 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 index ce46bba6..ac48fda6 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR6273.DFASL 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 index 882979f4..18a48a3f 100644 --- a/internal/test/LANGUAGE/AUTO/AR6273.TEST +++ b/internal/test/LANGUAGE/AUTO/AR6273.TEST @@ -1 +1,11 @@ -;;; 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 +;;; 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)) + ) + ) + ) +) diff --git a/internal/test/LANGUAGE/AUTO/AR6781.DFASL b/internal/test/LANGUAGE/AUTO/AR6781.DFASL index 17e5b9d2..68ae9d4f 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR6781.DFASL 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 index 758ab0ab..0dee791e 100644 --- a/internal/test/LANGUAGE/AUTO/AR6781.TEST +++ b/internal/test/LANGUAGE/AUTO/AR6781.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/AUTO/AR7412.DFASL b/internal/test/LANGUAGE/AUTO/AR7412.DFASL index c82f53fb..05a1e773 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR7412.DFASL 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 index 8130e774..1dde9ca6 100644 --- a/internal/test/LANGUAGE/AUTO/AR7412.TEST +++ b/internal/test/LANGUAGE/AUTO/AR7412.TEST @@ -1 +1,7 @@ -;; 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 +;; 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 index 3faaf92e..0b5f9b3e 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR7475.DFASL 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 index d7bc15f0..8b7a9a09 100644 --- a/internal/test/LANGUAGE/AUTO/AR7475.TEST +++ b/internal/test/LANGUAGE/AUTO/AR7475.TEST @@ -1 +1,19 @@ -;; 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 +;; 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 index 51c34b5a..da06a476 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR7525.DFASL 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 index 008c6856..1c1786bb 100644 --- a/internal/test/LANGUAGE/AUTO/AR7525.TEST +++ b/internal/test/LANGUAGE/AUTO/AR7525.TEST @@ -1 +1,23 @@ -;; 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 +;; 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 index 8b170fa3..57c3ddb6 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR7587-DOC.DFASL 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 index e5d7b645..d109e52d 100644 --- a/internal/test/LANGUAGE/AUTO/AR7587-DOC.TEST +++ b/internal/test/LANGUAGE/AUTO/AR7587-DOC.TEST @@ -1 +1,20 @@ -;; 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 +;; 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 index 89ee6a66..dba36cfb 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR7647.DFASL 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 index 13c23096..034f4645 100644 --- a/internal/test/LANGUAGE/AUTO/AR7647.TEST +++ b/internal/test/LANGUAGE/AUTO/AR7647.TEST @@ -1 +1,5 @@ -;;; 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 +;;; Regression test for AR 7647: CASE macro loses on () clause - Lucid L211 + +(do-test "AR 7647" + (let ((foo nil)) (case foo (() nil) ((nil) t))) +) diff --git a/internal/test/LANGUAGE/AUTO/AR7742.DFASL b/internal/test/LANGUAGE/AUTO/AR7742.DFASL index 9f8b4b2f..ba3d3f35 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR7742.DFASL 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 index cce5c8f8..c773bbc8 100644 --- a/internal/test/LANGUAGE/AUTO/AR7742.TEST +++ b/internal/test/LANGUAGE/AUTO/AR7742.TEST @@ -1 +1,7 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/AUTO/AR8135.DFASL b/internal/test/LANGUAGE/AUTO/AR8135.DFASL index 4016e449..8a01521b 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR8135.DFASL 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 index da5f25ed..9511a7a7 100644 --- a/internal/test/LANGUAGE/AUTO/AR8135.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8135.TEST @@ -1 +1,32 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/AR8136.DFASL b/internal/test/LANGUAGE/AUTO/AR8136.DFASL index d4b214aa..d1a1bc41 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR8136.DFASL 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 index 0c92ea5e..b485b778 100644 --- a/internal/test/LANGUAGE/AUTO/AR8136.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8136.TEST @@ -1 +1,13 @@ -;; 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 +;; 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 index bfbdc31c..9201b2d1 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR8190.DFASL 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 index 49e7e2a6..457f9702 100644 --- a/internal/test/LANGUAGE/AUTO/AR8190.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8190.TEST @@ -1 +1,6 @@ -;; 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 +;; 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 index f5e839b3..52685215 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR8207.DFASL 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 index b4a962a0..ffa38dc2 100644 --- a/internal/test/LANGUAGE/AUTO/AR8207.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8207.TEST @@ -1 +1,9 @@ -;; 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 +;; 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 index 1ec2b6c3..37068dd2 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR8297.TEST 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 index f2d6afaf..cbd63eae 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR8301.DFASL 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 index cc2a99c7..bd477148 100644 --- a/internal/test/LANGUAGE/AUTO/AR8301.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8301.TEST @@ -1 +1,10 @@ -;; 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 +;; 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 index 98483055..61b7f375 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR8319.DFASL 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 index 3fa36acb..315cb2f3 100644 --- a/internal/test/LANGUAGE/AUTO/AR8319.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8319.TEST @@ -1 +1,5 @@ -;;; 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 +;;; Regression test for AR 8319: FMEMB not on UNSAFE.TO.MODIFY.FNS + +(do-test "AR 8319" + (member 'il:fmemb il:unsafe.to.modify.fns) +) diff --git a/internal/test/LANGUAGE/AUTO/AR8458.DFASL b/internal/test/LANGUAGE/AUTO/AR8458.DFASL index a1aafdc7..1f1ce859 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR8458.DFASL 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 index 075d4266..6e54a439 100644 --- a/internal/test/LANGUAGE/AUTO/AR8458.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8458.TEST @@ -1 +1,5 @@ -;;; 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 +;;; Regression test for AR 8458: *TRACE-OUTPUT* is supposed to be a window by default + +(do-test "AR 8458" + (typep *trace-output* 'il:window) +) diff --git a/internal/test/LANGUAGE/AUTO/AR8465.DFASL b/internal/test/LANGUAGE/AUTO/AR8465.DFASL index 51b3d462..10c33b2b 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR8465.DFASL 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 index 320e97f4..43c78dd1 100644 --- a/internal/test/LANGUAGE/AUTO/AR8465.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8465.TEST @@ -1 +1,7 @@ -;;; 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 +;;; 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))) + ) +) diff --git a/internal/test/LANGUAGE/AUTO/AR8466.TEST b/internal/test/LANGUAGE/AUTO/AR8466.TEST index 85990a2a..cd94d05f 100644 --- a/internal/test/LANGUAGE/AUTO/AR8466.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8466.TEST @@ -1 +1,8 @@ -;;; 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 +;;; 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) +) diff --git a/internal/test/LANGUAGE/AUTO/AR8470.DFASL b/internal/test/LANGUAGE/AUTO/AR8470.DFASL index ac005eb6..7db1164b 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR8470.DFASL 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 index 104bab21..a808e741 100644 --- a/internal/test/LANGUAGE/AUTO/AR8470.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8470.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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)))) +) diff --git a/internal/test/LANGUAGE/AUTO/AR8491.TEST b/internal/test/LANGUAGE/AUTO/AR8491.TEST index ae14d4b8..144059c3 100644 --- a/internal/test/LANGUAGE/AUTO/AR8491.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8491.TEST @@ -1 +1,6 @@ -;;; 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 +;;; 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))))) +) diff --git a/internal/test/LANGUAGE/AUTO/AR8575.DFASL b/internal/test/LANGUAGE/AUTO/AR8575.DFASL index a9449777..0e362af8 100644 Binary files a/internal/test/LANGUAGE/AUTO/AR8575.DFASL 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 index 86290397..665fc298 100644 --- a/internal/test/LANGUAGE/AUTO/AR8575.TEST +++ b/internal/test/LANGUAGE/AUTO/AR8575.TEST @@ -1 +1,12 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/ARITHMETIC-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/ARITHMETIC-REGRESSION.TEST index 6c07bd5d..27525494 100644 Binary files a/internal/test/LANGUAGE/AUTO/ARITHMETIC-REGRESSION.TEST 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 index 7c0c2454..2a7ca4c1 100644 Binary files a/internal/test/LANGUAGE/AUTO/ARRAY.DFASL 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 index 1f762e7f..2b15e2c9 100644 --- a/internal/test/LANGUAGE/AUTO/ARRAY.TEST +++ b/internal/test/LANGUAGE/AUTO/ARRAY.TEST @@ -1 +1,91 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/ARRAYP.DFASL b/internal/test/LANGUAGE/AUTO/ARRAYP.DFASL index 74b55b95..f6fcc9fa 100644 Binary files a/internal/test/LANGUAGE/AUTO/ARRAYP.DFASL 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 index 61a074d6..8ca741ab 100644 --- a/internal/test/LANGUAGE/AUTO/ARRAYP.TEST +++ b/internal/test/LANGUAGE/AUTO/ARRAYP.TEST @@ -1 +1,111 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/ARRAYS-AR6466.TEST b/internal/test/LANGUAGE/AUTO/ARRAYS-AR6466.TEST index 49dbcc4c..de044564 100644 Binary files a/internal/test/LANGUAGE/AUTO/ARRAYS-AR6466.TEST 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 index ea1a146a..f48bed74 100644 Binary files a/internal/test/LANGUAGE/AUTO/BIGNUM-PATCH-REGRESSION.DFASL 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 index f6178224..8f48f5eb 100644 --- a/internal/test/LANGUAGE/AUTO/BIGNUM-PATCH-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/BIGNUM-PATCH-REGRESSION.TEST @@ -1 +1,8 @@ -(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 +(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 index 6b3a08fe..440d9946 100644 Binary files a/internal/test/LANGUAGE/AUTO/BINDING.DFASL 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 index f9b104bb..238d9eb6 100644 --- a/internal/test/LANGUAGE/AUTO/BINDING.TEST +++ b/internal/test/LANGUAGE/AUTO/BINDING.TEST @@ -1 +1,67 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.DFASL index 1a19964e..383aa1d0 100644 Binary files a/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.DFASL 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 index 901085b9..c946455f 100644 --- a/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/BYTECOMPILER-REGRESSION.TEST @@ -1 +1,41 @@ -;; 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 +;; 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)))) diff --git a/internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.DFASL index 1e3b84f6..ccb66a85 100644 Binary files a/internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.DFASL 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 index 89f8d692..1351d516 100644 --- a/internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/CHAR-REGRESSION.TEST @@ -1 +1,44 @@ -;;; 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 +;;; 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)) +) + + diff --git a/internal/test/LANGUAGE/AUTO/CHARSET.TEST b/internal/test/LANGUAGE/AUTO/CHARSET.TEST index c740a52c..1b40feba 100644 --- a/internal/test/LANGUAGE/AUTO/CHARSET.TEST +++ b/internal/test/LANGUAGE/AUTO/CHARSET.TEST @@ -1 +1,13 @@ -(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 +(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 index b3638823..a58fa996 100644 Binary files a/internal/test/LANGUAGE/AUTO/CL-INTERPRETER-REGRESSION.DFASL 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 index 46480d5b..1c13dd5d 100644 --- a/internal/test/LANGUAGE/AUTO/CL-INTERPRETER-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/CL-INTERPRETER-REGRESSION.TEST @@ -1 +1,163 @@ -;; 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 +;; 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)))) diff --git a/internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.DFASL index 7d67cc29..0e1e8707 100644 Binary files a/internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.DFASL 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 index 7137c9c4..fdf14851 100644 --- a/internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/CLSTREAMS-REGRESSION.TEST @@ -1 +1,44 @@ -;;; 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 +;;; 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")) + diff --git a/internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.DFASL b/internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.DFASL index 34d27f84..c656406c 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.DFASL 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 index beff200b..64265ae2 100644 --- a/internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLARRAY-PATCH.TEST @@ -1 +1,7 @@ -;; (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 +;; +(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)))) + + diff --git a/internal/test/LANGUAGE/AUTO/CMLARRAY.DFASL b/internal/test/LANGUAGE/AUTO/CMLARRAY.DFASL index d513be70..cb9ea2a3 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLARRAY.DFASL 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 index 0024fd3b..4bab3936 100644 --- a/internal/test/LANGUAGE/AUTO/CMLARRAY.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLARRAY.TEST @@ -1 +1,8 @@ -;;; 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 +;;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/CMLCHARACTER.DFASL b/internal/test/LANGUAGE/AUTO/CMLCHARACTER.DFASL index 269593ce..3be19b6a 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLCHARACTER.DFASL 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 index 7409802e..30b0e79a 100644 --- a/internal/test/LANGUAGE/AUTO/CMLCHARACTER.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLCHARACTER.TEST @@ -1 +1,14 @@ -;;; 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 +;;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/CMLFILEMANAGER.TEST b/internal/test/LANGUAGE/AUTO/CMLFILEMANAGER.TEST index d133ba11..a913af06 100644 --- a/internal/test/LANGUAGE/AUTO/CMLFILEMANAGER.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLFILEMANAGER.TEST @@ -1,350 +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" - ˙˙ (˙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 +;; 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 index 4eece1e3..ad8366eb 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLFILESYS-REGRESSION.DFASL 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 index b3f3cfb5..dd78fa6c 100644 --- a/internal/test/LANGUAGE/AUTO/CMLFILESYS-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLFILESYS-REGRESSION.TEST @@ -1 +1,12 @@ -;;; 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 +;;; 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)))) diff --git a/internal/test/LANGUAGE/AUTO/CMLFLOAT.TEST b/internal/test/LANGUAGE/AUTO/CMLFLOAT.TEST index 48356a04..e283cfab 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLFLOAT.TEST 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 index 38a2599f..ca8d9172 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.DFASL 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 index 6f74cee2..4e31edca 100644 --- a/internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLPATHNAME-REGRESSION.TEST @@ -1 +1,3 @@ -;;; 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 +;;; 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 index c4251a76..b704e080 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLPROGV-REGRESSION.DFASL 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 index a936b70b..735421ab 100644 --- a/internal/test/LANGUAGE/AUTO/CMLPROGV-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLPROGV-REGRESSION.TEST @@ -1 +1,23 @@ -;; 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 +;; 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 index a35d485d..0030c7f8 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLRAND.DFASL 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 index 2f3737dc..e2c865eb 100644 --- a/internal/test/LANGUAGE/AUTO/CMLRAND.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLRAND.TEST @@ -1 +1,16 @@ -;;; 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 +;;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.DFASL index c1e51f99..ab183dff 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.DFASL 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 index 686b4cf2..00015b02 100644 --- a/internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLREADTABLE-REGRESSION.TEST @@ -1 +1,48 @@ -;; 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 +;; 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))) + ) +) diff --git a/internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.DFASL b/internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.DFASL index 6a072a67..4faa0187 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.DFASL 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 index 84c77a94..72840309 100644 --- a/internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLSEQMODIFY-PATCH.TEST @@ -1 +1,6 @@ -;; (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 +;; +(do-test "delete-duplicates works with :from-end" + (equal (delete-duplicates '(0 2 2 2) :start 2 :from-end t) '(0 2 2)) +) + + diff --git a/internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.DFASL index 50707a83..32b1a66a 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.DFASL 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 index 0b2ea8dd..6446ea35 100644 --- a/internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLSETF-REGRESSION.TEST @@ -1 +1,11 @@ -;; 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 +;; 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"))) diff --git a/internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.DFASL b/internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.DFASL index a8a29c54..f48aaf59 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.DFASL 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 index 8fc82fd7..dae96d3a 100644 --- a/internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLSPECIALFORMS-REGRESSION.TEST @@ -1 +1,9 @@ -;; 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 +;; 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)))) diff --git a/internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.DFASL b/internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.DFASL index e3ce6a88..849757e1 100644 Binary files a/internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.DFASL 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 index d81461aa..b696ef76 100644 --- a/internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.TEST +++ b/internal/test/LANGUAGE/AUTO/CMLTYPES-PATCH.TEST @@ -1 +1,18 @@ -;; (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 +;; +(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) + + ) + + diff --git a/internal/test/LANGUAGE/AUTO/COMMON.TEST b/internal/test/LANGUAGE/AUTO/COMMON.TEST index 8daa2b3b..6d874499 100644 --- a/internal/test/LANGUAGE/AUTO/COMMON.TEST +++ b/internal/test/LANGUAGE/AUTO/COMMON.TEST @@ -1 +1,15 @@ -;;; 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 +;;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/COMPILERS-AR8409.TEST b/internal/test/LANGUAGE/AUTO/COMPILERS-AR8409.TEST index 7aea76ee..3254f61b 100644 --- a/internal/test/LANGUAGE/AUTO/COMPILERS-AR8409.TEST +++ b/internal/test/LANGUAGE/AUTO/COMPILERS-AR8409.TEST @@ -1 +1,5 @@ -;;; 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 +;;; Regression test for AR 8409: MKATOM should return a single value + +(do-test "AR 8409" + (eql (length (multiple-value-list (il:mkatom "abc"))) 1) +) diff --git a/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7875.TEST b/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7875.TEST index cefdec5b..b0b9eb80 100644 --- a/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7875.TEST +++ b/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7875.TEST @@ -1 +1,6 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7893.TEST b/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7893.TEST index 9b961639..8a428ba4 100644 --- a/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7893.TEST +++ b/internal/test/LANGUAGE/AUTO/CONDITIONS-AR7893.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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))) +) diff --git a/internal/test/LANGUAGE/AUTO/CONDITIONSAR7383.TEST b/internal/test/LANGUAGE/AUTO/CONDITIONSAR7383.TEST index 33970300..cfb4527c 100644 --- a/internal/test/LANGUAGE/AUTO/CONDITIONSAR7383.TEST +++ b/internal/test/LANGUAGE/AUTO/CONDITIONSAR7383.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/AUTO/DEBUGGER-AR8512.TEST b/internal/test/LANGUAGE/AUTO/DEBUGGER-AR8512.TEST index ff57da7d..548d541a 100644 --- a/internal/test/LANGUAGE/AUTO/DEBUGGER-AR8512.TEST +++ b/internal/test/LANGUAGE/AUTO/DEBUGGER-AR8512.TEST @@ -1 +1,5 @@ -;;; 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 +;;; Regression test for AR 8512: System errors get breakwindows the say "In \LISPERROR..." + +(do-test "AR 8512" + (member 'il:\\lisperror il:*debugger-entry-points*) +) diff --git a/internal/test/LANGUAGE/AUTO/DEFDEFINE.TEST b/internal/test/LANGUAGE/AUTO/DEFDEFINE.TEST index f33a44e5..03918879 100644 --- a/internal/test/LANGUAGE/AUTO/DEFDEFINE.TEST +++ b/internal/test/LANGUAGE/AUTO/DEFDEFINE.TEST @@ -1,286 +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 HELVETICA HELVETICA/"/"zş \ No newline at end of file +;; 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 index c190bfc6..89424e79 100644 --- a/internal/test/LANGUAGE/AUTO/DEFSTRUCT-ADDITIONAL.TEST +++ b/internal/test/LANGUAGE/AUTO/DEFSTRUCT-ADDITIONAL.TEST @@ -1 +1,173 @@ - ;;; 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 + +;;; 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 diff --git a/internal/test/LANGUAGE/AUTO/DEFSTRUCT-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/DEFSTRUCT-REGRESSION.TEST index 2664a2c2..e693240d 100644 Binary files a/internal/test/LANGUAGE/AUTO/DEFSTRUCT-REGRESSION.TEST 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 index 18f897b6..19d299f6 100644 --- a/internal/test/LANGUAGE/AUTO/DELETE-SIDE-EFFECT.TEST +++ b/internal/test/LANGUAGE/AUTO/DELETE-SIDE-EFFECT.TEST @@ -1 +1,9 @@ -;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 +;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 index 916427aa..33256b8b 100644 --- a/internal/test/LANGUAGE/AUTO/DESCRIBE.TEST +++ b/internal/test/LANGUAGE/AUTO/DESCRIBE.TEST @@ -1 +1,7 @@ -;;; 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 +;;; woz 4/27/87 test for DESCRIBE - 8259 +(do-test "random state symbols are globally-special" + (DESCRIBE MOST-NEGATIVE-FIXNUM) +) + +stop + diff --git a/internal/test/LANGUAGE/AUTO/DOVEVMEMSIZEPATCH-LLFAULT.TEST b/internal/test/LANGUAGE/AUTO/DOVEVMEMSIZEPATCH-LLFAULT.TEST index 0f284bfd..4ed86692 100644 Binary files a/internal/test/LANGUAGE/AUTO/DOVEVMEMSIZEPATCH-LLFAULT.TEST 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 index 66da6b6c..ede8d340 100644 --- a/internal/test/LANGUAGE/AUTO/ERROR-RUNTIME-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/ERROR-RUNTIME-REGRESSION.TEST @@ -1 +1,35 @@ -;;; 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 +;;; 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.") + ) + ) +) + diff --git a/internal/test/LANGUAGE/AUTO/EVALUATOR-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/EVALUATOR-REGRESSION.TEST index d4a5498f..c2e9854d 100644 --- a/internal/test/LANGUAGE/AUTO/EVALUATOR-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/EVALUATOR-REGRESSION.TEST @@ -1 +1,84 @@ -;;; 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 +;;; 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 index 46401116..fd8bb8c9 100644 --- a/internal/test/LANGUAGE/AUTO/EVENP.TEST +++ b/internal/test/LANGUAGE/AUTO/EVENP.TEST @@ -1 +1,36 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/FASDUMP-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/FASDUMP-REGRESSION.TEST index e22b4d0a..dac54ddd 100644 --- a/internal/test/LANGUAGE/AUTO/FASDUMP-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/FASDUMP-REGRESSION.TEST @@ -1 +1,20 @@ -;;;; 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 +;;;; 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) + ) +) diff --git a/internal/test/LANGUAGE/AUTO/FASLOAD-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/FASLOAD-REGRESSION.TEST index ca0552c1..35f751be 100644 --- a/internal/test/LANGUAGE/AUTO/FASLOAD-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/FASLOAD-REGRESSION.TEST @@ -1 +1,79 @@ -;;; 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 +;;; 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*)) + ) + ) + ) +) diff --git a/internal/test/LANGUAGE/AUTO/FILEPKG-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/FILEPKG-REGRESSION.TEST index 89d58fe1..fc99f3e6 100644 --- a/internal/test/LANGUAGE/AUTO/FILEPKG-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/FILEPKG-REGRESSION.TEST @@ -1 +1,6 @@ -;; 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 +;; 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"))))) diff --git a/internal/test/LANGUAGE/AUTO/FIXP.TEST b/internal/test/LANGUAGE/AUTO/FIXP.TEST index b9f8d938..03e383dd 100644 --- a/internal/test/LANGUAGE/AUTO/FIXP.TEST +++ b/internal/test/LANGUAGE/AUTO/FIXP.TEST @@ -1 +1,127 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/FLOATP.TEST b/internal/test/LANGUAGE/AUTO/FLOATP.TEST index cf4d85b1..afc6e58c 100644 --- a/internal/test/LANGUAGE/AUTO/FLOATP.TEST +++ b/internal/test/LANGUAGE/AUTO/FLOATP.TEST @@ -1 +1,130 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/FORMAT-AR7912.TEST b/internal/test/LANGUAGE/AUTO/FORMAT-AR7912.TEST index cb884870..30f7e0e4 100644 --- a/internal/test/LANGUAGE/AUTO/FORMAT-AR7912.TEST +++ b/internal/test/LANGUAGE/AUTO/FORMAT-AR7912.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/AUTO/FORMAT-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/FORMAT-REGRESSION.TEST index 775a9b94..d2b89e6d 100644 Binary files a/internal/test/LANGUAGE/AUTO/FORMAT-REGRESSION.TEST 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 index 456af393..c897fa8d 100644 --- a/internal/test/LANGUAGE/AUTO/FP-PRINT-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/FP-PRINT-REGRESSION.TEST @@ -1 +1,29 @@ -;;; 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 +;;; 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 index 35084e83..8df01e00 100644 --- a/internal/test/LANGUAGE/AUTO/HARRAYP.TEST +++ b/internal/test/LANGUAGE/AUTO/HARRAYP.TEST @@ -1 +1,110 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/HASH-AR7587.TEST b/internal/test/LANGUAGE/AUTO/HASH-AR7587.TEST index fab2f6ea..23516b0f 100644 --- a/internal/test/LANGUAGE/AUTO/HASH-AR7587.TEST +++ b/internal/test/LANGUAGE/AUTO/HASH-AR7587.TEST @@ -1 +1,20 @@ -;; 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 +;; 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 index f06716e7..460b3334 100644 --- a/internal/test/LANGUAGE/AUTO/HASHARRAY.TEST +++ b/internal/test/LANGUAGE/AUTO/HASHARRAY.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-ARGUMENT-FUNCTIONS.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-ARGUMENT-FUNCTIONS.TEST index 89e347b7..f481f5d0 100644 --- a/internal/test/LANGUAGE/AUTO/INTERLISP-ARGUMENT-FUNCTIONS.TEST +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-ARGUMENT-FUNCTIONS.TEST @@ -1 +1,30 @@ -;; 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 +;; 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 +) diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-AR7398.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-AR7398.TEST index f0c19e33..e4d5cfa6 100644 --- a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-AR7398.TEST +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-AR7398.TEST @@ -1 +1,12 @@ -;;; 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 +;;; 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)) + ) + ) + ) + )) +) diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-ATOM.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-ATOM.TEST index 5b2741b3..07e461b7 100644 --- a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-ATOM.TEST +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES-ATOM.TEST @@ -1 +1,131 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES.TEST index ac9127a5..1305dc98 100644 --- a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES.TEST +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPES.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPESLITATOM.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPESLITATOM.TEST index d8611c0e..938de0a6 100644 --- a/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPESLITATOM.TEST +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-DATATYPESLITATOM.TEST @@ -1 +1,130 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/INTERLISP-ISOPRS.TEST b/internal/test/LANGUAGE/AUTO/INTERLISP-ISOPRS.TEST index 143b941e..ca28dba6 100644 --- a/internal/test/LANGUAGE/AUTO/INTERLISP-ISOPRS.TEST +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-ISOPRS.TEST @@ -1 +1,191 @@ -;; ;; 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 +;; +;; 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 index 0c162c66..c411ad01 100644 --- a/internal/test/LANGUAGE/AUTO/INTERLISP-RECORDS.TEST +++ b/internal/test/LANGUAGE/AUTO/INTERLISP-RECORDS.TEST @@ -1,665 +1,2 @@ -(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 +(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 index 7b8262da..f2cafbac 100644 --- a/internal/test/LANGUAGE/AUTO/INTERPRETER-AR8538.TEST +++ b/internal/test/LANGUAGE/AUTO/INTERPRETER-AR8538.TEST @@ -1 +1,6 @@ -;;; 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 +;;; 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))) +) diff --git a/internal/test/LANGUAGE/AUTO/INTERPRETERS-AR8366.TEST b/internal/test/LANGUAGE/AUTO/INTERPRETERS-AR8366.TEST index 9bf6c5ba..269924a6 100644 --- a/internal/test/LANGUAGE/AUTO/INTERPRETERS-AR8366.TEST +++ b/internal/test/LANGUAGE/AUTO/INTERPRETERS-AR8366.TEST @@ -1 +1,6 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/AUTO/LLINTERP-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/LLINTERP-REGRESSION.TEST index 9177390d..1cca4f82 100644 --- a/internal/test/LANGUAGE/AUTO/LLINTERP-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/LLINTERP-REGRESSION.TEST @@ -1 +1,12 @@ -;; 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 +;; 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 #'+))) + diff --git a/internal/test/LANGUAGE/AUTO/LLREAD.TEST b/internal/test/LANGUAGE/AUTO/LLREAD.TEST index 1301b72b..7af9499a 100644 --- a/internal/test/LANGUAGE/AUTO/LLREAD.TEST +++ b/internal/test/LANGUAGE/AUTO/LLREAD.TEST @@ -1 +1,12 @@ -;;; 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 +;;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/LLSYMBOL-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/LLSYMBOL-REGRESSION.TEST index d932fde8..ca1f8bf4 100644 --- a/internal/test/LANGUAGE/AUTO/LLSYMBOL-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/LLSYMBOL-REGRESSION.TEST @@ -1 +1,8 @@ -;; 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 +;; 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)))) diff --git a/internal/test/LANGUAGE/AUTO/LOCALFILE-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/LOCALFILE-REGRESSION.TEST index c117fec4..cc9d6f03 100644 --- a/internal/test/LANGUAGE/AUTO/LOCALFILE-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/LOCALFILE-REGRESSION.TEST @@ -1 +1,24 @@ -;;; 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 +;;; 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") + ) + ) +) diff --git a/internal/test/LANGUAGE/AUTO/NAMESTRING-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/NAMESTRING-REGRESSION.TEST index 7a5fac81..8d0bb51c 100644 --- a/internal/test/LANGUAGE/AUTO/NAMESTRING-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/NAMESTRING-REGRESSION.TEST @@ -1 +1,9 @@ -;; 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 +;; 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))) + diff --git a/internal/test/LANGUAGE/AUTO/NLISTP.TEST b/internal/test/LANGUAGE/AUTO/NLISTP.TEST index 123b77c6..08ccb9ec 100644 --- a/internal/test/LANGUAGE/AUTO/NLISTP.TEST +++ b/internal/test/LANGUAGE/AUTO/NLISTP.TEST @@ -1 +1,125 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/NUMBERP.TEST b/internal/test/LANGUAGE/AUTO/NUMBERP.TEST index e242be3e..5906672a 100644 --- a/internal/test/LANGUAGE/AUTO/NUMBERP.TEST +++ b/internal/test/LANGUAGE/AUTO/NUMBERP.TEST @@ -1 +1,130 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/PACKAGE-ARS.TEST b/internal/test/LANGUAGE/AUTO/PACKAGE-ARS.TEST index 356ed4ad..7eca9a7c 100644 --- a/internal/test/LANGUAGE/AUTO/PACKAGE-ARS.TEST +++ b/internal/test/LANGUAGE/AUTO/PACKAGE-ARS.TEST @@ -1 +1,241 @@ -;; ;; 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 +;; +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/PACKAGE-CONDITIONS.TEST b/internal/test/LANGUAGE/AUTO/PACKAGE-CONDITIONS.TEST index 55c64c33..d0aa9586 100644 --- a/internal/test/LANGUAGE/AUTO/PACKAGE-CONDITIONS.TEST +++ b/internal/test/LANGUAGE/AUTO/PACKAGE-CONDITIONS.TEST @@ -1 +1,227 @@ -;; ;; 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 +;; +;; 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 index b4157449..e4f0f514 100644 --- a/internal/test/LANGUAGE/AUTO/PACKAGE-CONVERTER-TEST.DATA +++ b/internal/test/LANGUAGE/AUTO/PACKAGE-CONVERTER-TEST.DATA @@ -1 +1,191 @@ -(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 +(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 index 98772eae..89cc1bd9 100644 --- a/internal/test/LANGUAGE/AUTO/PRETTY-CIRCLE-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/PRETTY-CIRCLE-REGRESSION.TEST @@ -1 +1,14 @@ -;;; 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 +;;; 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 index 2d9be223..727f4b9a 100644 --- a/internal/test/LANGUAGE/AUTO/PRINTING-MINUS0.TEST +++ b/internal/test/LANGUAGE/AUTO/PRINTING-MINUS0.TEST @@ -1 +1,3 @@ -(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 +(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 index 5a8e9fde..c8105c7a 100644 --- a/internal/test/LANGUAGE/AUTO/PROC-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/PROC-REGRESSION.TEST @@ -1 +1,28 @@ -;;; 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 +;;; 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 + + diff --git a/internal/test/LANGUAGE/AUTO/PROPERTY.TEST b/internal/test/LANGUAGE/AUTO/PROPERTY.TEST index 7ead376f..3499444c 100644 --- a/internal/test/LANGUAGE/AUTO/PROPERTY.TEST +++ b/internal/test/LANGUAGE/AUTO/PROPERTY.TEST @@ -1 +1,116 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/REGRESSION.TEST index 6c07bd5d..27525494 100644 Binary files a/internal/test/LANGUAGE/AUTO/REGRESSION.TEST 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 index c936428a..bdd17979 100644 --- a/internal/test/LANGUAGE/AUTO/RESETVAR-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/RESETVAR-REGRESSION.TEST @@ -1 +1,5 @@ -(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 +(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 diff --git a/internal/test/LANGUAGE/AUTO/SIMPLE-SUPPLIED-P.TEST b/internal/test/LANGUAGE/AUTO/SIMPLE-SUPPLIED-P.TEST index 76716b94..5701e133 100644 --- a/internal/test/LANGUAGE/AUTO/SIMPLE-SUPPLIED-P.TEST +++ b/internal/test/LANGUAGE/AUTO/SIMPLE-SUPPLIED-P.TEST @@ -1 +1,24 @@ -;;;; 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 +;;;; 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))) +) diff --git a/internal/test/LANGUAGE/AUTO/SINGLE-VALUE.TEST b/internal/test/LANGUAGE/AUTO/SINGLE-VALUE.TEST index de104fcd..38629864 100644 --- a/internal/test/LANGUAGE/AUTO/SINGLE-VALUE.TEST +++ b/internal/test/LANGUAGE/AUTO/SINGLE-VALUE.TEST @@ -1 +1,3 @@ -(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 +(DO-TEST "AR 8409 - IL:MKATOM shouldn't return multiple values" + (NULL (CDR (MULTIPLE-VALUE-LIST (IL:MKATOM "FOO"))))) +STOP diff --git a/internal/test/LANGUAGE/AUTO/SMALLP.TEST b/internal/test/LANGUAGE/AUTO/SMALLP.TEST index b6f0d1bc..3b57e9b8 100644 --- a/internal/test/LANGUAGE/AUTO/SMALLP.TEST +++ b/internal/test/LANGUAGE/AUTO/SMALLP.TEST @@ -1 +1,125 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/SPECIALS.TEST b/internal/test/LANGUAGE/AUTO/SPECIALS.TEST index 5df26ea7..a4df8780 100644 --- a/internal/test/LANGUAGE/AUTO/SPECIALS.TEST +++ b/internal/test/LANGUAGE/AUTO/SPECIALS.TEST @@ -1 +1,76 @@ -(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 +(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 index ee94094b..291e5f8d 100644 Binary files a/internal/test/LANGUAGE/AUTO/STACK.TEST 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 index 9a653eff..32cd1782 100644 --- a/internal/test/LANGUAGE/AUTO/STRING.TEST +++ b/internal/test/LANGUAGE/AUTO/STRING.TEST @@ -1 +1,146 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/STRING.TESTS b/internal/test/LANGUAGE/AUTO/STRING.TESTS index 3fe235ca..2d1e1d1b 100644 --- a/internal/test/LANGUAGE/AUTO/STRING.TESTS +++ b/internal/test/LANGUAGE/AUTO/STRING.TESTS @@ -1 +1,19 @@ -(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 +(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 index b73de165..639dc2c6 100644 --- a/internal/test/LANGUAGE/AUTO/STRINGP.TEST +++ b/internal/test/LANGUAGE/AUTO/STRINGP.TEST @@ -1 +1,127 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/STRINGS-AR7993.TEST b/internal/test/LANGUAGE/AUTO/STRINGS-AR7993.TEST index 26dee76e..c6b174e3 100644 --- a/internal/test/LANGUAGE/AUTO/STRINGS-AR7993.TEST +++ b/internal/test/LANGUAGE/AUTO/STRINGS-AR7993.TEST @@ -1 +1,22 @@ -;; 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 +;; 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 index 0db29bdc..60397cbe 100644 --- a/internal/test/LANGUAGE/AUTO/STRUCTURE-PRINT-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/STRUCTURE-PRINT-REGRESSION.TEST @@ -1 +1,13 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/AUTO/TIME-PATCH.TEST b/internal/test/LANGUAGE/AUTO/TIME-PATCH.TEST index 94e71cfd..3ffa1f60 100644 --- a/internal/test/LANGUAGE/AUTO/TIME-PATCH.TEST +++ b/internal/test/LANGUAGE/AUTO/TIME-PATCH.TEST @@ -1 +1,18 @@ -(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 +(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 index d027cb78..81389fc5 100644 --- a/internal/test/LANGUAGE/AUTO/TYPENAME.TEST +++ b/internal/test/LANGUAGE/AUTO/TYPENAME.TEST @@ -1 +1,72 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/TYPENAMEP.TEST b/internal/test/LANGUAGE/AUTO/TYPENAMEP.TEST index 4230910d..ad00f8b7 100644 --- a/internal/test/LANGUAGE/AUTO/TYPENAMEP.TEST +++ b/internal/test/LANGUAGE/AUTO/TYPENAMEP.TEST @@ -1 +1,86 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/AUTO/USERDEF.TEST b/internal/test/LANGUAGE/AUTO/USERDEF.TEST index ef59059a..a26c5522 100644 --- a/internal/test/LANGUAGE/AUTO/USERDEF.TEST +++ b/internal/test/LANGUAGE/AUTO/USERDEF.TEST @@ -1 +1,34 @@ -(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 +(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 index d12d7b8c..37bb3eda 100644 Binary files a/internal/test/LANGUAGE/AUTO/VECTOR.TEST 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 index 03b3dc4e..0b7cfd41 100644 --- a/internal/test/LANGUAGE/AUTO/WRAPPERS-AR7900.TEST +++ b/internal/test/LANGUAGE/AUTO/WRAPPERS-AR7900.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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) +) diff --git a/internal/test/LANGUAGE/AUTO/WRITEFILE-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/WRITEFILE-REGRESSION.TEST index e024eb2a..0638f846 100644 --- a/internal/test/LANGUAGE/AUTO/WRITEFILE-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/WRITEFILE-REGRESSION.TEST @@ -1 +1,3 @@ -(do-test "WRITEFILE closes its file once" (il:writefile '((plus 2 3)(times 4 5)) '{dsk}foofile)) STOP \ No newline at end of file +(do-test "WRITEFILE closes its file once" + (il:writefile '((plus 2 3)(times 4 5)) '{dsk}foofile)) +STOP diff --git a/internal/test/LANGUAGE/AUTO/XCL-COMPILER-REGRESSION.TEST b/internal/test/LANGUAGE/AUTO/XCL-COMPILER-REGRESSION.TEST index 87367d66..e6991210 100644 --- a/internal/test/LANGUAGE/AUTO/XCL-COMPILER-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/XCL-COMPILER-REGRESSION.TEST @@ -1 +1,229 @@ -;; 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 +;; 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 index e2a4c7af..582de9d5 100644 --- a/internal/test/LANGUAGE/AUTO/XCLC-REGRESSION.TEST +++ b/internal/test/LANGUAGE/AUTO/XCLC-REGRESSION.TEST @@ -1 +1,155 @@ -;; 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 +;; 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)))))) + diff --git a/internal/test/LANGUAGE/AUTO/Y b/internal/test/LANGUAGE/AUTO/Y index 99fa106a..164664e8 100644 --- a/internal/test/LANGUAGE/AUTO/Y +++ b/internal/test/LANGUAGE/AUTO/Y @@ -1 +1,9 @@ -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 +FOO(@Z) LAMBDA + '511 RETURN + +FOO +name table: +(L (0 Z)) +code length: argtype: 0 +SICX 1 377Q RETURN -X- + diff --git a/internal/test/LANGUAGE/AUTO/test-results b/internal/test/LANGUAGE/AUTO/test-results index 7a494a9c..728f7c60 100644 --- a/internal/test/LANGUAGE/AUTO/test-results +++ b/internal/test/LANGUAGE/AUTO/test-results @@ -1 +1,41 @@ -;;; 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 +;;; 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 index 8d22d0dc..c78c8db6 100644 --- a/internal/test/LANGUAGE/Hand/22-4-Y-OR-N-P.U +++ b/internal/test/LANGUAGE/Hand/22-4-Y-OR-N-P.U @@ -1 +1,70 @@ -;; 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 +;; 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 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 index 0d636344..86efc97b 100644 --- a/internal/test/LANGUAGE/Hand/22-4-YES-OR-NO-P.U +++ b/internal/test/LANGUAGE/Hand/22-4-YES-OR-NO-P.U @@ -1 +1,70 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/Hand/25-3-STEP.U b/internal/test/LANGUAGE/Hand/25-3-STEP.U index be8cd8a9..bd42e478 100644 --- a/internal/test/LANGUAGE/Hand/25-3-STEP.U +++ b/internal/test/LANGUAGE/Hand/25-3-STEP.U @@ -1 +1,45 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/Hand/25-3-TRACE.U b/internal/test/LANGUAGE/Hand/25-3-TRACE.U index 34023618..7df53c78 100644 --- a/internal/test/LANGUAGE/Hand/25-3-TRACE.U +++ b/internal/test/LANGUAGE/Hand/25-3-TRACE.U @@ -1 +1,88 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/Hand/25-3-UNTRACE.U b/internal/test/LANGUAGE/Hand/25-3-UNTRACE.U index 281f2a3a..6618721d 100644 --- a/internal/test/LANGUAGE/Hand/25-3-UNTRACE.U +++ b/internal/test/LANGUAGE/Hand/25-3-UNTRACE.U @@ -1 +1,89 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/LANGUAGE/LOGS/24-ERRORSYSTEM.LOG b/internal/test/LANGUAGE/LOGS/24-ERRORSYSTEM.LOG index 863932d8..19fa7926 100644 --- a/internal/test/LANGUAGE/LOGS/24-ERRORSYSTEM.LOG +++ b/internal/test/LANGUAGE/LOGS/24-ERRORSYSTEM.LOG @@ -1 +1,5 @@ -;;; 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 +;;; 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 index b98fe932..a9f5802b 100644 --- a/internal/test/LANGUAGE/LOGS/31-AUG-88.1109 +++ b/internal/test/LANGUAGE/LOGS/31-AUG-88.1109 @@ -1 +1,132 @@ -: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 +: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" diff --git a/internal/test/LANGUAGE/Plans/21-STREAMS.NOTEFILE b/internal/test/LANGUAGE/Plans/21-STREAMS.NOTEFILE index cf52829e..a78da7b8 100644 Binary files a/internal/test/LANGUAGE/Plans/21-STREAMS.NOTEFILE 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 index fd2af62d..bd0863a6 100644 --- a/internal/test/LANGUAGE/from-sun/README +++ b/internal/test/LANGUAGE/from-sun/README @@ -1 +1,10 @@ -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 +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 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 index e8c94d85..7fba5619 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 + + 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 index 959cdc6e..c7a2baea 100644 --- a/internal/test/LANGUAGE/from-sun/language/10/10-1-GET.TEST +++ b/internal/test/LANGUAGE/from-sun/language/10/10-1-GET.TEST @@ -1 +1,102 @@ -;; 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 +;; 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 + + + 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 index 50fd0686..cf044d35 100644 --- a/internal/test/LANGUAGE/from-sun/language/10/10-1-GETF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/10/10-1-GETF.TEST @@ -1 +1,85 @@ -;; 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 +;; 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 index 11972e1e..5c12eafc 100644 --- a/internal/test/LANGUAGE/from-sun/language/10/10-1-REMF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/10/10-1-REMF.TEST @@ -1 +1,60 @@ -;; 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 +;; 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 + 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 index 1b5b28c9..094220cb 100644 --- a/internal/test/LANGUAGE/from-sun/language/10/10-1-REMPROP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/10/10-1-REMPROP.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 + 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 index 1f97d9cb..46858c36 100644 --- 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 @@ -1 +1,72 @@ -;; 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 +;; 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 + + + 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 index d10c33d1..92b62433 100644 --- 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 @@ -1 +1,50 @@ -;; 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 +;; 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 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 index f1a8d488..a65d139d 100644 --- 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 @@ -1 +1,62 @@ -;; 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 +;; 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 + 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 index 02426931..b7ede7ca 100644 --- a/internal/test/LANGUAGE/from-sun/language/10/10-3-GENSYM.TEST +++ b/internal/test/LANGUAGE/from-sun/language/10/10-3-GENSYM.TEST @@ -1 +1,91 @@ -;; 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 +;; 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 + 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 index 917a078b..f3e9c893 100644 --- a/internal/test/LANGUAGE/from-sun/language/10/10-3-GENTEMP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/10/10-3-GENTEMP.TEST @@ -1 +1,142 @@ -;; 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 +;; 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 + 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 index be1d4ec0..3c7290ea 100644 --- a/internal/test/LANGUAGE/from-sun/language/10/10-3-KEYWORDP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/10/10-3-KEYWORDP.TEST @@ -1 +1,42 @@ -;; 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 +;; 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 + 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 index d3323036..61fa0ef4 100644 --- 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 @@ -1 +1,39 @@ -;; 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 +;; 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 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 index 5fc0e707..4b909fc1 100644 --- 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 @@ -1 +1,41 @@ -;; 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 +;; 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 + 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 index e15c3909..f3ad73f9 100644 --- a/internal/test/LANGUAGE/from-sun/language/11/11-6-IMPORT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/11/11-6-IMPORT.TEST @@ -1 +1,49 @@ -;; 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 +;; 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 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 index 35563012..e42853d1 100644 --- 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 @@ -1 +1,53 @@ -;; 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 +;; 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 + + 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 index 14b3c236..88ed7311 100644 --- 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 @@ -1 +1,64 @@ -;; 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 +;; 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 + + 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 index ccb0531a..1cc2e1d9 100644 --- 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 @@ -1 +1,81 @@ -;; 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 +;; 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 + + 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 index a3e1e450..44295698 100644 --- a/internal/test/LANGUAGE/from-sun/language/11/11-7-EXPORT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-EXPORT.TEST @@ -1 +1,67 @@ -;; 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 +;; 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 + + 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 index 3ff17cad..93e0963f 100644 --- 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 @@ -1 +1,38 @@ -;; 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 +;; 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 + + 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 index f229d7df..7e08915c 100644 --- 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 @@ -1 +1,41 @@ -;; 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 +;; 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 + + 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 index cee00adc..d7a7c800 100644 --- 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 @@ -1 +1,61 @@ -;; 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 +;; 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 + + 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 index d9287be0..9ef4d4fe 100644 --- a/internal/test/LANGUAGE/from-sun/language/11/11-7-IMPORT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-IMPORT.TEST @@ -1 +1,51 @@ -;; 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 +;; 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 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 index a93f66b9..f3b663f3 100644 --- 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 @@ -1 +1,57 @@ -;; 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 +;; 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 + + 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 index 70673c12..dfe52842 100644 --- a/internal/test/LANGUAGE/from-sun/language/11/11-7-INTERN.TEST +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-INTERN.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 + + 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 index 7db42315..8896f888 100644 --- 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 @@ -1 +1,45 @@ -;; 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 +;; 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 + + 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 index e6f11fbd..90e6b51a 100644 --- 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 @@ -1 +1,80 @@ -;; 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 +;; 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 + + 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 index 45e5228e..58e52490 100644 --- 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 @@ -1 +1,49 @@ - ;; 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 + +;; 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 + + 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 index d10337fe..e199fbee 100644 --- 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 @@ -1 +1,46 @@ -;; 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 +;; 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 + + 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 index 97f76cce..194201cc 100644 --- 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 @@ -1 +1,48 @@ -;; 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 +;; 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 + + 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 index 6427cb03..d9e7bf8b 100644 --- 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 @@ -1 +1,46 @@ -;; 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 +;; 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 + + 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 index b35e8100..d144f87b 100644 --- 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 @@ -1 +1,53 @@ -;; 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 +;; 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 + + 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 index 16f94ec3..09b4c43c 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 + + 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 index 87441938..31de7fbf 100644 --- a/internal/test/LANGUAGE/from-sun/language/11/11-7-SHADOW.TEST +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-SHADOW.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 + + 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 index 0ccbff6a..f21e4ed0 100644 --- 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 @@ -1 +1,59 @@ -;; 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 +;; 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 + + 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 index 65653fb4..0aaf0f9d 100644 --- a/internal/test/LANGUAGE/from-sun/language/11/11-7-UNEXPORT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-UNEXPORT.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 + + 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 index b8c2c190..e453cbf3 100644 --- a/internal/test/LANGUAGE/from-sun/language/11/11-7-UNINTERN.TEST +++ b/internal/test/LANGUAGE/from-sun/language/11/11-7-UNINTERN.TEST @@ -1 +1,61 @@ -;; 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 +;; 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 + + 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 index 73cec8a4..f8331b95 100644 --- 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 @@ -1 +1,46 @@ -;; 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 +;; 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 + + 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 index 473ced46..210afa88 100644 --- 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 @@ -1 +1,45 @@ -;; 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 +;; 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 + + 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 index ac656502..6807336f 100644 --- a/internal/test/LANGUAGE/from-sun/language/11/11-8-PROVIDE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/11/11-8-PROVIDE.TEST @@ -1 +1,54 @@ -;; 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 +;; 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 + + 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 index a9161124..f256beff 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 index 46401116..fd8bb8c9 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TEST @@ -1 +1,36 @@ -;; 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 +;; 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 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 index 8cd3ad9f..e58ed68e 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-EVENP.TST @@ -1 +1,14 @@ -;; 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 +;; 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 index fcc37363..15425cce 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 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 index 6c4bff4d..453dd0a9 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-MINUSP.TST @@ -1 +1,15 @@ -;: 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 +;: 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 index 5248b9d0..323c7028 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 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 index 51b4b162..62a2f152 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-ODDP.TST @@ -1 +1,17 @@ -;: 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 +;: 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 index 53916c0b..fa608316 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 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 index 2c0203bc..69c02352 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-PLUSP.TST @@ -1 +1,14 @@ -;: 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 +;: 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 index 87266fe5..ed374b5f 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 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 index 3a135355..29cb4683 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TXT +++ b/internal/test/LANGUAGE/from-sun/language/12/12-2-ZEROP.TXT @@ -1 +1,15 @@ -;: 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 +;: 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 index 83835fd7..20f0d52c 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-3-EQP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-EQP.TEST @@ -1 +1,109 @@ -;; 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 +;; 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 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 index a51c6d65..698ef3c2 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-3-GEQ.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-GEQ.TEST @@ -1 +1,130 @@ -;; 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 +;; 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 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 index dc22e12c..9033d864 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-3-GREATERP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-GREATERP.TEST @@ -1 +1,124 @@ -;; 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 +;; 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 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 index 622be6e2..22780ab2 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-3-LEQ.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-LEQ.TEST @@ -1 +1,129 @@ -;; 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 +;; 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 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 index f9247118..0701cdde 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-3-LESSP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-LESSP.TEST @@ -1 +1,124 @@ -;; 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 +;; 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 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 index 277574d9..5d2e624a 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-3-MAX.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-MAX.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 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 index c918592c..4a4b9cc4 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-3-MIN.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-MIN.TEST @@ -1 +1,71 @@ -;; 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 +;; 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 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 index 6c24219b..9ef99d80 100644 --- 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 @@ -1 +1,33 @@ -;; 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 +;; 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)))) + + + 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 index 879ed2cd..c023a71a 100644 --- 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 @@ -1 +1,33 @@ -;; 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 +;; 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)))) + + + 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 index 5af4e7c1..f1703b7b 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-3-NEQP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-3-NEQP.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4-+.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4-+.TEST index 6b08ead2..3a7a854d 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-4-+.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-+.TEST @@ -1 +1,73 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/from-sun/language/12/12-4--.TEST b/internal/test/LANGUAGE/from-sun/language/12/12-4--.TEST index 86fb0249..544e4ff7 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-4--.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4--.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 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 index c4b82a90..bc727ab9 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-4-1+.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-1+.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 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 index c134f6a1..90f9b77a 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-4-1-.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-1-.TEST @@ -1 +1,45 @@ -;; 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 +;; 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 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 index 9973e736..353a3c22 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-4-CONJUGATE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-CONJUGATE.TEST @@ -1 +1,42 @@ -;; 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 +;; 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 + 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 index 61cc7588..fd96b3b3 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-4-DECF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-DECF.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 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 index 26848e4a..d5b049d7 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-4-GCD.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-GCD.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 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 index 85a1ab44..a677cfb2 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-4-INCF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-INCF.TEST @@ -1 +1,49 @@ -;; 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 +;; 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 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 index f2369259..d92e69c4 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-4-LCM.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-LCM.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 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 index ccd439fc..ff208a4b 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-4-QUOTIENT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-QUOTIENT.TEST @@ -1 +1,73 @@ -;; 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 +;; 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 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 index 1d1ceeee..80e06ce7 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-4-TIMES.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-4-TIMES.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 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 index f4bafdf2..1aa80fa1 100644 --- 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 @@ -1 +1,38 @@ -;; 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 +;; 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 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 index c3be36f7..cbcf7421 100644 --- 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 @@ -1 +1,76 @@ -;; 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 +;; 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 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 index 7abd3f8a..c51a2e5a 100644 --- 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 @@ -1 +1,43 @@ -;; 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 +;; 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 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 index cd499f6b..76a8534d 100644 --- 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 @@ -1 +1,53 @@ -;; 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 +;; 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 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 index 8e273768..e17e777b 100644 --- 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 @@ -1 +1,46 @@ -;; 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 +;; 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 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 index ee89561e..e511436e 100644 --- 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 @@ -1 +1,56 @@ -;; 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 +;; 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 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 index 66d70198..c8de277d 100644 --- 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 @@ -1 +1,73 @@ -;; 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 +;; 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 + 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 index 9d4d69a2..8b13e2a2 100644 --- 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 @@ -1 +1,94 @@ -;; 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 +;; 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 + 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 index 21168b9b..405786cc 100644 --- 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 @@ -1 +1,73 @@ -;; 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 +;; 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 + 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 index 7e9d9eee..73c7c85b 100644 --- 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 @@ -1 +1,91 @@ -;; 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 +;; 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 + 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 index f38d1e37..a76dde38 100644 --- 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 @@ -1 +1,138 @@ -;; 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 +;; 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 index fb1a2e6c..158d7fdc 100644 --- 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 @@ -1 +1,105 @@ -;; 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 +;; 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 + + 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 index a55eb7ca..3578d9a4 100644 --- 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 @@ -1 +1,69 @@ -;; 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 +;; 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 + + + 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 index 043e71bf..592dd1cf 100644 --- 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 @@ -1 +1,62 @@ -;; 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 +;; 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 + + 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 index 4aefbaac..c7194cac 100644 --- 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 @@ -1 +1,92 @@ - ;; 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 + +;; 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 + + 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 index 4131fdaa..1731c153 100644 --- 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 @@ -1 +1,84 @@ -;; 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 +;; 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 + 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 index b0525335..10f3ec94 100644 --- 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 @@ -1 +1,101 @@ -;; 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 +;; 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 + + 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 index c829d0ee..d2dab431 100644 --- 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 @@ -1 +1,65 @@ -;; 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 +;; 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 + + 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 index 128813a6..68d9d228 100644 --- 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 @@ -1 +1,93 @@ -;; 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 +;; 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 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 index 2f679949..82777122 100644 --- 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 @@ -1 +1,62 @@ -;; 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 +;; 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 + + 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 index 0a13db09..b637ad06 100644 --- 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 @@ -1 +1,94 @@ -;; 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 +;; 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 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 index f3688a1e..e5bf0241 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-CEILING.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-CEILING.TEST @@ -1 +1,138 @@ -;; 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 +;; 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 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 index 1b6d4e9a..a24d2d8d 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-COMPLEX.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-COMPLEX.TEST @@ -1 +1,39 @@ -;; 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 +;; 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 + + 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 index 92e82a1d..7a970261 100644 --- 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 @@ -1 +1,54 @@ -;; 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 +;; 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 + + 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 index e22f1143..a8c62e0c 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-DENOMINATOR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-DENOMINATOR.TEST @@ -1 +1,44 @@ -;; 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 +;; 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 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 index dac989fd..3091d92f 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-FCEILING.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FCEILING.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 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 index 9e390a45..56ad9a0b 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-FFLOOR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FFLOOR.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 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 index 626a9b2e..c64977fd 100644 --- 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 @@ -1 +1,45 @@ -;; 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 +;; 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 + 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 index 8fdbdc95..0a8193c5 100644 --- 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 @@ -1 +1,51 @@ -;; 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 +;; 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 + 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 index a2d85fbf..179acf69 100644 --- 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 @@ -1 +1,44 @@ -;; 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 +;; 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 + 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 index 3df45ea2..be9695fa 100644 --- 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 @@ -1 +1,65 @@ -;; 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 +;; 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 + 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 index b8ed6448..b053e993 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOAT.TEST @@ -1 +1,41 @@ -;; 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 +;; 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 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 index 0ed5c8cc..985d0b0e 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOOR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FLOOR.TEST @@ -1 +1,138 @@ -;; 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 +;; 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 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 index b3da9296..d3533342 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-FROUND.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FROUND.TEST @@ -1 +1,63 @@ -;; 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 +;; 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 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 index e0569c90..9995f46d 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-FTRUNCATE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-FTRUNCATE.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 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 index ac90f5b1..6f26c02b 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-IMAGPART.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-IMAGPART.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 + + 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 index f4c0407c..0736ac07 100644 --- 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 @@ -1 +1,73 @@ -;; 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 +;; 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 + + 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 index 4486d09b..a8f56efe 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-MOD.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-MOD.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 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 index b7c60994..c916aa48 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-NUMERATOR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-NUMERATOR.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 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 index 7ac2c6a0..708a1e3c 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONAL.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONAL.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 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 index d58a88f6..8854ab9a 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONALIZE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-RATIONALIZE.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 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 index 25b2565d..c66320e8 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-REALPART.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-REALPART.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 + + 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 index 81271e5d..c202a46c 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-REM.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-REM.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 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 index f360a1cc..a828adbb 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-ROUND.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-ROUND.TEST @@ -1 +1,139 @@ -;; 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 +;; 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 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 index 0960caca..f282abd0 100644 --- 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 @@ -1 +1,59 @@ -;; 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 +;; 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 + 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 index cdd5f735..d4f76a30 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-6-TRUNCATE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-6-TRUNCATE.TEST @@ -1 +1,139 @@ -;; 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 +;; 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 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 index 03564f3e..9ad07759 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-ASH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-ASH.TEST @@ -1 +1,60 @@ -;; 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 +;; 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 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 index d15eef6d..d388ecd7 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-BOOLE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-BOOLE.TEST @@ -1 +1,262 @@ -;; 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 +;; 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 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 index 68be6c66..50d86f9d 100644 --- 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 @@ -1 +1,68 @@ -;; 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 +;; 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 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 index de0f4e44..f2c0ac01 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGAND.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGAND.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 + + 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 index 1f06b788..aaaf2002 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC1.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC1.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 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 index a7510021..936f2b46 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC2.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGANDC2.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 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 index 2fb1872a..a114fd90 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGBITP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGBITP.TEST @@ -1 +1,43 @@ -;; 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 +;; 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 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 index 7839abe7..3df2179d 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGCOUNT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGCOUNT.TEST @@ -1 +1,52 @@ -;; 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 +;; 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 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 index 4526257d..577256df 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGEQV.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGEQV.TEST @@ -1 +1,39 @@ -;; 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 +;; 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 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 index 6ce9b96a..c1444214 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGIOR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGIOR.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 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 index 2407940c..55fef6e0 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNAND.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNAND.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 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 index a29595c1..3cf1516d 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOR.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 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 index 5ef676ff..6af6b2e7 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGNOT.TEST @@ -1 +1,39 @@ -;; 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 +;; 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 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 index c45a5f9d..6123808e 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC1.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC1.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 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 index 6ec7ba6f..4a18ebf7 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC2.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGORC2.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 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 index 6e5e5322..8a1038c7 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGTEST.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGTEST.TEST @@ -1 +1,40 @@ -;; 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 +;; 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 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 index ebf980c0..403a0ca7 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGXOR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-7-LOGXOR.TEST @@ -1 +1,36 @@ -;; 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 +;; 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 + + 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 index 9b76c040..303f50f9 100644 --- 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 @@ -1 +1,53 @@ -;; 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 +;; 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 + + + + 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 index 1e9e2800..a1b09339 100644 --- 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 @@ -1 +1,49 @@ -;; 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 +;; 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 + 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 index c0b37625..8b6abf46 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-8-BYTE.TEST @@ -1 +1,54 @@ -;; 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 +;; 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 + + 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 index 896b530f..4424d376 100644 --- 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 @@ -1 +1,60 @@ -;; 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 +;; 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 + 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 index 7249888e..b8a47628 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-8-DPB.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-8-DPB.TEST @@ -1 +1,58 @@ -;; 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 +;; 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 + 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 index d4585aaf..d67ccc67 100644 --- 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 @@ -1 +1,44 @@ -;; 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 +;; 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 + 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 index 319c5d00..e006568a 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-8-LDB.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-8-LDB.TEST @@ -1 +1,45 @@ -;; 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 +;; 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 + 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 index 0861ca6f..6349ce22 100644 --- 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 @@ -1 +1,46 @@ -;; 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 +;; 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 + 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 index 52fe7bf1..ef5d86ae 100644 --- 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 @@ -1 +1,50 @@ -;; 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 +;; 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 + + 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 index 05f7a3e0..67d793a4 100644 --- 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 @@ -1 +1,45 @@ -;; 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 +;; 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 + + 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 index 8f0cf36b..8ec81d34 100644 --- a/internal/test/LANGUAGE/from-sun/language/12/12-9-RANDOM.TEST +++ b/internal/test/LANGUAGE/from-sun/language/12/12-9-RANDOM.TEST @@ -1 +1,84 @@ -;; 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 +;; 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 + + 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 index 6ba9f51f..491efbde 100644 --- a/internal/test/LANGUAGE/from-sun/language/13/13-1-CHARACTERATTRIBUTES.TEST +++ b/internal/test/LANGUAGE/from-sun/language/13/13-1-CHARACTERATTRIBUTES.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 + 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 index 0fb11db3..bcf3e6a8 100644 --- 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 @@ -1 +1,42 @@ -;; 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 +;; 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 + 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 index 5b30e9bc..47b9d504 100644 --- 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 @@ -1 +1,12 @@ -;;; 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 +;;; 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 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 index 0700beb3..c6bb41a1 100644 --- 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 @@ -1 +1,37 @@ -;; 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 +;; 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 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 index 24d1d0b1..30cfb00c 100644 --- 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 @@ -1 +1,60 @@ -;; 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 +;; 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 + 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 index 2bac3b1c..19040c02 100644 --- 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 @@ -1 +1,66 @@ -;; 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 +;; 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 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 index dd4ebb16..a69cc90c 100644 --- 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 @@ -1 +1,63 @@ -;; 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 +;; 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 + 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 index bb4015fe..2efaad76 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 + 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 index 8e96b430..bd757409 100644 --- 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 @@ -1 +1,66 @@ -;; 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 +;; 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 + + 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 index 84faa429..1a7617c5 100644 --- 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 @@ -1 +1,65 @@ -;; 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 +;; 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 + 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 index ccaa20c2..bcf54857 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 + 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 index 985e335e..84496cf1 100644 --- 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 @@ -1 +1,53 @@ -;; 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 +;; 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 + 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 index ee495066..90689e76 100644 --- 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 @@ -1 +1,70 @@ -;; 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 +;; 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 + + 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 index 05d2709c..0ee068f0 100644 --- 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 @@ -1 +1,71 @@ -;; 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 +;; 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 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 index 046f6742..c1d9033d 100644 --- a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAREQ.TEST +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHAREQ.TEST @@ -1 +1,51 @@ -;; 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 +;; 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 + 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 index 34e231f9..b1445883 100644 --- a/internal/test/LANGUAGE/from-sun/language/13/13-2-CHARNEQ.TEST +++ b/internal/test/LANGUAGE/from-sun/language/13/13-2-CHARNEQ.TEST @@ -1 +1,48 @@ -;; 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 +;; 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 + 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 index 4e55389a..348ba5fc 100644 --- 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 @@ -1 +1,97 @@ -;; 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 +;; 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 + + 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 index c0c7c8e0..b182fe4f 100644 --- 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 @@ -1 +1,33 @@ -;; 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 +;; 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 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 index 3f6309a2..ce8f9671 100644 --- 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 @@ -1 +1,50 @@ -;; 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 +;; 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 + + 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 index a2fbb065..4d5fe93c 100644 --- 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 @@ -1 +1,38 @@ -;; 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 +;; 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 + + 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 index 98491d60..fe3a05a6 100644 --- 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 @@ -1 +1,30 @@ -;; 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 +;; 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 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 index 9e3cee26..f9b7bc8e 100644 --- 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 @@ -1 +1,51 @@ -;; 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 +;; 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 + + 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 index 68b2f87b..35f57e50 100644 --- 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 @@ -1 +1,14 @@ -;; 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 +;; 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 + 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 index b9695335..6e3bea2a 100644 --- 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 @@ -1 +1,14 @@ -;; 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 +;; 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 + 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 index 1fecd176..fa5f4d3c 100644 --- 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 @@ -1 +1,12 @@ -;; 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 +;; 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 + 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 index 54459050..daff5a69 100644 --- 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 @@ -1 +1,12 @@ -;; 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 +;; 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 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 index 75c49c63..f7c3292c 100644 --- 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 @@ -1 +1,12 @@ -;; 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 +;; 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 + 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 index 3b12e93b..16bf5bdb 100644 --- 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 @@ -1 +1,43 @@ -;; 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 +;; 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 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 index c02df2ee..4b871eda 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 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 index e5d660e8..9fc67cb6 100644 --- 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 @@ -1 +1,36 @@ -;; 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 +;; 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 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 index d7e69c5b..04359293 100644 --- 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 @@ -1 +1,44 @@ -;; 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 +;; 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 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 index c8557934..7294ddcd 100644 --- a/internal/test/LANGUAGE/from-sun/language/13/13-4-CHARACTER.TEST +++ b/internal/test/LANGUAGE/from-sun/language/13/13-4-CHARACTER.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 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 index 0c2d5284..9bbd9905 100644 --- 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 @@ -1 +1,65 @@ -;; 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 +;; 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 + 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 index 3d8b8ca8..cd809073 100644 --- 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 @@ -1 +1,38 @@ -;; 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 +;; 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 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 index f68dacbf..8810bcd5 100644 --- 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 @@ -1 +1,34 @@ -;; 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 +;; 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 + 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 index 31e39e3f..c8257bc5 100644 --- 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 @@ -1 +1,40 @@ -;; 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 +;; 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 index d8c11c42..dc4cf42f 100644 --- 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 @@ -1 +1,41 @@ -;; 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 +;; 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 + 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 index e140b9fa..775328c4 100644 --- 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 @@ -1 +1,42 @@ -;; 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 +;; 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 index 51ae7a5c..9e0d70af 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-1-ELT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-ELT.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 index 898c347c..a5f54e2c 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-1-LENGTH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-LENGTH.TEST @@ -1 +1,56 @@ -;; 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 +;; 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 + + + 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 index abd1b5b3..6a830be7 100644 --- 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 @@ -1 +1,62 @@ -;; 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 +;; 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 index 75aa0b76..82670eb4 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-1-NREVERSE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-NREVERSE.TEST @@ -1 +1,70 @@ -;; 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 +;; 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 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 index 9498370a..30514695 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-1-REVERSE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-REVERSE.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 + + + 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 index 702c210f..7d2041e4 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-1-SUBSEQ.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-1-SUBSEQ.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 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 index 5d0c76f5..4e36844c 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-2-CONCATENATE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-CONCATENATE.TEST @@ -1 +1,102 @@ -;; 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 +;; 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 + + + 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 index e6aada0e..5caf49a4 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-2-EVERY.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-EVERY.TEST @@ -1 +1,172 @@ -;; 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 +;; 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 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 index 14a6add4..ff494b93 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-2-MAP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-MAP.TEST @@ -1 +1,98 @@ -;; 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 +;; 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 + + + + + + + + + + + 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 index 1912c143..91c80e39 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-2-NOTANY.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-NOTANY.TEST @@ -1 +1,174 @@ -;; 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 +;; 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 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 index 06096cd3..9c470f44 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-2-NOTEVERY.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-NOTEVERY.TEST @@ -1 +1,171 @@ -;; 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 +;; 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 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 index 3402dd19..584f4cb8 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-2-REDUCE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-REDUCE.TEST @@ -1 +1,128 @@ -;; 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 +;; 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 + + + + + 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 index 2170078f..39147005 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-2-SOME.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-2-SOME.TEST @@ -1 +1,165 @@ -;; 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 +;; 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 index 8adae10f..6e466a7b 100644 --- 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 @@ -1 +1,98 @@ -;; 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 +;; 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 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 index 0a7b32a2..a7ba8d25 100644 --- 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 @@ -1 +1,110 @@ -;; 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 +;; 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 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 index 1494ba45..4f9c6704 100644 --- 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 @@ -1 +1,88 @@ -;; 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 +;; 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 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 index c616dfa8..847fb120 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-DELETE.TEST @@ -1 +1,106 @@ -;; 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 +;; 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 + 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 index 52b9ae32..8248dbeb 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-3-FILL.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-FILL.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 index 8b70b167..1a3a6a46 100644 --- 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 @@ -1 +1,89 @@ -;; 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 +;; 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 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 index 304d86da..cdd2de9f 100644 --- 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 @@ -1 +1,94 @@ -;; 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 +;; 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 + + + + + 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 index a0cc9b79..e773fa8e 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-3-FIND.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-FIND.TEST @@ -1 +1,99 @@ -;; 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 +;; 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 + 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 index b0ece777..ecc6b93a 100644 --- 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 @@ -1 +1,119 @@ -;; 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 +;; 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 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 index 21c5bed5..24323cfe 100644 --- 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 @@ -1 +1,117 @@ -;; 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 +;; 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 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 index d513af5c..2b8fef19 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-NSUBSTITUTE.TEST @@ -1 +1,113 @@ -;; 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 +;; 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 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 index 3d02b322..615f1f0e 100644 --- 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 @@ -1 +1,118 @@ -;; 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 +;; 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 + + + + + + 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 index c83cabb7..7ecdd7ee 100644 --- 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 @@ -1 +1,114 @@ -;; 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 +;; 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 + + + 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 index 13a09b16..d3faa709 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-POSITION.TEST @@ -1 +1,120 @@ -;; 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 +;; 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 + + + + + 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 index c07cd640..45b35b2a 100644 --- 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 @@ -1 +1,107 @@ -;; 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 +;; 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 + + + + + + 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 index 2f3d448f..c58212dc 100644 --- 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 @@ -1 +1,116 @@ -;; 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 +;; 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 + + 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 index d01873f3..bdfd7a5a 100644 --- 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 @@ -1 +1,92 @@ -;; 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 +;; 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 index f3819eb8..309482ad 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-REMOVE.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 index 7f6844c2..d05c1b57 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-3-REPLACE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-REPLACE.TEST @@ -1 +1,93 @@ -;; 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 +;; 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 index 78f01f1c..6ac75aa2 100644 --- 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 @@ -1 +1,124 @@ -;; 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 +;; 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 + 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 index 322124da..5f417389 100644 --- 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 @@ -1 +1,125 @@ -;; 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 +;; 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 + + + + 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 index e287df81..02b83568 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-3-SUBSTITUTE.TEST @@ -1 +1,115 @@ -;; 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 +;; 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 + + + + 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 index dbf5f110..ddc6bc72 100644 --- 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 @@ -1 +1,113 @@ -;; 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 +;; 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 + 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 index 94a5436c..b4d6d45b 100644 --- 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 @@ -1 +1,110 @@ -;; 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 +;; 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 index d08abd12..60ecb60b 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-4-COUNT.TEST @@ -1 +1,123 @@ -;; 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 +;; 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 + + + + + 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 index 512c2c57..b6fa688a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/14/14-4-MISMATCH.TEST 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 index 2eb14b40..224ef197 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-5-MERGE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-5-MERGE.TEST @@ -1 +1,110 @@ -;; 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 +;; 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 index 56d3bdfb..d65a5ac9 100644 --- a/internal/test/LANGUAGE/from-sun/language/14/14-5-SORT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/14/14-5-SORT.TEST @@ -1 +1,156 @@ -;; 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 +;; 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 + 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 index d7ed26dc..e52d2b11 100644 --- 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 @@ -1 +1,98 @@ -;; 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 +;; 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 + + + 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 index 8bc10e7b..6edf6a89 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAAR.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 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 index bfc51e5b..1fe4611b 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAADR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAADR.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 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 index f69c8d2e..bb0d222a 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAAR.TEST @@ -1 +1,76 @@ -;; 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 +;; 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 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 index 62d75336..14819da3 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADAR.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 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 index b1da8fbd..ffcb2c33 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADDR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADDR.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 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 index 7e840c66..70469a15 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAADR.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 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% index 2d84c532..d0095715 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAR.TEST% +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CAAR.TEST% @@ -1 +1,78 @@ -;; 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 +;; 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 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 index 3917deae..57c00e5b 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CADAA.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADAA.TEST @@ -1 +1,75 @@ -;; 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 +;; 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 + + 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 index c062e54f..aace6420 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CADADR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADADR.TEST @@ -1 +1,66 @@ -;; 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 +;; 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 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 index 1dc03d8e..7675d81c 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CADAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADAR.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 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 index 84eb1ed0..58125a37 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CADDAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CADDAR.TEST @@ -1 +1,83 @@ -;; 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 +;; 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 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 index 28e2c183..e06988b1 100644 --- 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 @@ -1 +1,110 @@ -;; 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 +;; 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 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 index 1916213f..02cdea7c 100644 --- 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 @@ -1 +1,81 @@ -;; 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 +;; 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 + 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 index ad41c510..24f13040 100644 --- 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 @@ -1 +1,91 @@ -;; 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 +;; 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 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 index 1b674a6e..f6576869 100644 --- 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 @@ -1 +1,106 @@ -;; 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 +;; 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 + + + 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 index 46157704..bbb5c226 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAAR.TEST @@ -1 +1,75 @@ -;; 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 +;; 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 + 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 index 73e6ae4e..d1a9c1b8 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAADR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAADR.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 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 index 6afd886e..048a9886 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAAR.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 + + 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 index dc25210d..e7f2f420 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADAR.TEST @@ -1 +1,81 @@ -;; 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 +;; 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 + 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 index 9e090923..274f4abe 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADDR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADDR.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 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 index 7dd21de2..06d438c5 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDADR.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 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 index 0274dc45..f057cfe3 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDAR.TEST @@ -1 +1,82 @@ -;; 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 +;; 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 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 index af6b10b6..d54e1774 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAAR.TEST @@ -1 +1,82 @@ -;; 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 +;; 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 + + 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 index bd2bd0d6..06584140 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDADR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDADR.TEST @@ -1 +1,81 @@ -;; 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 +;; 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 + 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 index 0267abde..1b5c0991 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDAR.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 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 index cde4b41f..15d9554d 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDAR.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 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 index f31feeaf..8367bd55 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDDR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDDR.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 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 index aaccb9ce..d71970de 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDDR.TEST @@ -1 +1,65 @@ -;; 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 +;; 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 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 index 1b4c015a..341f675e 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CDDR.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 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 index 55226dff..e72a30c9 100644 --- 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 @@ -1 +1,99 @@ -;; 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 +;; 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 + + + + + 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 index fdc8b63a..a4a28b19 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-1-CONS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-1-CONS.TEST @@ -1 +1,70 @@ -;; 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 +;; 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 index e2d9d5af..79f887fb 100644 --- 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 @@ -1 +1,136 @@ -;; 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 +;; 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 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 index d5d9ff6c..0032e705 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-APPEND.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-APPEND.TEST @@ -1 +1,125 @@ -;; 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 +;; 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 index 64972995..6ee08d69 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-BUTLAST.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-BUTLAST.TEST @@ -1 +1,80 @@ -;; 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 +;; 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 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 index cde32c74..6d60b28a 100644 --- 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 @@ -1 +1,149 @@ -;; 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 +;; 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 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 index 3322b2a7..ab9bcfab 100644 --- 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 @@ -1 +1,111 @@ -;; 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 +;; 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 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 index 8266135c..d7d5a55d 100644 --- 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 @@ -1 +1,205 @@ -;; 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 +;; 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 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 index 068bfa28..7117ece5 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-EIGHTH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-EIGHTH.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 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 index db9ef8a2..63fade9d 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-ENDP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-ENDP.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 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 index bb6a08f6..236ae2e7 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-FIFTH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-FIFTH.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 index 06dfcebe..ec755136 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-FIRST.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-FIRST.TEST @@ -1 +1,45 @@ -;; 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 +;; 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 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 index a46241b8..4d1910f4 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-FOURTH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-FOURTH.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 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 index 1070043d..43c2d19d 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-LAST.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-LAST.TEST @@ -1 +1,63 @@ -;; 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 +;; 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 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 index 39fdab24..856461c6 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-LDIFF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-LDIFF.TEST @@ -1 +1,95 @@ -;; 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 +;; 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 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 index 4c9cb4ae..ced3671c 100644 --- 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 @@ -1 +1,107 @@ -;; 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 +;; 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 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 index 9fded9c0..96a351e0 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-LIST.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-LIST.TEST @@ -1 +1,94 @@ -;; 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 +;; 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 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 index 0d749cc5..d2f86ce8 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST @@ -1 +1,91 @@ -;; 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 +;; 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 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% index 0d749cc5..d2f86ce8 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST% +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-LISTSTAR.TEST% @@ -1 +1,91 @@ -;; 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 +;; 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 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 index d3f6f51e..4fdc39da 100644 --- 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 @@ -1 +1,87 @@ -;; 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 +;; 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 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 index d39ec692..be77dc05 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-NBUTLAST.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NBUTLAST.TEST @@ -1 +1,120 @@ -;; 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 +;; 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 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 index 27d75656..7b0ff9ba 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-NCONC.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NCONC.TEST @@ -1 +1,77 @@ -;; 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 +;; 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 index 910353f4..d6f196ac 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-NINTH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NINTH.TEST @@ -1 +1,110 @@ -;; 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 +;; 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 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 index e23d2263..a8994f79 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-NRECONC.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NRECONC.TEST @@ -1 +1,72 @@ -;; 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 +;; 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 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 index 5021c8a1..30dcb992 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-NTH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NTH.TEST @@ -1 +1,97 @@ -;; 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 +;; 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 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 index 86d02e65..d05fd8cd 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-NTHCDR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-NTHCDR.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 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 index 79da7ff4..a2004194 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-POP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-POP.TEST @@ -1 +1,74 @@ -;; 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 +;; 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 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 index 544f85db..29753275 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-PUSH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-PUSH.TEST @@ -1 +1,97 @@ -;; 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 +;; 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 index 6c799b68..54f31ac7 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-PUSHNEW.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-PUSHNEW.TEST @@ -1 +1,97 @@ -;; 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 +;; 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 index 9e8b6a2d..cb519d35 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-REST.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-REST.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 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 index 699a1689..2c6541f4 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-REVAPPEND.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-REVAPPEND.TEST @@ -1 +1,73 @@ -;; 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 +;; 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 index 663182fe..1e64f41d 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-SECOND.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-SECOND.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 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 index 65935dd9..a8297ac3 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-SEVENTH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-SEVENTH.TEST @@ -1 +1,107 @@ -;; 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 +;; 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 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 index fc9a6f47..824027b8 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-SIXTH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-SIXTH.TEST @@ -1 +1,93 @@ -;; 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 +;; 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 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 index eb5e02b1..3c6dd5af 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-TENTH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-TENTH.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 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 index 35544af1..74f1ad49 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-2-THIRD.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-2-THIRD.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 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 index 498662db..fb7ec66b 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACA.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACA.TEST @@ -1 +1,90 @@ -;; 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 +;; 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 index 108c1aec..ae672926 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACD.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-3-RPLACD.TEST @@ -1 +1,89 @@ -;; 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 +;; 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 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 index 6f10300b..96c18567 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBLIS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBLIS.TEST @@ -1 +1,103 @@ -;; 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 +;; 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 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 index ba503349..a251e08a 100644 --- 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 @@ -1 +1,97 @@ -;; 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 +;; 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 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 index a9e158bc..757d6f71 100644 --- 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 @@ -1 +1,92 @@ -;; 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 +;; 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 index 49f804c8..a8b64c73 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-NSUBST.TEST @@ -1 +1,115 @@ -;; 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 +;; 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 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 index 7822dba4..4ce4dd22 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBLIS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBLIS.TEST @@ -1 +1,165 @@ -;; 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 +;; 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 index ec080eb9..fecaf46d 100644 --- 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 @@ -1 +1,132 @@ -;; 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 +;; 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 index bae6a2c8..2743f23d 100644 --- 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 @@ -1 +1,143 @@ -;; 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 +;; 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 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 index a89e7d9b..317703ea 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-4-SUBST.TEST @@ -1 +1,199 @@ -;; 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 +;; 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 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 index 1ffecac0..28f3cf8c 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-5-ADJOIN.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-ADJOIN.TEST @@ -1 +1,102 @@ -;; 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 +;; 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 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 index a38e06aa..10e9b43a 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-5-INTERSECTION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-INTERSECTION.TEST @@ -1 +1,156 @@ -;; 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 +;; 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 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 index a3643836..249a5d2b 100644 --- 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 @@ -1 +1,101 @@ -;; 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 +;; 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 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 index ff8f8f08..52ea4ac8 100644 --- 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 @@ -1 +1,96 @@ -;; 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 +;; 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 index e9d578a4..c72a9147 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-MEMBER.TEST @@ -1 +1,110 @@ -;; 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 +;; 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 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 index 8296be08..d8bc6812 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-5-NINTERSECTION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-NINTERSECTION.TEST @@ -1 +1,143 @@ -;; 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 +;; 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 index f2e3cd0d..23df84a7 100644 --- 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 @@ -1 +1,234 @@ -;; 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 +;; 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 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 index d82c3e71..f7fb46b3 100644 --- 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 @@ -1 +1,237 @@ -;; 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 +;; 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 + + + + 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 index f61c1bf5..23c8aeda 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-5-NUNION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-NUNION.TEST @@ -1 +1,160 @@ -;; 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 +;; 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 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 index c5a83454..d775a8d2 100644 --- 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 @@ -1 +1,235 @@ -;; 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 +;; 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 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 index 25d653dc..bfdf157e 100644 --- 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 @@ -1 +1,236 @@ -;; 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 +;; 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 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 index e5dc5abc..f3d4a478 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-5-SUBSETP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-SUBSETP.TEST @@ -1 +1,92 @@ -;; 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 +;; 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 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 index 2e0cd1c1..cd334fbd 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-5-TAILP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-TAILP.TEST @@ -1 +1,71 @@ -;; 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 +;; 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 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 index 172f1a64..5b9d0105 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-5-UNION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-5-UNION.TEST @@ -1 +1,169 @@ -;; 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 +;; 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 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 index 5808af45..38173222 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-6-ACONS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-ACONS.TEST @@ -1 +1,507 @@ -;; 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 +;; 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 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 index ca024c6e..cdd1ebf4 100644 --- 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 @@ -1 +1,128 @@ -;; 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 +;; 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 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 index 4e5c903a..f570a215 100644 --- 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 @@ -1 +1,128 @@ -;; 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 +;; 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 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 index a4c544e6..b7ecd130 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-ASSOC.TEST @@ -1 +1,153 @@ -;; 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 +;; 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 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 index f7354cc2..d57695ea 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-6-PAIRLIS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-PAIRLIS.TEST @@ -1 +1,843 @@ -;; 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 +;; 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 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 index af7006da..08846b9a 100644 --- 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 @@ -1 +1,83 @@ -;; 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 +;; 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 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 index f937f1e9..27e163ed 100644 --- 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 @@ -1 +1,82 @@ -;; 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 +;; 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 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 index a943d7fd..59772c2a 100644 --- a/internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC.TEST +++ b/internal/test/LANGUAGE/from-sun/language/15/15-6-RASSOC.TEST @@ -1 +1,142 @@ -;; 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 +;; 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 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 index 0bd3de14..d3eb5903 100644 --- a/internal/test/LANGUAGE/from-sun/language/16/16-1-CLRHASH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/16/16-1-CLRHASH.TEST @@ -1 +1,47 @@ -;; 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 +;; 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 index bccc0f21..165e58fa 100644 --- a/internal/test/LANGUAGE/from-sun/language/16/16-1-GETHASH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/16/16-1-GETHASH.TEST @@ -1 +1,50 @@ -;; 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 +;; 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 + + + + + + + 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 index ec36ed7f..b3320cbd 100644 --- 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 @@ -1 +1,49 @@ - ;; 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 + + +;; 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 + 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 index 309a7c4b..2743b59c 100644 --- 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 @@ -1 +1,38 @@ -;; 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 +;; 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 + + + + + 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 index af990a4e..23481494 100644 --- 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 @@ -1 +1,55 @@ -;; 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 +;; 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 + + + + + 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 index ef3f10b9..f9d5e187 100644 --- a/internal/test/LANGUAGE/from-sun/language/16/16-1-MAPHASH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/16/16-1-MAPHASH.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 + 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 index f88d638a..7b002433 100644 --- a/internal/test/LANGUAGE/from-sun/language/16/16-1-REMHASH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/16/16-1-REMHASH.TEST @@ -1 +1,48 @@ -;; 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 +;; 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 + 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 index 73003850..3190798e 100644 --- a/internal/test/LANGUAGE/from-sun/language/16/16-2-SXHASH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/16/16-2-SXHASH.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 + 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 index d6063c27..a8349951 100644 --- 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 @@ -1 +1,90 @@ -;; 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 +;; 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 + + + 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 index 0e1f5758..0f56619e 100644 --- a/internal/test/LANGUAGE/from-sun/language/17/17-1-VECTOR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/17/17-1-VECTOR.TEST @@ -1 +1,37 @@ -;; 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 +;; 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 index ffa81763..25737792 100644 --- a/internal/test/LANGUAGE/from-sun/language/17/17-2-AREF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/17/17-2-AREF.TEST @@ -1 +1,84 @@ -;; 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 +;; 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 + 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 index 83186fc2..7aca6daf 100644 --- a/internal/test/LANGUAGE/from-sun/language/17/17-2-SVREF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/17/17-2-SVREF.TEST @@ -1 +1,49 @@ -;; 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 +;; 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 index 9847736a..298e0e2e 100644 --- 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 @@ -1 +1,38 @@ -;; 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 +;; 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 + 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 index 79ec7a45..97a9f060 100644 --- 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 @@ -1 +1,49 @@ -;; 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 +;; 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 index c129f905..533182b0 100644 --- 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 @@ -1 +1,40 @@ -;; 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 +;; 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 index c7d6edc2..093676af 100644 --- 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 @@ -1 +1,63 @@ -;; 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 +;; 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 + + 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 index 21f5c6d4..2cac627f 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 index d60245ae..7f6dd83b 100644 --- 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 @@ -1 +1,35 @@ -;; 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 +;; 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 + + 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 index f4826b1f..360cdabf 100644 --- 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 @@ -1 +1,57 @@ -;; 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 +;; 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 + + 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 index 1658f86f..56394101 100644 --- 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 @@ -1 +1,42 @@ -;; 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 +;; 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 index bed57802..37149a0c 100644 --- 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 @@ -1 +1,56 @@ -;; 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 +;; 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 + + 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 index b7df0b8c..b21a7d98 100644 --- 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 @@ -1 +1,59 @@ -;; 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 +;; 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 + + 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 index 5db40ae8..8debd803 100644 --- 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 @@ -1 +1,60 @@ -;; 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 +;; 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 + + 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 index 53e3384f..564ee646 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 + + 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 index 63f97d35..1e67b97c 100644 --- 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 @@ -1 +1,57 @@ -;; 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 +;; 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 + + 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 index c110bcfb..9eb81b2e 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 + + 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 index 8af6e987..20c1e8c1 100644 --- 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 @@ -1 +1,57 @@ -;; 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 +;; 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 + 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 index a7888845..7a3c40f3 100644 --- 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 @@ -1 +1,55 @@ -;; 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 +;; 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 + + 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 index 8b3efc6c..2d863935 100644 --- 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 @@ -1 +1,60 @@ -;; 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 +;; 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 + + 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 index 22c576a6..212f0f8b 100644 --- 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 @@ -1 +1,59 @@ -;; 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 +;; 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 + + 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 index a5beaa48..09fa91ea 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 + + 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 index fb0bf382..c5b165a8 100644 --- a/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-BIT.TEST @@ -1 +1,61 @@ -;; 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 +;; 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 index be82d0ed..36125e3b 100644 --- a/internal/test/LANGUAGE/from-sun/language/17/17-4-SBIT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/17/17-4-SBIT.TEST @@ -1 +1,69 @@ -;; 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 +;; 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 index cf7d974f..1c2a9c8b 100644 --- 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 @@ -1 +1,46 @@ -;; 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 +;; 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 index 6cecc824..108b563d 100644 --- 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 @@ -1 +1,35 @@ -;; 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 +;; 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 index 3260d089..1fe00149 100644 --- 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 @@ -1 +1,59 @@ -;; 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 +;; 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 + + + + + + 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 index d1604cb6..eec1782e 100644 --- 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 @@ -1 +1,86 @@ -;; 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 +;; 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 + + 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 index 7cc60c4c..448c2706 100644 --- 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 @@ -1 +1,48 @@ -;; 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 +;; 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 index 7d98cd49..ca568306 100644 --- 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 @@ -1 +1,68 @@ -;; 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 +;; 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 index 1e3948a1..cbbd6086 100644 --- a/internal/test/LANGUAGE/from-sun/language/18/18-1-CHAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/18/18-1-CHAR.TEST @@ -1 +1,94 @@ -;; 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 +;; 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 + 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 index dc9e57ca..1f94626e 100644 --- a/internal/test/LANGUAGE/from-sun/language/18/18-1-SCHAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/18/18-1-SCHAR.TEST @@ -1 +1,63 @@ -;; 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 +;; 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 + 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 index a876b91f..aa99dd60 100644 --- 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 @@ -1 +1,110 @@ -;; 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 +;; 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 + 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 index e2a31638..682cc617 100644 --- 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 @@ -1 +1,140 @@ -;; 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 +;; 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 index 8da811e9..289d5301 100644 --- 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 @@ -1 +1,101 @@ -;; 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 +;; 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 + 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 index 3d4ee62e..ece83730 100644 --- 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 @@ -1 +1,100 @@ -;; 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 +;; 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 + 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 index ce920762..febdbe96 100644 --- 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 @@ -1 +1,102 @@ -;; 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 +;; 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 + 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 index 4297f1e2..c0e9b23c 100644 --- 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 @@ -1 +1,102 @@ -;; 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 +;; 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 + 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 index c5b91b3f..e0393916 100644 --- 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 @@ -1 +1,94 @@ -;; 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 +;; 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 + 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 index 2b525511..3ff8b68c 100644 --- 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 @@ -1 +1,96 @@ -;; 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 +;; 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 + 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 index a0072a97..1c1ecadb 100644 --- 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 @@ -1 +1,48 @@ -;; 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 +;; 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 + 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 index fdf82187..95aab6e2 100644 --- 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 @@ -1 +1,48 @@ -;; 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 +;; 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 + 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 index 2b8d445a..b2f6815a 100644 --- 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 @@ -1 +1,98 @@ -;; 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 +;; 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 + 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 index ef6d5eed..fd83023a 100644 --- 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 @@ -1 +1,101 @@ -;; 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 +;; 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 + 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 index ed283579..33ef9707 100644 --- 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 @@ -1 +1,38 @@ -;; 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 +;; 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 + 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 index b99edf24..f23a0708 100644 --- 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 @@ -1 +1,59 @@ -;; 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 +;; 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 + 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 index d8339999..7e2681e4 100644 --- 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 @@ -1 +1,61 @@ -;; 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 +;; 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 + 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 index fe140aa0..9e8695e2 100644 --- 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 @@ -1 +1,57 @@ -;; 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 +;; 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 + 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 index 054552f4..28bf4f58 100644 --- 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 @@ -1 +1,40 @@ -;; 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 +;; 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 + 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 index b58d570e..34e1c7ad 100644 --- 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 @@ -1 +1,51 @@ -;; 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 +;; 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 + 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 index 7452492e..008a03f6 100644 --- 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 @@ -1 +1,68 @@ -;; 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 +;; 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 + 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 index 2b83dfce..2c34dddc 100644 --- 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 @@ -1 +1,66 @@ -;; 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 +;; 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 + 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 index 8c606cf4..c0ae8a6b 100644 --- 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 @@ -1 +1,64 @@ -;; 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 +;; 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 + 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 index 16797e06..1bda60b0 100644 --- 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 @@ -1 +1,50 @@ -;; 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 +;; 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 + 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 index 98281d43..0862091e 100644 --- a/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING.TEST +++ b/internal/test/LANGUAGE/from-sun/language/18/18-3-STRING.TEST @@ -1 +1,79 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/19/19-DEFSTRUCT.TEST b/internal/test/LANGUAGE/from-sun/language/19/19-DEFSTRUCT.TEST index 81539c3a..0f689be4 100644 --- a/internal/test/LANGUAGE/from-sun/language/19/19-DEFSTRUCT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/19/19-DEFSTRUCT.TEST @@ -1 +1,221 @@ -;; 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 +;; 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 + + + + 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 index fea98395..b22523ea 100644 --- a/internal/test/LANGUAGE/from-sun/language/20/20-1-APPLYHOOK.TEST +++ b/internal/test/LANGUAGE/from-sun/language/20/20-1-APPLYHOOK.TEST @@ -1 +1,85 @@ -;; 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 +;; 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 + + + + 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 index 00325f1c..d9f7f8c7 100644 --- a/internal/test/LANGUAGE/from-sun/language/20/20-1-CONSTANTP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/20/20-1-CONSTANTP.TEST @@ -1 +1,53 @@ -;; 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 +;; 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 + + + 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 index 9b2f8068..bda5e6e5 100644 --- a/internal/test/LANGUAGE/from-sun/language/20/20-1-EVAL.TEST +++ b/internal/test/LANGUAGE/from-sun/language/20/20-1-EVAL.TEST @@ -1 +1,72 @@ -;; 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 +;; 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 + + 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 index 513115bf..7233fd01 100644 --- 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 @@ -1 +1,103 @@ -;; 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 +;; 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 + 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 index c99ae066..8b4bcae0 100644 --- 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 @@ -1 +1,85 @@ -;; 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 +;; 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 + 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 index 7d55ddf2..533a7364 100644 --- 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 @@ -1 +1,81 @@ -;; 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 +;; 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 + + 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 index 8b810733..ba80c5e3 100644 --- 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 @@ -1 +1,90 @@ -;; 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 +;; 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 + 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 index 8999ca0e..a43481f6 100644 --- 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 @@ -1 +1,56 @@ -;; 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 +;; 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 + 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 index 7d82235d..b78cb053 100644 --- 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 @@ -1 +1,90 @@ -;; 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 +;; 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 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 index 54ab5232..af407401 100644 --- 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 @@ -1 +1,116 @@ -;; 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 +;; 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 + + 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 index 661079fa..4e7278b8 100644 --- 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 @@ -1 +1,155 @@ -;; 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 +;; 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 + 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 index 4197f6fa..e0eb7815 100644 --- 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 @@ -1 +1,79 @@ -;; 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 +;; 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 + 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 index 04ca4bd0..b7df669b 100644 --- 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 @@ -1 +1,108 @@ -;; 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 +;; 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 + 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 index ba018aea..49f8bd9f 100644 --- 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 @@ -1 +1,103 @@ -;; 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 +;; 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 + 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 index 8056d490..fa595c39 100644 --- 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 @@ -1 +1,73 @@ -;; 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 +;; 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 + 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 index 06cf6d8d..7a1e2436 100644 --- 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 @@ -1 +1,85 @@ -;; 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 +;; 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 + 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 index ce9528ca..b167ba9a 100644 --- 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 @@ -1 +1,59 @@ -;; 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 +;; 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 + 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 index 4a3c4de2..8d920da5 100644 --- 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 @@ -1 +1,105 @@ -;; 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 +;; 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 + 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 index 84631a1d..2907d0c4 100644 --- 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 @@ -1 +1,75 @@ -;; 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 +;; 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 + 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 index df83a9ce..df2a0278 100644 --- 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 @@ -1 +1,69 @@ -;; 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 +;; 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 + 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 index baaf68b6..a0537ad4 100644 --- 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 @@ -1 +1,67 @@ -;; 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 +;; 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 + 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 index 1de5d522..df3d8981 100644 --- 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 @@ -1 +1,65 @@ -;; 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 +;; 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 index 2ab4ad5a..f382d524 100644 --- 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 @@ -1 +1,100 @@ -;; 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 +;; 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 + 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 index 6398d30c..8483b58f 100644 --- 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 @@ -1 +1,38 @@ -;; 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 +;; 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 + 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 index c9ffe3a3..ddecfbb5 100644 --- 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 @@ -1 +1,104 @@ -;; 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 +;; 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 + 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 index 5fbcfb26..a6763dec 100644 --- 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 @@ -1 +1,85 @@ -;; 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 +;; 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 + 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 index 2bf8b3e8..1d2b311f 100644 --- 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 @@ -1 +1,119 @@ -;; 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 +;; 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 + 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 index 7f8567cc..9658fdfc 100644 --- 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 @@ -1 +1,64 @@ -;; 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 +;; 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 + 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 index bfb6eb2f..aab9848f 100644 --- 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 @@ -1 +1,92 @@ -;; 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 +;; 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 + 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 index 0bc433d5..162c7f18 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 + 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 index 7c51263a..f31fee22 100644 --- 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 @@ -1 +1,57 @@ -;; 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 +;; 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 + 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 index 88fc2811..35b25859 100644 --- 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 @@ -1 +1,114 @@ -;; 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 +;; 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 + 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 index 95543859..78d39954 100644 --- 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 @@ -1 +1,114 @@ -;; 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 +;; 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 + 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 index 6c480bde..4689b30a 100644 --- 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 @@ -1 +1,607 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/23/.DFASL b/internal/test/LANGUAGE/from-sun/language/23/.DFASL index e838a888..5c218df0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/23/.DFASL 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 index 96439b8e..067c60b9 100644 --- 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 @@ -1 +1,93 @@ -;; 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 +;; 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 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 index 2b549251..d437eacd 100644 --- 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 @@ -1 +1,78 @@ -;; 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 +;; 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 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 index 89590449..4df27466 100644 --- 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 @@ -1 +1,116 @@ -;; 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 +;; 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 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 index ca07f46a..21b4958c 100644 --- 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 @@ -1 +1,148 @@ -;; 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 +;; 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 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 index 7fc34957..b22c50bb 100644 --- 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 @@ -1 +1,79 @@ -;; 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 +;; 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 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 index 5a8a3b2a..e1712344 100644 --- 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 @@ -1 +1,183 @@ -;; 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 +;; 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 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 index dea52dd5..2d09cd13 100644 --- 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 @@ -1 +1,201 @@ -;; 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 +;; 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 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 index 483648a7..6b939e96 100644 --- 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 @@ -1 +1,133 @@ -;; 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 +;; 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 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 index cf47c8e2..c784fa10 100644 --- 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 @@ -1 +1,120 @@ -;; 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 +;; 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 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 index b95e6135..b2f15300 100644 --- 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 @@ -1 +1,105 @@ -;; 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 +;; 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 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 index 595ace2a..a9c92e7c 100644 --- 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 @@ -1 +1,80 @@ -;; 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 +;; 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 + 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 index c2aae103..6ccb5968 100644 --- 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 @@ -1 +1,120 @@ -;; 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 +;; 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 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 index 356d4e7d..13937602 100644 --- 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 @@ -1 +1,62 @@ -;; 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 +;; 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 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 index 97e8a32a..eeaf1b77 100644 --- 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 @@ -1 +1,37 @@ -;; 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 +;; 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 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 index 0c48fea4..3101458d 100644 --- a/internal/test/LANGUAGE/from-sun/language/23/23-2-OPEN.X +++ b/internal/test/LANGUAGE/from-sun/language/23/23-2-OPEN.X @@ -1 +1,88 @@ -;; 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 +;; 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 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 index fbded6be..d606de9f 100644 --- 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 @@ -1 +1,96 @@ -;; 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 +;; 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 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 index 83445c26..a9423129 100644 --- 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 @@ -1 +1,116 @@ -;; 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 +;; 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 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 index e5eddf73..6a303fbf 100644 --- 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 @@ -1 +1,87 @@ -;; 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 +;; 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 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 index e1112d42..77514b1d 100644 --- 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 @@ -1 +1,107 @@ -;; 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 +;; 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 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 index 1741b057..82264f6c 100644 --- 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 @@ -1 +1,110 @@ -;; 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 +;; 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 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 index e406446e..12fc9ca8 100644 --- 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 @@ -1 +1,114 @@ -;; 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 +;; 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 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 index 0c4c9141..c8542ec6 100644 --- 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 @@ -1 +1,143 @@ -;; 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 +;; 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 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 index b1842f4f..28b2f433 100644 --- 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 @@ -1 +1,142 @@ -;; 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 +;; 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 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 index efae9ef0..8ec1e90b 100644 --- a/internal/test/LANGUAGE/from-sun/language/23/23-4-LOAD.X +++ b/internal/test/LANGUAGE/from-sun/language/23/23-4-LOAD.X @@ -1 +1,64 @@ -;; 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 +;; 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 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 index 3095dd91..a033222e 100644 --- a/internal/test/LANGUAGE/from-sun/language/23/23-5-DIRECTORY.X +++ b/internal/test/LANGUAGE/from-sun/language/23/23-5-DIRECTORY.X @@ -1 +1,71 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS b/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS index 02f9806e..ced8c03a 100644 --- a/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS +++ b/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS @@ -1 +1,1220 @@ -(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 +(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 diff --git a/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS.DEF b/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS.DEF index 03633f89..62ee4d4f 100644 --- a/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS.DEF +++ b/internal/test/LANGUAGE/from-sun/language/23/23-FUNCTIONS.DEF @@ -1 +1,206 @@ -;; 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 +;; 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)) + 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 index ecedf8b4..23f16332 100644 --- a/internal/test/LANGUAGE/from-sun/language/24/24-1-BREAK.TEST +++ b/internal/test/LANGUAGE/from-sun/language/24/24-1-BREAK.TEST @@ -1 +1,96 @@ -;; 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 +;; 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 + + 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 index 685963ab..92650881 100644 --- a/internal/test/LANGUAGE/from-sun/language/24/24-1-CERROR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/24/24-1-CERROR.TEST @@ -1 +1,140 @@ -;; 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 +;; 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 + + 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 index d69b96ba..0cceb4a4 100644 --- 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 @@ -1 +1,122 @@ -;; 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 +;; 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 + + 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 index 2b3299b9..34b022c6 100644 --- a/internal/test/LANGUAGE/from-sun/language/24/24-1-ERROR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/24/24-1-ERROR.TEST @@ -1 +1,61 @@ -;; 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 +;; 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 + + 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 index 92d82df0..6774ed9e 100644 --- a/internal/test/LANGUAGE/from-sun/language/24/24-1-WARN.TEST +++ b/internal/test/LANGUAGE/from-sun/language/24/24-1-WARN.TEST @@ -1 +1,84 @@ -;; 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 +;; 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 + + 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 index 951a7605..e16f5b71 100644 --- a/internal/test/LANGUAGE/from-sun/language/24/24-2-ASSERT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/24/24-2-ASSERT.TEST @@ -1 +1,111 @@ -;; 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 +;; 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 + + + 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 index 32af5748..2cbf1830 100644 --- a/internal/test/LANGUAGE/from-sun/language/24/24-3-CCASE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/24/24-3-CCASE.TEST @@ -1 +1,74 @@ -;; 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 +;; 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 + + + 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 index 149819cf..4bb710a3 100644 --- a/internal/test/LANGUAGE/from-sun/language/24/24-3-CTYPECASE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/24/24-3-CTYPECASE.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 + + + 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 index 8b8024ed..d5bc155a 100644 --- a/internal/test/LANGUAGE/from-sun/language/24/24-3-ECASE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/24/24-3-ECASE.TEST @@ -1 +1,70 @@ -;; 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 +;; 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 + + + 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 index f46afc84..f35b7a49 100644 --- a/internal/test/LANGUAGE/from-sun/language/24/24-3-ETYPECASE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/24/24-3-ETYPECASE.TEST @@ -1 +1,62 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/LANGUAGE/from-sun/language/24/24-ERRORSYSTEM.X b/internal/test/LANGUAGE/from-sun/language/24/24-ERRORSYSTEM.X index a977bfb3..b1bf47a0 100644 --- a/internal/test/LANGUAGE/from-sun/language/24/24-ERRORSYSTEM.X +++ b/internal/test/LANGUAGE/from-sun/language/24/24-ERRORSYSTEM.X @@ -1 +1,688 @@ -;; 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 +;; 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 index f361e8e2..18675333 100644 --- 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 @@ -1 +1,107 @@ -;; 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 +;; 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 + + + + 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 index 6a57fb98..bf6bbcbb 100644 --- a/internal/test/LANGUAGE/from-sun/language/25/25-1-COMPILE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/25/25-1-COMPILE.TEST @@ -1 +1,91 @@ -;; 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 +;; 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 + + + + + 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 index d949c136..050113df 100644 --- a/internal/test/LANGUAGE/from-sun/language/25/25-1-DISASSEMBLE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/25/25-1-DISASSEMBLE.TEST @@ -1 +1,48 @@ -;; 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 +;; 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 + + + + 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 index eab61a6f..ad603885 100644 --- a/internal/test/LANGUAGE/from-sun/language/25/25-2-DOCUMENTATION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/25/25-2-DOCUMENTATION.TEST @@ -1 +1,81 @@ -;; 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 +;; 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 + + 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 index 5c894ca2..358529d2 100644 --- 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 @@ -1 +1,69 @@ -;; 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 +;; 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 + + + + 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 index f5e077bb..356fbe4f 100644 --- a/internal/test/LANGUAGE/from-sun/language/25/25-3-APROPOS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-APROPOS.TEST @@ -1 +1,59 @@ -;; 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 +;; 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 + + + + 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 index 0f9e585a..dfabac45 100644 --- a/internal/test/LANGUAGE/from-sun/language/25/25-3-DESCRIBE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-DESCRIBE.TEST @@ -1 +1,92 @@ -;; 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 +;; 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 + + + + 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 index 40467198..b44bc0df 100644 --- a/internal/test/LANGUAGE/from-sun/language/25/25-3-ED.TEST +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-ED.TEST @@ -1 +1,42 @@ -;; 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 +;; 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 + + + + 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 index ae01316a..564b107c 100644 --- a/internal/test/LANGUAGE/from-sun/language/25/25-3-INSPECT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-INSPECT.TEST @@ -1 +1,43 @@ -;; 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 +;; 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 + + + + 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 index ae0f49f1..aaf2699e 100644 --- a/internal/test/LANGUAGE/from-sun/language/25/25-3-ROOM.TEST +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-ROOM.TEST @@ -1 +1,99 @@ -;; 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 +;; 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 + + + + 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 index 9dea99cd..18afad2c 100644 --- a/internal/test/LANGUAGE/from-sun/language/25/25-3-TIME.TEST +++ b/internal/test/LANGUAGE/from-sun/language/25/25-3-TIME.TEST @@ -1 +1,43 @@ -;; 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 +;; 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 + + + + 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 index 75e3fbd1..7cabf208 100644 --- 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 @@ -1 +1,68 @@ -;; 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 +;; 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 + + 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 index 9a881b11..7a6aa026 100644 --- 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 @@ -1 +1,71 @@ -;; 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 +;; 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 + + 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 index 95523211..1c325b48 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 + + 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 index 33546de1..79fe1503 100644 --- 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 @@ -1 +1,47 @@ -;; 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 +;; 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 + + 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 index d0bd3f6d..07e5d435 100644 --- 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 @@ -1 +1,45 @@ -;; 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 +;; 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 + + 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 index 9b31f148..b5a66dd4 100644 --- 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 @@ -1 +1,53 @@ -;; 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 +;; 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 + + 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 index 3210deb3..e537bf9f 100644 --- 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 @@ -1 +1,34 @@ -;; 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 +;; 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 + + 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 index a95f68df..d5a12f4c 100644 --- 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 @@ -1 +1,33 @@ -;; 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 +;; 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 + + 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 index 36b29e22..648f70a7 100644 --- 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 @@ -1 +1,34 @@ -;; 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 +;; 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 + + 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 index 5859eafb..fb29cb96 100644 --- 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 @@ -1 +1,39 @@ -;; 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 +;; 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 + + 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 index b614cc65..aad55a92 100644 --- 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 @@ -1 +1,33 @@ -;; 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 +;; 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 + + 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 index 1289c09e..b6d7362e 100644 --- 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 @@ -1 +1,33 @@ -;; 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 +;; 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 + + 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 index 9b8c2bf7..487e79dd 100644 --- a/internal/test/LANGUAGE/from-sun/language/25/25-4-SLEEP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/25/25-4-SLEEP.TEST @@ -1 +1,55 @@ -;; 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 +;; 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 + + 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 index 796b84db..afff2290 100644 --- 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 @@ -1 +1,34 @@ -;; 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 +;; 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 + + 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 index 9f7df2bd..81a83cd9 100644 --- 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 @@ -1 +1,33 @@ -;; 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 +;; 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 + + 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 index 7ce2612d..189692f5 100644 --- a/internal/test/LANGUAGE/from-sun/language/25/25-5-IDENTITY.TEST +++ b/internal/test/LANGUAGE/from-sun/language/25/25-5-IDENTITY.TEST @@ -1 +1,54 @@ -;; 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 +;; 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 + + + + 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 index f7dff256..4dbf21f7 100644 --- a/internal/test/LANGUAGE/from-sun/language/4/4-7-DEFTYPE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/4/4-7-DEFTYPE.TEST @@ -1 +1,144 @@ -;; 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 +;; 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 + 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 index 1a67285e..4edb3f22 100644 --- a/internal/test/LANGUAGE/from-sun/language/4/4-8-COERCE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/4/4-8-COERCE.TEST @@ -1 +1,123 @@ -;; 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 +;; 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 + + 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 index c02a3ecf..d3ae4301 100644 --- 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 @@ -1 +1,59 @@ -;; 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 +;; 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 + 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 index 4230aceb..c7978464 100644 --- 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 @@ -1 +1,72 @@ -;; ;; ;; 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 +;; +;; +;; 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 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 index 9b933fec..66b06668 100644 --- 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 @@ -1 +1,16 @@ -;; ;; 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 +;; +;; 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 index 782fc1ea..da509f0a 100644 --- 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 @@ -1 +1,10 @@ -;; ;; 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 +;; +;; 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 index 83a158d8..f2e5bbad 100644 --- 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 @@ -1 +1,186 @@ -;; ;; 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 +;; +;; 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 + + + + + + + + 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 index 0273d57e..1c8789e9 100644 --- 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 @@ -1 +1,104 @@ -;; ;; 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 +;; +;; 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 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 index 2aa62a74..3951e8fa 100644 --- 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 @@ -1 +1,106 @@ -;; ;; 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 +;; +;; 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 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 index ba7716d6..860a7eb3 100644 --- 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 @@ -1 +1,109 @@ -;; ;; 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 +;; +;; 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 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 index 45ba62db..8c3a59c0 100644 --- 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 @@ -1 +1,38 @@ -;; ;; 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 +;; +;; 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 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 index 572c22a6..72534555 100644 --- 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 @@ -1 +1,182 @@ -;; 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 +;; 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 + 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 index 455bfd53..113543b8 100644 --- 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 @@ -1 +1,84 @@ -;; 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 +;; 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 + 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 index 8448fdc9..0f757d6d 100644 --- 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 @@ -1 +1,146 @@ -;; 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 +;; 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 + + 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 index 2a0045a8..a530bf63 100644 --- 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 @@ -1 +1,103 @@ -;; 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 +;; 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 + 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 index 265b4530..4d885d28 100644 --- 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 @@ -1 +1,118 @@ -;; 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 +;; 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 + 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 index 4252d040..108c7803 100644 --- 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 @@ -1 +1,57 @@ -;; 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 +;; 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 + 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 index 35c3d5d1..ce8bb809 100644 --- 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 @@ -1 +1,60 @@ -;; 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 +;; 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 + 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 index 6deee8a7..d521b1ba 100644 --- 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 @@ -1 +1,53 @@ -;; 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 +;; 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 + 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 index 316f9ded..322c7c5d 100644 --- 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 @@ -1 +1,102 @@ -;; 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 +;; 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 + 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 index 1c6aae22..d7c1fabc 100644 --- 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 @@ -1 +1,105 @@ -;; 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 +;; 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 + + + + 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 index f2f9ac82..63b559e5 100644 --- 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 @@ -1 +1,83 @@ -;; 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 +;; 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 + 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 index 95268732..e20005d5 100644 --- 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 @@ -1 +1,55 @@ -;; 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 +;; 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 + 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 index 0d97222e..52a95690 100644 --- 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 @@ -1 +1,79 @@ -;; 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 +;; 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 + 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 index 3d40c65f..1e253826 100644 --- 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 @@ -1 +1,106 @@ -;; 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 +;; 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 + + + + 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 index 5cfb068b..1d492f8b 100644 --- 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 @@ -1 +1,61 @@ -;; 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 +;; 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 + 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 index f5b85dc7..7294e989 100644 --- 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 @@ -1 +1,75 @@ -;; 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 +;; 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 + 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 index 3300d250..410c0c3a 100644 --- 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 @@ -1 +1,63 @@ -;; 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 +;; 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 + 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 index eecb783b..062dc815 100644 --- 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 @@ -1 +1,79 @@ -;; 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 +;; 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 + 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 index bc393615..b1b7ae71 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/6/6-2-2-SIMPLE-BIT-VECTOR-P.TEST 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 index 4d821219..6343310d 100644 --- 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 @@ -1 +1,100 @@ -;; 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 +;; 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 + 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 index e7c33dfd..f769a830 100644 --- 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 @@ -1 +1,59 @@ -;; 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 +;; 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 + 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 index 6ac4b4e7..da4fdad4 100644 --- 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 @@ -1 +1,124 @@ -;; 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 +;; 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 + 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 index a81ee2e6..95397e88 100644 --- a/internal/test/LANGUAGE/from-sun/language/6/6-3-EQ.TEST +++ b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQ.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 + + + + 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 index c1f9bb66..009fefb3 100644 --- a/internal/test/LANGUAGE/from-sun/language/6/6-3-EQL.TEST +++ b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQL.TEST @@ -1 +1,56 @@ -;; 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 +;; 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 + + + + 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 index 251e098c..ed8eeadf 100644 --- a/internal/test/LANGUAGE/from-sun/language/6/6-3-EQUAL.TEST +++ b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQUAL.TEST @@ -1 +1,64 @@ -;; 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 +;; 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 + + + + 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 index e5243f4e..01df6a25 100644 --- a/internal/test/LANGUAGE/from-sun/language/6/6-3-EQUALP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/6/6-3-EQUALP.TEST @@ -1 +1,97 @@ -;; 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 +;; 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 + + + + 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 index e1346b77..bbfc1d13 100644 --- a/internal/test/LANGUAGE/from-sun/language/6/6-4-AND.TEST +++ b/internal/test/LANGUAGE/from-sun/language/6/6-4-AND.TEST @@ -1 +1,97 @@ -;; 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 +;; 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 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 index 592eae64..543714dc 100644 --- a/internal/test/LANGUAGE/from-sun/language/6/6-4-NOT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/6/6-4-NOT.TEST @@ -1 +1,44 @@ -;; 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 +;; 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 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 index e2b93290..e6cdaf58 100644 --- a/internal/test/LANGUAGE/from-sun/language/6/6-4-OR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/6/6-4-OR.TEST @@ -1 +1,72 @@ -;; 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 +;; 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 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 index 0be1f22d..11aebab8 100644 --- 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 @@ -1 +1,56 @@ -;; 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 +;; 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 index acffe6a7..ab8aa623 100644 --- 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 @@ -1 +1,72 @@ -;; 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 +;; 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 index bb86457c..2265cb03 100644 --- 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 @@ -1 +1,69 @@ -;; 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 +;; 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 index 13dc4bc5..5bfe5473 100644 --- 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 @@ -1 +1,41 @@ -;; 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 +;; 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 index 6f1cdbc3..86395d46 100644 --- 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 @@ -1 +1,54 @@ -;; 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 +;; 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 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 index a07a9e5d..a49e12e3 100644 --- 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 @@ -1 +1,91 @@ -;; 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 +;; 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 index 1923620b..7f404432 100644 --- 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 @@ -1 +1,80 @@ -;; ;; 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 +;; +;; 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 index 316761e6..3d618562 100644 --- 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 @@ -1 +1,62 @@ -;; 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 +;; 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 index fe6a9f5d..88152f5c 100644 --- 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 @@ -1 +1,77 @@ -;; 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 +;; 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 index d17ebc8a..662e3832 100644 --- 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 @@ -1 +1,58 @@ -;; 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 +;; 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 index c0391b6e..824bbef4 100644 --- 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 @@ -1 +1,63 @@ -;; 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 +;; 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 + + + 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 index 6bea2f53..0bd05221 100644 --- 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 @@ -1 +1,55 @@ -;; 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 +;; 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 index e37d61aa..a4fc9269 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-10-CATCH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-10-CATCH.TEST @@ -1 +1,215 @@ -;; 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 +;; 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 index 8a3e8520..91b589dd 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-10-THROW.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-10-THROW.TEST @@ -1 +1,35 @@ -;; 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 +;; 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 index e062d429..fe200ecd 100644 --- 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 @@ -1 +1,154 @@ -;; 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 +;; 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 index f7e6d693..d7b674cc 100644 --- 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 @@ -1 +1,105 @@ -;; 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 +;; 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 index 1ece12cf..6d6f39f4 100644 --- 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 @@ -1 +1,84 @@ -;; 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 +;; 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 + + 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 index ec1689a9..5c2d11d3 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-2-DEFSETF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-DEFSETF.TEST @@ -1 +1,68 @@ -;; 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 +;; 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 index 87ab1d32..ff901a34 100644 --- 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 @@ -1 +1,65 @@ -;; 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 +;; 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 + + 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 index 9eea1d27..7cf1e4a9 100644 --- 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 @@ -1 +1,64 @@ -;; 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 +;; 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 + + 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 index cdcc2bae..8ab7c2af 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-2-PSETF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-PSETF.TEST @@ -1 +1,977 @@ -;; 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 +;; 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 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 index 9b3b2897..2eb6af0c 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-2-ROTATEF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-ROTATEF.TEST @@ -1 +1,855 @@ -;; 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 +;; 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 + + + + + + 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 index 8498c888..debf2edf 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-2-SETF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-SETF.TEST @@ -1 +1,385 @@ -(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 +(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 + 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 index 297eecb0..9fe1b06d 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-2-SHIFTF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-2-SHIFTF.TEST @@ -1 +1,428 @@ -;; 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 +;; 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 + + 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 index c86dcb98..3d74ac11 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-3-APPLY.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-3-APPLY.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 index bb4a6369..a383f4ec 100644 --- 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 @@ -1 +1,31 @@ -;; 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 +;; 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 index 8cf341d0..e387d9d9 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-3-FUNCALL.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-3-FUNCALL.TEST @@ -1 +1,78 @@ -;; 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 +;; 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 index 455fb2b3..a3070d2b 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-4-PROG1.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-4-PROG1.TEST @@ -1 +1,38 @@ -;; 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 +;; 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 index fc6e1f1c..48e4bde5 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-4-PROG2.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-4-PROG2.TEST @@ -1 +1,43 @@ -;; 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 +;; 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 index 96e92f36..d37f7d0e 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-4-PROGN.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-4-PROGN.TEST @@ -1 +1,50 @@ -;; 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 +;; 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 index 0cba7a15..21859193 100644 --- 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 @@ -1 +1,78 @@ -;; 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 +;; 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 index bbbdca3d..c77a4cd9 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-5-FLET.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-FLET.TEST @@ -1 +1,136 @@ -;; 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 +;; 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 index 0d97e0f9..155340d9 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-5-LABELS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-LABELS.TEST @@ -1 +1,206 @@ -;; 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 +;; 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 index 9c7249d5..d524034d 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-5-LET.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-LET.TEST @@ -1 +1,114 @@ -;; 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 +;; 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 index 9a9d42bc..a50f6a93 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-5-LETSTAR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-LETSTAR.TEST @@ -1 +1,114 @@ -;; 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 +;; 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 index b3fb6180..fa3195d9 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-5-MACROLET.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-MACROLET.TEST @@ -1 +1,244 @@ -;; 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 +;; 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 index 9113ff90..771f6510 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-5-PROGV.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-5-PROGV.TEST @@ -1 +1,104 @@ -;; 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 +;; 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 index 143034d0..6b5c7295 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-6-CASE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-CASE.TEST @@ -1 +1,141 @@ -;; 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 +;; 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 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 index 0e49b57b..8928e046 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-6-COND.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-COND.TEST @@ -1 +1,124 @@ -;; 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 +;; 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 index 4a3fb4c9..365cd772 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-6-IF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-IF.TEST @@ -1 +1,150 @@ -;; 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 +;; 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 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 index 17978ed5..9fab75a2 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-6-TYPECASE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-TYPECASE.TEST @@ -1 +1,228 @@ -;; 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 +;; 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 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 index 0d0ea169..62dacd53 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-6-UNLESS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-UNLESS.TEST @@ -1 +1,144 @@ -;; 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 +;; 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 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 index f4c37669..a0528c1e 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-6-WHEN.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-6-WHEN.TEST @@ -1 +1,142 @@ -;; 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 +;; 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 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 index cfbc9f8f..ac10166c 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-7-BLOCK.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-7-BLOCK.TEST @@ -1 +1,120 @@ -;; 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 +;; 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 + + 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 index 5ea67b9d..4b94d65a 100644 --- 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 @@ -1 +1,212 @@ -;; 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 +;; 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 + + + 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 index 494b6a41..d9432650 100644 --- a/internal/test/LANGUAGE/from-sun/language/7/7-7-RETURN.TEST +++ b/internal/test/LANGUAGE/from-sun/language/7/7-7-RETURN.TEST @@ -1 +1,134 @@ -;; 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 +;; 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 + + + 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 index 2afdbd89..3916c36f 100644 --- 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 @@ -1 +1,181 @@ -;; 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 +;; 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 index a0f230e1..655ba73f 100644 --- 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 @@ -1 +1,173 @@ -;; 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 +;; 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 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 index 087657d3..bcf16dbc 100644 --- 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 @@ -1 +1,169 @@ -;; 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 +;; 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 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 index 16112402..5d868adb 100644 --- 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 @@ -1 +1,169 @@ -;; 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 +;; 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 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 index 9a7db00e..f3b8b143 100644 --- 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 @@ -1 +1,195 @@ -;; 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 +;; 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 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 index 1324a254..7e55059a 100644 --- 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 @@ -1 +1,170 @@ -;; 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 +;; 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 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 index 5aaa6a64..ac7b2021 100644 --- 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 @@ -1 +1,114 @@ -;; 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 +;; 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 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 index 46a4002e..50b7e585 100644 --- 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 @@ -1 +1,162 @@ -;; 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 +;; 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 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 index fa811802..998ed7eb 100644 --- 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 @@ -1 +1,116 @@ -;; 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 +;; 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 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 index 5f4d4455..aca4cc07 100644 --- 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 @@ -1 +1,154 @@ -;; 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 +;; 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 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 index bbe93d9b..52b77ce4 100644 --- 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 @@ -1 +1,135 @@ -;; 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 +;; 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 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 index 34766631..7c47307c 100644 --- 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 @@ -1 +1,179 @@ -(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 +(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 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 index 5fff190c..b2a7a60d 100644 --- 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 @@ -1 +1,29 @@ -;; 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 +;; 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 index 5f0c3df4..6de66514 100644 --- 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 @@ -1 +1,164 @@ -;; 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 +;; 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 + + + + + + + + + + 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 index 60baa5ca..c83a9e28 100644 --- 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 @@ -1 +1,164 @@ -;; 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 +;; 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 + + + + + + + + + + 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 index 4cba6a14..1ce83aba 100644 --- 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 @@ -1 +1,184 @@ -;; 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 +;; 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 index 64700a3e..e5f906d9 100644 --- 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 @@ -1 +1,232 @@ -;; ;; 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 +;; +;; 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 + + + + + + + + + + + + + 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 index bae10496..81ed26fa 100644 --- 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 @@ -1 +1,49 @@ -;; ;; 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 +;; +;; 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 index 3884c15f..8d5d5b7e 100644 --- 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 @@ -1 +1,252 @@ -;; 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 +;; 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 index 8cc4483a..ee6f56f4 100644 --- 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 @@ -1 +1,329 @@ -;; 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 +;; 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 + + + + + + + + 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 index 5589f140..196b0139 100644 --- 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 @@ -1 +1,697 @@ -;; 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 +;; 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 index 534803e4..532ef558 100644 --- 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 @@ -1 +1,177 @@ -;; ;; 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 +;; +;; 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 + + + + + + + + + + + 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 index 1e4cc6a1..c0bbc0dd 100644 --- 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 @@ -1 +1,263 @@ -;; 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 +;; 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 + 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 index ad9bed2a..0bd4cc6f 100644 --- 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 @@ -1 +1,484 @@ -;; 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 +;; 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 index 1bd785af..decb5f7b 100644 --- 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 @@ -1 +1,20 @@ -(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 +(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 index 0df15b23..94635981 100644 --- 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 @@ -1 +1,141 @@ -;; 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 +;; 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 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 index a6d244af..f7f6bc14 100644 --- 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 @@ -1 +1,539 @@ -;; ;; 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 +;; +;; 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 index 5b3b1319..f15678d8 100644 --- a/internal/test/LANGUAGE/from-sun/language/9/9-1-DECLARE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/9/9-1-DECLARE.TEST @@ -1 +1,436 @@ -;; ;; 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 +;; +;; 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 + + 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 index 3b8c2abe..397ad549 100644 --- a/internal/test/LANGUAGE/from-sun/language/9/9-1-LOCALLY.TEST +++ b/internal/test/LANGUAGE/from-sun/language/9/9-1-LOCALLY.TEST @@ -1 +1,93 @@ -;; ;; 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 +;; +;; 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 + + + + + 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 index 259ec9ce..7ca6dcbb 100644 --- a/internal/test/LANGUAGE/from-sun/language/9/9-1-PROCLAIM.TEST +++ b/internal/test/LANGUAGE/from-sun/language/9/9-1-PROCLAIM.TEST @@ -1 +1,152 @@ -;; ;; 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 +;; +;; 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 + + + + + + + + + + + + + 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 index 9f478c52..72fe71a7 100644 --- a/internal/test/LANGUAGE/from-sun/language/9/9-3-THE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/9/9-3-THE.TEST @@ -1 +1,75 @@ -;; 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 +;; 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 index a209fd14..fe218076 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/DO-TEST.DFASL 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 index 3b592dae..bef384c3 100644 --- a/internal/test/LANGUAGE/from-sun/language/README +++ b/internal/test/LANGUAGE/from-sun/language/README @@ -1 +1,5 @@ -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 +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. + diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR5741.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR5741.TEST index 96f707a5..925a88fd 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR5741.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR5741.TEST @@ -1 +1 @@ -(do-test "prog scoping" (prog ((foo (return t))) nil)) \ No newline at end of file +(do-test "prog scoping" (prog ((foo (return t))) nil)) diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR6150.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR6150.TEST index 804b5294..eedd7d2c 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR6150.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR6150.TEST @@ -1 +1,15 @@ -;;; 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 +;;; 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 index 673ed6c7..0181c27d 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR6247.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR6247.TEST @@ -1 +1,21 @@ -;; 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 +;; 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 index 882979f4..18a48a3f 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR6273.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR6273.TEST @@ -1 +1,11 @@ -;;; 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 +;;; 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)) + ) + ) + ) +) diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR6781.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR6781.TEST index 758ab0ab..0dee791e 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR6781.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR6781.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR7412.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR7412.TEST index 8130e774..1dde9ca6 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR7412.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7412.TEST @@ -1 +1,7 @@ -;; 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 +;; 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 index d7bc15f0..8b7a9a09 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR7475.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7475.TEST @@ -1 +1,19 @@ -;; 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 +;; 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 index 008c6856..1c1786bb 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR7525.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7525.TEST @@ -1 +1,23 @@ -;; 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 +;; 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 index e5d7b645..d109e52d 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR7587-DOC.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7587-DOC.TEST @@ -1 +1,20 @@ -;; 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 +;; 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 index 13c23096..034f4645 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR7647.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7647.TEST @@ -1 +1,5 @@ -;;; 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 +;;; Regression test for AR 7647: CASE macro loses on () clause - Lucid L211 + +(do-test "AR 7647" + (let ((foo nil)) (case foo (() nil) ((nil) t))) +) diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR7742.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR7742.TEST index cce5c8f8..c773bbc8 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR7742.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR7742.TEST @@ -1 +1,7 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8135.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8135.TEST index da5f25ed..9511a7a7 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8135.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8135.TEST @@ -1 +1,32 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8136.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8136.TEST index 0c92ea5e..b485b778 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8136.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8136.TEST @@ -1 +1,13 @@ -;; 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 +;; 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 index 49e7e2a6..457f9702 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8190.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8190.TEST @@ -1 +1,6 @@ -;; 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 +;; 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 index b4a962a0..ffa38dc2 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8207.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8207.TEST @@ -1 +1,9 @@ -;; 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 +;; 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 index 2acff213..24b95959 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8297.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8297.TEST @@ -1 +1,10 @@ -;; 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 +;; 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 index cc2a99c7..bd477148 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8301.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8301.TEST @@ -1 +1,10 @@ -;; 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 +;; 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 index 3fa36acb..315cb2f3 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8319.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8319.TEST @@ -1 +1,5 @@ -;;; 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 +;;; Regression test for AR 8319: FMEMB not on UNSAFE.TO.MODIFY.FNS + +(do-test "AR 8319" + (member 'il:fmemb il:unsafe.to.modify.fns) +) diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8458.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8458.TEST index 075d4266..6e54a439 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8458.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8458.TEST @@ -1 +1,5 @@ -;;; 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 +;;; Regression test for AR 8458: *TRACE-OUTPUT* is supposed to be a window by default + +(do-test "AR 8458" + (typep *trace-output* 'il:window) +) diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8465.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8465.TEST index 320e97f4..43c78dd1 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8465.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8465.TEST @@ -1 +1,7 @@ -;;; 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 +;;; 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))) + ) +) diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8466.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8466.TEST index 85990a2a..cd94d05f 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8466.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8466.TEST @@ -1 +1,8 @@ -;;; 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 +;;; 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) +) diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8470.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8470.TEST index 104bab21..a808e741 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8470.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8470.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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)))) +) diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8491.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8491.TEST index ae14d4b8..144059c3 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8491.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8491.TEST @@ -1 +1,6 @@ -;;; 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 +;;; 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))))) +) diff --git a/internal/test/LANGUAGE/from-sun/language/ar/AR8575.TEST b/internal/test/LANGUAGE/from-sun/language/ar/AR8575.TEST index 86290397..665fc298 100644 --- a/internal/test/LANGUAGE/from-sun/language/ar/AR8575.TEST +++ b/internal/test/LANGUAGE/from-sun/language/ar/AR8575.TEST @@ -1 +1,12 @@ -;; 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 +;; 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 + + diff --git a/internal/test/LANGUAGE/from-sun/language/other/ARITHMETIC-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/ARITHMETIC-REGRESSION.TEST index 2b2e951f..f626e7af 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/ARITHMETIC-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/ARITHMETIC-REGRESSION.TEST @@ -1 +1,51 @@ -(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 +(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))) +) + diff --git a/internal/test/LANGUAGE/from-sun/language/other/ARRAY.TEST b/internal/test/LANGUAGE/from-sun/language/other/ARRAY.TEST index 1f762e7f..2b15e2c9 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/ARRAY.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/ARRAY.TEST @@ -1 +1,91 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/ARRAYP.TEST b/internal/test/LANGUAGE/from-sun/language/other/ARRAYP.TEST index 61a074d6..8ca741ab 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/ARRAYP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/ARRAYP.TEST @@ -1 +1,111 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/ARRAYS-AR6466.TEST b/internal/test/LANGUAGE/from-sun/language/other/ARRAYS-AR6466.TEST index 4b56fd6f..bc355544 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/ARRAYS-AR6466.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/ARRAYS-AR6466.TEST @@ -1 +1,14 @@ -;; 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>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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/BYTECOMPILER-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/BYTECOMPILER-REGRESSION.TEST index 901085b9..c946455f 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/BYTECOMPILER-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/BYTECOMPILER-REGRESSION.TEST @@ -1 +1,41 @@ -;; 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 +;; 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)))) diff --git a/internal/test/LANGUAGE/from-sun/language/other/CHAR-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CHAR-REGRESSION.TEST index 89f8d692..1351d516 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CHAR-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CHAR-REGRESSION.TEST @@ -1 +1,44 @@ -;;; 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 +;;; 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)) +) + + diff --git a/internal/test/LANGUAGE/from-sun/language/other/CHARSET.TEST b/internal/test/LANGUAGE/from-sun/language/other/CHARSET.TEST index c740a52c..1b40feba 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CHARSET.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CHARSET.TEST @@ -1 +1,13 @@ -(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 +(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 index 46480d5b..1c13dd5d 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CL-INTERPRETER-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CL-INTERPRETER-REGRESSION.TEST @@ -1 +1,163 @@ -;; 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 +;; 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)))) diff --git a/internal/test/LANGUAGE/from-sun/language/other/CLSTREAMS-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CLSTREAMS-REGRESSION.TEST index 7137c9c4..fdf14851 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CLSTREAMS-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CLSTREAMS-REGRESSION.TEST @@ -1 +1,44 @@ -;;; 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 +;;; 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")) + diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY-PATCH.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY-PATCH.TEST index beff200b..64265ae2 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY-PATCH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY-PATCH.TEST @@ -1 +1,7 @@ -;; (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 +;; +(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)))) + + diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY.TEST index 0024fd3b..4bab3936 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLARRAY.TEST @@ -1 +1,8 @@ -;;; 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 +;;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLCHARACTER.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLCHARACTER.TEST index 7409802e..30b0e79a 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLCHARACTER.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLCHARACTER.TEST @@ -1 +1,14 @@ -;;; 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 +;;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLFILEMANAGER.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLFILEMANAGER.TEST index d934eabf..c6f88311 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLFILEMANAGER.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLFILEMANAGER.TEST @@ -1 +1,335 @@ -;; 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 +;; 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 index b3f3cfb5..dd78fa6c 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLFILESYS-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLFILESYS-REGRESSION.TEST @@ -1 +1,12 @@ -;;; 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 +;;; 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)))) diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLFLOAT.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLFLOAT.TEST index acb230df..9414aa26 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLFLOAT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLFLOAT.TEST @@ -1 +1,8 @@ -;;; 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 +;;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLPATHNAME-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLPATHNAME-REGRESSION.TEST index 6f74cee2..4e31edca 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLPATHNAME-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLPATHNAME-REGRESSION.TEST @@ -1 +1,3 @@ -;;; 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 +;;; 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 index a936b70b..735421ab 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLPROGV-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLPROGV-REGRESSION.TEST @@ -1 +1,23 @@ -;; 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 +;; 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 index 2f3737dc..e2c865eb 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLRAND.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLRAND.TEST @@ -1 +1,16 @@ -;;; 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 +;;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLREADTABLE-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLREADTABLE-REGRESSION.TEST index 686b4cf2..00015b02 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLREADTABLE-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLREADTABLE-REGRESSION.TEST @@ -1 +1,48 @@ -;; 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 +;; 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))) + ) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLSEQMODIFY-PATCH.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLSEQMODIFY-PATCH.TEST index 84c77a94..72840309 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLSEQMODIFY-PATCH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLSEQMODIFY-PATCH.TEST @@ -1 +1,6 @@ -;; (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 +;; +(do-test "delete-duplicates works with :from-end" + (equal (delete-duplicates '(0 2 2 2) :start 2 :from-end t) '(0 2 2)) +) + + diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLSETF-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLSETF-REGRESSION.TEST index 0b2ea8dd..6446ea35 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLSETF-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLSETF-REGRESSION.TEST @@ -1 +1,11 @@ -;; 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 +;; 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"))) diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLSPECIALFORMS-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLSPECIALFORMS-REGRESSION.TEST index 8fc82fd7..dae96d3a 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLSPECIALFORMS-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLSPECIALFORMS-REGRESSION.TEST @@ -1 +1,9 @@ -;; 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 +;; 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)))) diff --git a/internal/test/LANGUAGE/from-sun/language/other/CMLTYPES-PATCH.TEST b/internal/test/LANGUAGE/from-sun/language/other/CMLTYPES-PATCH.TEST index d81461aa..b696ef76 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CMLTYPES-PATCH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CMLTYPES-PATCH.TEST @@ -1 +1,18 @@ -;; (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 +;; +(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) + + ) + + diff --git a/internal/test/LANGUAGE/from-sun/language/other/COMMON.TEST b/internal/test/LANGUAGE/from-sun/language/other/COMMON.TEST index 8daa2b3b..6d874499 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/COMMON.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/COMMON.TEST @@ -1 +1,15 @@ -;;; 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 +;;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/COMPILERS-AR8409.TEST b/internal/test/LANGUAGE/from-sun/language/other/COMPILERS-AR8409.TEST index 7aea76ee..3254f61b 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/COMPILERS-AR8409.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/COMPILERS-AR8409.TEST @@ -1 +1,5 @@ -;;; 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 +;;; Regression test for AR 8409: MKATOM should return a single value + +(do-test "AR 8409" + (eql (length (multiple-value-list (il:mkatom "abc"))) 1) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7875.TEST b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7875.TEST index cefdec5b..b0b9eb80 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7875.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7875.TEST @@ -1 +1,6 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7893.TEST b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7893.TEST index 9b961639..8a428ba4 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7893.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONS-AR7893.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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))) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/CONDITIONSAR7383.TEST b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONSAR7383.TEST index 33970300..cfb4527c 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/CONDITIONSAR7383.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/CONDITIONSAR7383.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/DEBUGGER-AR8512.TEST b/internal/test/LANGUAGE/from-sun/language/other/DEBUGGER-AR8512.TEST index ff57da7d..548d541a 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/DEBUGGER-AR8512.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/DEBUGGER-AR8512.TEST @@ -1 +1,5 @@ -;;; 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 +;;; Regression test for AR 8512: System errors get breakwindows the say "In \LISPERROR..." + +(do-test "AR 8512" + (member 'il:\\lisperror il:*debugger-entry-points*) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/DEFDEFINE.TEST b/internal/test/LANGUAGE/from-sun/language/other/DEFDEFINE.TEST index b6c0a883..6fd4a92d 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/DEFDEFINE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/DEFDEFINE.TEST @@ -1 +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 \ No newline at end of file +;; 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 index c190bfc6..89424e79 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-ADDITIONAL.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-ADDITIONAL.TEST @@ -1 +1,173 @@ - ;;; 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 + +;;; 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 diff --git a/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-REGRESSION.TEST index 62702e69..f7247dd8 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/DEFSTRUCT-REGRESSION.TEST @@ -1 +1,45 @@ -;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 +;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 index 18f897b6..19d299f6 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/DELETE-SIDE-EFFECT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/DELETE-SIDE-EFFECT.TEST @@ -1 +1,9 @@ -;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 +;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 index 916427aa..33256b8b 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/DESCRIBE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/DESCRIBE.TEST @@ -1 +1,7 @@ -;;; 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 +;;; woz 4/27/87 test for DESCRIBE - 8259 +(do-test "random state symbols are globally-special" + (DESCRIBE MOST-NEGATIVE-FIXNUM) +) + +stop + 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 index 803ff8f9..f2ca5a46 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/DOUBLE-OP-ARITH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/DOUBLE-OP-ARITH.TEST @@ -1,236 +1,3 @@ -;; double operation arithmetic tests for edge conditions -;; March 29, 1988 by Masinter - -(do-test-group ("Two Arg arithmetic opcodes" - :before (test-defun and-eq-frob (frob test) - (and (eq frob 'frob) test))) -(do-test - "Arithmetic edge condition tests " - (macrolet - ((check (op) - `(or (null (setq val (pop arg))) - (and-eq-frob 'frob (eql (,op arg1 arg2) val)) - (warn "(~A ~S ~S) is ~S and not ~S" ',op arg1 arg2 (,op arg1 arg2) val)))) - (every - #'(lambda (arg) - (let ((arg1 (pop arg)) - (arg2 (pop arg)) - (val nil)) - (and (check +) - (check -) - (check *) - (check /) - (check il:iplus) - (check il:idifference) - (check il:itimes) - (check il:iquotient) - (check il:quotient) - (check logior) - (check logand) - (check logxor) - (check ash) - (check il:igreaterp) - (check >) - (check il:fgreaterp) - (check =) - (check eql)))) - (prog1 - '((0 0 0 0 0 nil 0 0 0 nil nil 0 0 0 0 nil nil nil t t) - (0 1 1 -1 0 0 1 -1 0 0 0 1 0 1 0 nil nil nil nil nil) - (0 -1 -1 1 0 0 -1 1 0 0 0 -1 0 -1 0 t t t nil nil) - (0 1.0 1.0 -1.0 0.0 0.0 1 -1 0 0 0.0 1 0 1 0 nil nil nil nil nil) - (0 65535 65535 -65535 0 0 65535 -65535 0 0 0 65535 0 65535 nil - nil nil nil nil nil) - (0 -65536 -65536 65536 0 0 -65536 65536 0 0 0 -65536 0 -65536 0 t - t t nil nil) - (0 65536 65536 -65536 0 0 65536 -65536 0 0 0 65536 0 65536 nil - nil nil nil nil nil) - (0 -65537 -65537 65537 0 0 -65537 65537 0 0 0 -65537 0 -65537 0 t - t t nil nil) - (0 2147483648 2147483648 -2147483648 0 0 2147483648 -2147483648 0 - 0 0 2147483648 0 2147483648 nil nil nil nil nil nil) - (1 0 1 1 0 nil 1 1 0 nil nil 1 0 1 1 t t t nil nil) - (1 1 2 0 1 1 2 0 1 1 1 1 1 0 2 nil nil nil t t) - (1 -1 0 2 -1 -1 0 2 -1 -1 -1 -1 1 -2 0 t t t nil nil) - (1 1.0 2.0 0.0 1.0 1.0 2 0 1 1 1.0 1 1 0 2 nil nil nil t nil) - (1 65535 65536 -65534 65535 1/65535 65536 -65534 65535 0 0 65535 - 1 65534 nil nil nil nil nil nil) - (1 -65536 -65535 65537 -65536 -1/65536 -65535 65537 -65536 0 0 - -65535 0 -65535 1 t t t nil nil) - (1 65536 65537 -65535 65536 1/65536 65537 -65535 65536 0 0 65537 - 0 65537 nil nil nil nil nil nil) - (1 -65537 -65536 65538 -65537 -1/65537 -65536 65538 -65537 0 0 - -65537 1 -65538 0 t t t nil nil) - (1 2147483648 2147483649 -2147483647 2147483648 1/2147483648 - 2147483649 -2147483647 2147483648 0 0 2147483649 0 2147483649 - nil nil nil nil nil nil) - (-1 0 -1 -1 0 nil -1 -1 0 nil nil -1 0 -1 -1 nil nil nil nil nil) - (-1 1 0 -2 -1 -1 0 -2 -1 -1 -1 -1 1 -2 -2 nil nil nil nil nil) - (-1 -1 -2 0 1 1 -2 0 1 1 1 -1 -1 0 -1 nil nil nil t t) - (-1 1.0 0.0 -2.0 -1.0 -1.0 0 -2 -1 -1 -1.0 -1 1 -2 -2 nil nil nil - nil nil) - (-1 65535 65534 -65536 -65535 -1/65535 65534 -65536 -65535 0 0 -1 - 65535 -65536 nil nil nil nil nil nil) - (-1 -65536 -65537 65535 65536 1/65536 -65537 65535 65536 0 0 -1 - -65536 65535 -1 t t t nil nil) - (-1 65536 65535 -65537 -65536 -1/65536 65535 -65537 -65536 0 0 -1 - 65536 -65537 nil nil nil nil nil nil) - (-1 -65537 -65538 65536 65537 1/65537 -65538 65536 65537 0 0 -1 - -65537 65536 -1 t t t nil nil) - (-1 2147483648 2147483647 -2147483649 -2147483648 -1/2147483648 - 2147483647 -2147483649 -2147483648 0 0 -1 2147483648 - -2147483649 nil nil nil nil nil nil) - (1.0 0 1.0 1.0 0.0 nil 1 1 0 nil nil 1 0 1 1.0 t t t nil nil) - (1.0 1 2.0 0.0 1.0 1.0 2 0 1 1 1.0 1 1 0 2 nil nil nil t nil) - (1.0 -1 0.0 2.0 -1.0 -1.0 0 2 -1 -1 -1.0 -1 1 -2 0 t t t nil nil) - (1.0 1.0 2.0 0.0 1.0 1.0 2 0 1 1 1.0 1 1 0 2 nil nil nil t t) - (1.0 65535 65536.0 -65534.0 65535.0 1.5259022E-5 65536 -65534 - 65535 0 1.5259022E-5 65535 1 65534 nil nil nil nil nil nil) - (1.0 -65536 -65535.0 65537.0 -65536.0 -1.5258789E-5 -65535 65537 - -65536 0 -1.5258789E-5 -65535 0 -65535 0 t t t nil nil) - (1.0 65536 65537.0 -65535.0 65536.0 1.5258789E-5 65537 -65535 - 65536 0 1.5258789E-5 65537 0 65537 nil nil nil nil nil nil) - (1.0 -65537 -65536.0 65538.0 -65537.0 -1.5258556E-5 -65536 65538 - -65537 0 -1.5258556E-5 -65537 1 -65538 0 t t t nil nil) - (1.0 2147483648 2.1474836E+9 -2.1474836E+9 2.1474836E+9 - 4.656613E-10 2147483649 -2147483647 2147483648 0 - 4.656613E-10 2147483649 0 2147483649 nil nil nil nil nil nil - ) - (65535 0 65535 65535 0 nil 65535 65535 0 nil nil 65535 0 65535 - 65535 t t t nil nil) - (65535 1 65536 65534 65535 65535 65536 65534 65535 65535 65535 - 65535 1 65534 131070 t t t nil nil) - (65535 -1 65534 65536 -65535 -65535 65534 65536 -65535 -65535 - -65535 -1 65535 -65536 32767 t t t nil nil) - (65535 1.0 65536.0 65534.0 65535.0 65535.0 65536 65534 65535 - 65535 65535.0 65535 1 65534 131070 t t t nil nil) - (65535 65535 131070 0 4294836225 1 131070 0 4294836225 1 1 65535 - 65535 0 nil nil nil nil t t) - (65535 -65536 -1 131071 -4294901760 -65535/65536 -1 131071 - -4294901760 0 0 -1 0 -1 65535 t t t nil nil) - (65535 65536 131071 -1 4294901760 65535/65536 131071 -1 - 4294901760 0 0 131071 0 131071 nil nil nil nil nil nil) - (65535 -65537 -2 131072 -4294967295 -65535/65537 -2 131072 - -4294967295 0 0 -65537 65535 -131072 0 t t t nil nil) - (65535 2147483648 2147549183 -2147418113 140735340871680 - 65535/2147483648 2147549183 -2147418113 140735340871680 0 - 0 2147549183 0 2147549183 nil nil nil nil nil nil) - (-65536 0 -65536 -65536 0 nil -65536 -65536 0 nil nil -65536 0 - -65536 -65536 nil nil nil nil nil) - (-65536 1 -65535 -65537 -65536 -65536 -65535 -65537 -65536 -65536 - -65536 -65535 0 -65535 -131072 nil nil nil nil nil) - (-65536 -1 -65537 -65535 65536 65536 -65537 -65535 65536 65536 - 65536 -1 -65536 65535 -32768 nil nil nil nil nil) - (-65536 1.0 -65535.0 -65537.0 -65536.0 -65536.0 -65535 -65537 - -65536 -65536 -65536.0 -65535 0 -65535 -131072 nil nil nil - nil nil) - (-65536 65535 -1 -131071 -4294901760 -65536/65535 -1 -131071 - -4294901760 -1 -1 -1 0 -1 nil nil nil nil nil nil) - (-65536 -65536 -131072 0 4294967296 1 -131072 0 4294967296 1 1 - -65536 -65536 0 -1 nil nil nil t t) - (-65536 65536 0 -131072 -4294967296 -1 0 -131072 -4294967296 -1 - -1 -65536 65536 -131072 nil nil nil nil nil nil) - (-65536 -65537 -131073 1 4295032832 65536/65537 -131073 1 - 4295032832 0 0 -1 -131072 131071 -1 t t t nil nil) - (-65536 2147483648 2147418112 -2147549184 -140737488355328 - -1/32768 2147418112 -2147549184 -140737488355328 0 0 - -65536 2147483648 -2147549184 nil nil nil nil nil nil) - (65536 0 65536 65536 0 nil 65536 65536 0 nil nil 65536 0 65536 - 65536 t t t nil nil) - (65536 1 65537 65535 65536 65536 65537 65535 65536 65536 65536 - 65537 0 65537 131072 t t t nil nil) - (65536 -1 65535 65537 -65536 -65536 65535 65537 -65536 -65536 - -65536 -1 65536 -65537 32768 t t t nil nil) - (65536 1.0 65537.0 65535.0 65536.0 65536.0 65537 65535 65536 - 65536 65536.0 65537 0 65537 131072 t t t nil nil) - (65536 65535 131071 1 4294901760 65536/65535 131071 1 4294901760 - 1 1 131071 0 131071 nil t t t nil nil) - (65536 -65536 0 131072 -4294967296 -1 0 131072 -4294967296 -1 -1 - -65536 65536 -131072 0 t t t nil nil) - (65536 65536 131072 0 4294967296 1 131072 0 4294967296 1 1 65536 - 65536 0 nil nil nil nil t t) - (65536 -65537 -1 131073 -4295032832 -65536/65537 -1 131073 - -4295032832 0 0 -1 0 -1 0 t t t nil nil) - (65536 2147483648 2147549184 -2147418112 140737488355328 1/32768 - 2147549184 -2147418112 140737488355328 0 0 2147549184 0 - 2147549184 nil nil nil nil nil nil) - (-65537 0 -65537 -65537 0 nil -65537 -65537 0 nil nil -65537 0 - -65537 -65537 nil nil nil nil nil) - (-65537 1 -65536 -65538 -65537 -65537 -65536 -65538 -65537 -65537 - -65537 -65537 1 -65538 -131074 nil nil nil nil nil) - (-65537 -1 -65538 -65536 65537 65537 -65538 -65536 65537 65537 - 65537 -1 -65537 65536 -32769 nil nil nil nil nil) - (-65537 1.0 -65536.0 -65538.0 -65537.0 -65537.0 -65536 -65538 - -65537 -65537 -65537.0 -65537 1 -65538 -131074 nil nil nil - nil nil) - (-65537 65535 -2 -131072 -4294967295 -65537/65535 -2 -131072 - -4294967295 -1 -1 -65537 65535 -131072 nil nil nil nil nil - nil) - (-65537 -65536 -131073 -1 4295032832 65537/65536 -131073 -1 - 4295032832 1 1 -1 -131072 131071 -1 nil nil nil nil nil) - (-65537 65536 -1 -131073 -4295032832 -65537/65536 -1 -131073 - -4295032832 -1 -1 -1 0 -1 nil nil nil nil nil nil) - (-65537 -65537 -131074 0 4295098369 1 -131074 0 4295098369 1 1 - -65537 -65537 0 -1 nil nil nil t t) - (-65537 2147483648 2147418111 -2147549185 -140739635838976 - -65537/2147483648 2147418111 -2147549185 -140739635838976 - 0 0 -65537 2147483648 -2147549185 nil nil nil nil nil nil) - (2147483648 0 2147483648 2147483648 0 nil 2147483648 2147483648 0 - nil nil 2147483648 0 2147483648 2147483648 t t t nil nil) - (2147483648 1 2147483649 2147483647 2147483648 2147483648 - 2147483649 2147483647 2147483648 2147483648 2147483648 - 2147483649 0 2147483649 4294967296 t t t nil nil) - (2147483648 -1 2147483647 2147483649 -2147483648 -2147483648 - 2147483647 2147483649 -2147483648 -2147483648 -2147483648 - -1 2147483648 -2147483649 1073741824 t t t nil nil) - (2147483648 1.0 2.1474836E+9 2.1474836E+9 2.1474836E+9 - 2.1474836E+9 2147483649 2147483647 2147483648 2147483648 - 2.1474836E+9 2147483649 0 2147483649 4294967296 t t t nil - nil) - (2147483648 65535 2147549183 2147418113 140735340871680 - 2147483648/65535 2147549183 2147418113 140735340871680 - 32768 32768 2147549183 0 2147549183 nil t t t nil nil) - (2147483648 -65536 2147418112 2147549184 -140737488355328 -32768 - 2147418112 2147549184 -140737488355328 -32768 -32768 - -65536 2147483648 -2147549184 0 t t t nil nil) - (2147483648 65536 2147549184 2147418112 140737488355328 32768 - 2147549184 2147418112 140737488355328 32768 32768 - 2147549184 0 2147549184 nil t t t nil nil) - (2147483648 -65537 2147418111 2147549185 -140739635838976 - -2147483648/65537 2147418111 2147549185 -140739635838976 - -32767 -32767 -65537 2147483648 -2147549185 0 t t t nil - nil) - (2147483648 2147483648 4294967296 0 4611686018427387904 1 - 4294967296 0 4611686018427387904 1 1 2147483648 2147483648 - 0 nil nil nil nil t t)) - '(let - ((values '(0 1 -1 1.0 65535 -65536 65536 -65537 2147483648))) - (mapcan - #'(lambda (arg1) - (mapcar #'(lambda (arg2) - (list arg1 arg2 (+ arg1 arg2) - (- arg1 arg2) - (* arg1 arg2) - (unless (= arg2 0) - (/ arg1 arg2)) - (il:iplus arg1 arg2) - (il:idifference arg1 arg2) - (il:itimes arg1 arg2) - (unless (= arg2 0) - (il:iquotient arg1 arg2)) - (unless (= arg2 0) - (il:quotient arg1 arg2)) - (logior arg1 arg2) - (logand arg1 arg2) - (logxor arg1 arg2) - (unless (> arg2 64) - (ash arg1 arg2)) - (il:igreaterp arg1 arg2) - (> arg1 arg2) - (il:fgreaterp arg1 arg2) - (= arg1 arg2) - (eql arg1 arg2))) values)) - values)))))) -) -STOP -GACHA ?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) <2ě3Czş \ No newline at end of file +;; double operation arithmetic tests for edge conditions ;; March 29, 1988 by Masinter (do-test-group ("Two Arg arithmetic opcodes" :before (test-defun and-eq-frob (frob test) (and (eq frob 'frob) test))) (do-test "Arithmetic edge condition tests " (macrolet ((check (op) `(or (null (setq val (pop arg))) (and-eq-frob 'frob (eql (,op arg1 arg2) val)) (warn "(~A ~S ~S) is ~S and not ~S" ',op arg1 arg2 (,op arg1 arg2) val)))) (every #'(lambda (arg) (let ((arg1 (pop arg)) (arg2 (pop arg)) (val nil)) (and (check +) (check -) (check *) (check /) (check il:iplus) (check il:idifference) (check il:itimes) (check il:iquotient) (check il:quotient) (check logior) (check logand) (check logxor) (check ash) (check il:igreaterp) (check >) (check il:fgreaterp) (check =) (check eql)))) (prog1 '((0 0 0 0 0 nil 0 0 0 nil nil 0 0 0 0 nil nil nil t t) (0 1 1 -1 0 0 1 -1 0 0 0 1 0 1 0 nil nil nil nil nil) (0 -1 -1 1 0 0 -1 1 0 0 0 -1 0 -1 0 t t t nil nil) (0 1.0 1.0 -1.0 0.0 0.0 1 -1 0 0 0.0 1 0 1 0 nil nil nil nil nil) (0 65535 65535 -65535 0 0 65535 -65535 0 0 0 65535 0 65535 nil nil nil nil nil nil) (0 -65536 -65536 65536 0 0 -65536 65536 0 0 0 -65536 0 -65536 0 t t t nil nil) (0 65536 65536 -65536 0 0 65536 -65536 0 0 0 65536 0 65536 nil nil nil nil nil nil) (0 -65537 -65537 65537 0 0 -65537 65537 0 0 0 -65537 0 -65537 0 t t t nil nil) (0 2147483648 2147483648 -2147483648 0 0 2147483648 -2147483648 0 0 0 2147483648 0 2147483648 nil nil nil nil nil nil) (1 0 1 1 0 nil 1 1 0 nil nil 1 0 1 1 t t t nil nil) (1 1 2 0 1 1 2 0 1 1 1 1 1 0 2 nil nil nil t t) (1 -1 0 2 -1 -1 0 2 -1 -1 -1 -1 1 -2 0 t t t nil nil) (1 1.0 2.0 0.0 1.0 1.0 2 0 1 1 1.0 1 1 0 2 nil nil nil t nil) (1 65535 65536 -65534 65535 1/65535 65536 -65534 65535 0 0 65535 1 65534 nil nil nil nil nil nil) (1 -65536 -65535 65537 -65536 -1/65536 -65535 65537 -65536 0 0 -65535 0 -65535 1 t t t nil nil) (1 65536 65537 -65535 65536 1/65536 65537 -65535 65536 0 0 65537 0 65537 nil nil nil nil nil nil) (1 -65537 -65536 65538 -65537 -1/65537 -65536 65538 -65537 0 0 -65537 1 -65538 0 t t t nil nil) (1 2147483648 2147483649 -2147483647 2147483648 1/2147483648 2147483649 -2147483647 2147483648 0 0 2147483649 0 2147483649 nil nil nil nil nil nil) (-1 0 -1 -1 0 nil -1 -1 0 nil nil -1 0 -1 -1 nil nil nil nil nil) (-1 1 0 -2 -1 -1 0 -2 -1 -1 -1 -1 1 -2 -2 nil nil nil nil nil) (-1 -1 -2 0 1 1 -2 0 1 1 1 -1 -1 0 -1 nil nil nil t t) (-1 1.0 0.0 -2.0 -1.0 -1.0 0 -2 -1 -1 -1.0 -1 1 -2 -2 nil nil nil nil nil) (-1 65535 65534 -65536 -65535 -1/65535 65534 -65536 -65535 0 0 -1 65535 -65536 nil nil nil nil nil nil) (-1 -65536 -65537 65535 65536 1/65536 -65537 65535 65536 0 0 -1 -65536 65535 -1 t t t nil nil) (-1 65536 65535 -65537 -65536 -1/65536 65535 -65537 -65536 0 0 -1 65536 -65537 nil nil nil nil nil nil) (-1 -65537 -65538 65536 65537 1/65537 -65538 65536 65537 0 0 -1 -65537 65536 -1 t t t nil nil) (-1 2147483648 2147483647 -2147483649 -2147483648 -1/2147483648 2147483647 -2147483649 -2147483648 0 0 -1 2147483648 -2147483649 nil nil nil nil nil nil) (1.0 0 1.0 1.0 0.0 nil 1 1 0 nil nil 1 0 1 1.0 t t t nil nil) (1.0 1 2.0 0.0 1.0 1.0 2 0 1 1 1.0 1 1 0 2 nil nil nil t nil) (1.0 -1 0.0 2.0 -1.0 -1.0 0 2 -1 -1 -1.0 -1 1 -2 0 t t t nil nil) (1.0 1.0 2.0 0.0 1.0 1.0 2 0 1 1 1.0 1 1 0 2 nil nil nil t t) (1.0 65535 65536.0 -65534.0 65535.0 1.5259022E-5 65536 -65534 65535 0 1.5259022E-5 65535 1 65534 nil nil nil nil nil nil) (1.0 -65536 -65535.0 65537.0 -65536.0 -1.5258789E-5 -65535 65537 -65536 0 -1.5258789E-5 -65535 0 -65535 0 t t t nil nil) (1.0 65536 65537.0 -65535.0 65536.0 1.5258789E-5 65537 -65535 65536 0 1.5258789E-5 65537 0 65537 nil nil nil nil nil nil) (1.0 -65537 -65536.0 65538.0 -65537.0 -1.5258556E-5 -65536 65538 -65537 0 -1.5258556E-5 -65537 1 -65538 0 t t t nil nil) (1.0 2147483648 2.1474836E+9 -2.1474836E+9 2.1474836E+9 4.656613E-10 2147483649 -2147483647 2147483648 0 4.656613E-10 2147483649 0 2147483649 nil nil nil nil nil nil ) (65535 0 65535 65535 0 nil 65535 65535 0 nil nil 65535 0 65535 65535 t t t nil nil) (65535 1 65536 65534 65535 65535 65536 65534 65535 65535 65535 65535 1 65534 131070 t t t nil nil) (65535 -1 65534 65536 -65535 -65535 65534 65536 -65535 -65535 -65535 -1 65535 -65536 32767 t t t nil nil) (65535 1.0 65536.0 65534.0 65535.0 65535.0 65536 65534 65535 65535 65535.0 65535 1 65534 131070 t t t nil nil) (65535 65535 131070 0 4294836225 1 131070 0 4294836225 1 1 65535 65535 0 nil nil nil nil t t) (65535 -65536 -1 131071 -4294901760 -65535/65536 -1 131071 -4294901760 0 0 -1 0 -1 65535 t t t nil nil) (65535 65536 131071 -1 4294901760 65535/65536 131071 -1 4294901760 0 0 131071 0 131071 nil nil nil nil nil nil) (65535 -65537 -2 131072 -4294967295 -65535/65537 -2 131072 -4294967295 0 0 -65537 65535 -131072 0 t t t nil nil) (65535 2147483648 2147549183 -2147418113 140735340871680 65535/2147483648 2147549183 -2147418113 140735340871680 0 0 2147549183 0 2147549183 nil nil nil nil nil nil) (-65536 0 -65536 -65536 0 nil -65536 -65536 0 nil nil -65536 0 -65536 -65536 nil nil nil nil nil) (-65536 1 -65535 -65537 -65536 -65536 -65535 -65537 -65536 -65536 -65536 -65535 0 -65535 -131072 nil nil nil nil nil) (-65536 -1 -65537 -65535 65536 65536 -65537 -65535 65536 65536 65536 -1 -65536 65535 -32768 nil nil nil nil nil) (-65536 1.0 -65535.0 -65537.0 -65536.0 -65536.0 -65535 -65537 -65536 -65536 -65536.0 -65535 0 -65535 -131072 nil nil nil nil nil) (-65536 65535 -1 -131071 -4294901760 -65536/65535 -1 -131071 -4294901760 -1 -1 -1 0 -1 nil nil nil nil nil nil) (-65536 -65536 -131072 0 4294967296 1 -131072 0 4294967296 1 1 -65536 -65536 0 -1 nil nil nil t t) (-65536 65536 0 -131072 -4294967296 -1 0 -131072 -4294967296 -1 -1 -65536 65536 -131072 nil nil nil nil nil nil) (-65536 -65537 -131073 1 4295032832 65536/65537 -131073 1 4295032832 0 0 -1 -131072 131071 -1 t t t nil nil) (-65536 2147483648 2147418112 -2147549184 -140737488355328 -1/32768 2147418112 -2147549184 -140737488355328 0 0 -65536 2147483648 -2147549184 nil nil nil nil nil nil) (65536 0 65536 65536 0 nil 65536 65536 0 nil nil 65536 0 65536 65536 t t t nil nil) (65536 1 65537 65535 65536 65536 65537 65535 65536 65536 65536 65537 0 65537 131072 t t t nil nil) (65536 -1 65535 65537 -65536 -65536 65535 65537 -65536 -65536 -65536 -1 65536 -65537 32768 t t t nil nil) (65536 1.0 65537.0 65535.0 65536.0 65536.0 65537 65535 65536 65536 65536.0 65537 0 65537 131072 t t t nil nil) (65536 65535 131071 1 4294901760 65536/65535 131071 1 4294901760 1 1 131071 0 131071 nil t t t nil nil) (65536 -65536 0 131072 -4294967296 -1 0 131072 -4294967296 -1 -1 -65536 65536 -131072 0 t t t nil nil) (65536 65536 131072 0 4294967296 1 131072 0 4294967296 1 1 65536 65536 0 nil nil nil nil t t) (65536 -65537 -1 131073 -4295032832 -65536/65537 -1 131073 -4295032832 0 0 -1 0 -1 0 t t t nil nil) (65536 2147483648 2147549184 -2147418112 140737488355328 1/32768 2147549184 -2147418112 140737488355328 0 0 2147549184 0 2147549184 nil nil nil nil nil nil) (-65537 0 -65537 -65537 0 nil -65537 -65537 0 nil nil -65537 0 -65537 -65537 nil nil nil nil nil) (-65537 1 -65536 -65538 -65537 -65537 -65536 -65538 -65537 -65537 -65537 -65537 1 -65538 -131074 nil nil nil nil nil) (-65537 -1 -65538 -65536 65537 65537 -65538 -65536 65537 65537 65537 -1 -65537 65536 -32769 nil nil nil nil nil) (-65537 1.0 -65536.0 -65538.0 -65537.0 -65537.0 -65536 -65538 -65537 -65537 -65537.0 -65537 1 -65538 -131074 nil nil nil nil nil) (-65537 65535 -2 -131072 -4294967295 -65537/65535 -2 -131072 -4294967295 -1 -1 -65537 65535 -131072 nil nil nil nil nil nil) (-65537 -65536 -131073 -1 4295032832 65537/65536 -131073 -1 4295032832 1 1 -1 -131072 131071 -1 nil nil nil nil nil) (-65537 65536 -1 -131073 -4295032832 -65537/65536 -1 -131073 -4295032832 -1 -1 -1 0 -1 nil nil nil nil nil nil) (-65537 -65537 -131074 0 4295098369 1 -131074 0 4295098369 1 1 -65537 -65537 0 -1 nil nil nil t t) (-65537 2147483648 2147418111 -2147549185 -140739635838976 -65537/2147483648 2147418111 -2147549185 -140739635838976 0 0 -65537 2147483648 -2147549185 nil nil nil nil nil nil) (2147483648 0 2147483648 2147483648 0 nil 2147483648 2147483648 0 nil nil 2147483648 0 2147483648 2147483648 t t t nil nil) (2147483648 1 2147483649 2147483647 2147483648 2147483648 2147483649 2147483647 2147483648 2147483648 2147483648 2147483649 0 2147483649 4294967296 t t t nil nil) (2147483648 -1 2147483647 2147483649 -2147483648 -2147483648 2147483647 2147483649 -2147483648 -2147483648 -2147483648 -1 2147483648 -2147483649 1073741824 t t t nil nil) (2147483648 1.0 2.1474836E+9 2.1474836E+9 2.1474836E+9 2.1474836E+9 2147483649 2147483647 2147483648 2147483648 2.1474836E+9 2147483649 0 2147483649 4294967296 t t t nil nil) (2147483648 65535 2147549183 2147418113 140735340871680 2147483648/65535 2147549183 2147418113 140735340871680 32768 32768 2147549183 0 2147549183 nil t t t nil nil) (2147483648 -65536 2147418112 2147549184 -140737488355328 -32768 2147418112 2147549184 -140737488355328 -32768 -32768 -65536 2147483648 -2147549184 0 t t t nil nil) (2147483648 65536 2147549184 2147418112 140737488355328 32768 2147549184 2147418112 140737488355328 32768 32768 2147549184 0 2147549184 nil t t t nil nil) (2147483648 -65537 2147418111 2147549185 -140739635838976 -2147483648/65537 2147418111 2147549185 -140739635838976 -32767 -32767 -65537 2147483648 -2147549185 0 t t t nil nil) (2147483648 2147483648 4294967296 0 4611686018427387904 1 4294967296 0 4611686018427387904 1 1 2147483648 2147483648 0 nil nil nil nil t t)) '(let ((values '(0 1 -1 1.0 65535 -65536 65536 -65537 2147483648))) (mapcan #'(lambda (arg1) (mapcar #'(lambda (arg2) (list arg1 arg2 (+ arg1 arg2) (- arg1 arg2) (* arg1 arg2) (unless (= arg2 0) (/ arg1 arg2)) (il:iplus arg1 arg2) (il:idifference arg1 arg2) (il:itimes arg1 arg2) (unless (= arg2 0) (il:iquotient arg1 arg2)) (unless (= arg2 0) (il:quotient arg1 arg2)) (logior arg1 arg2) (logand arg1 arg2) (logxor arg1 arg2) (unless (> arg2 64) (ash arg1 arg2)) (il:igreaterp arg1 arg2) (> arg1 arg2) (il:fgreaterp arg1 arg2) (= arg1 arg2) (eql arg1 arg2))) values)) values)))))) ) STOP GACHA +?1(DEFAULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) +<2ě3Czş \ No newline at end of file diff --git a/internal/test/LANGUAGE/from-sun/language/other/DOVEVMEMSIZEPATCH-LLFAULT.TEST b/internal/test/LANGUAGE/from-sun/language/other/DOVEVMEMSIZEPATCH-LLFAULT.TEST index c0bfc70e..e003a111 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/DOVEVMEMSIZEPATCH-LLFAULT.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/DOVEVMEMSIZEPATCH-LLFAULT.TEST @@ -1 +1,4 @@ -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 +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. + 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 index 66da6b6c..ede8d340 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/ERROR-RUNTIME-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/ERROR-RUNTIME-REGRESSION.TEST @@ -1 +1,35 @@ -;;; 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 +;;; 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.") + ) + ) +) + diff --git a/internal/test/LANGUAGE/from-sun/language/other/EVALUATOR-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/EVALUATOR-REGRESSION.TEST index d4a5498f..c2e9854d 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/EVALUATOR-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/EVALUATOR-REGRESSION.TEST @@ -1 +1,84 @@ -;;; 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 +;;; 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 index 46401116..fd8bb8c9 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/EVENP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/EVENP.TEST @@ -1 +1,36 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/from-sun/language/other/FASDUMP-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/FASDUMP-REGRESSION.TEST index e22b4d0a..dac54ddd 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/FASDUMP-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/FASDUMP-REGRESSION.TEST @@ -1 +1,20 @@ -;;;; 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 +;;;; 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) + ) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/FASLOAD-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/FASLOAD-REGRESSION.TEST index ca0552c1..35f751be 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/FASLOAD-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/FASLOAD-REGRESSION.TEST @@ -1 +1,79 @@ -;;; 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 +;;; 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*)) + ) + ) + ) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/FILEPKG-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/FILEPKG-REGRESSION.TEST index 89d58fe1..fc99f3e6 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/FILEPKG-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/FILEPKG-REGRESSION.TEST @@ -1 +1,6 @@ -;; 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 +;; 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"))))) diff --git a/internal/test/LANGUAGE/from-sun/language/other/FIXP.TEST b/internal/test/LANGUAGE/from-sun/language/other/FIXP.TEST index b9f8d938..03e383dd 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/FIXP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/FIXP.TEST @@ -1 +1,127 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/FLOATP.TEST b/internal/test/LANGUAGE/from-sun/language/other/FLOATP.TEST index cf4d85b1..afc6e58c 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/FLOATP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/FLOATP.TEST @@ -1 +1,130 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/FORMAT-AR7912.TEST b/internal/test/LANGUAGE/from-sun/language/other/FORMAT-AR7912.TEST index cb884870..30f7e0e4 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/FORMAT-AR7912.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/FORMAT-AR7912.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/FORMAT-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/FORMAT-REGRESSION.TEST index 4eaf64c0..23bfe3d3 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/FORMAT-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/FORMAT-REGRESSION.TEST @@ -1 +1,14 @@ -(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 +(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 index 456af393..c897fa8d 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/FP-PRINT-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/FP-PRINT-REGRESSION.TEST @@ -1 +1,29 @@ -;;; 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 +;;; 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 index 35084e83..8df01e00 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/HARRAYP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/HARRAYP.TEST @@ -1 +1,110 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/HASH-AR7587.TEST b/internal/test/LANGUAGE/from-sun/language/other/HASH-AR7587.TEST index fab2f6ea..23516b0f 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/HASH-AR7587.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/HASH-AR7587.TEST @@ -1 +1,20 @@ -;; 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 +;; 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 index f06716e7..460b3334 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/HASHARRAY.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/HASHARRAY.TEST @@ -1 +1,108 @@ -;; 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 +;; 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 + 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 index 89e347b7..f481f5d0 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ARGUMENT-FUNCTIONS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ARGUMENT-FUNCTIONS.TEST @@ -1 +1,30 @@ -;; 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 +;; 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 +) 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 index f0c19e33..e4d5cfa6 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-AR7398.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-AR7398.TEST @@ -1 +1,12 @@ -;;; 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 +;;; 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)) + ) + ) + ) + )) +) 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 index 5b2741b3..07e461b7 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-ATOM.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES-ATOM.TEST @@ -1 +1,131 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES.TEST index ac9127a5..1305dc98 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPES.TEST @@ -1 +1,46 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPESLITATOM.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPESLITATOM.TEST index d8611c0e..938de0a6 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPESLITATOM.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-DATATYPESLITATOM.TEST @@ -1 +1,130 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ISOPRS.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ISOPRS.TEST index 143b941e..ca28dba6 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ISOPRS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-ISOPRS.TEST @@ -1 +1,191 @@ -;; ;; 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 +;; +;; 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 index 6f2a86e9..b820f35c 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-RECORDS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERLISP-RECORDS.TEST @@ -1 +1,664 @@ -(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 +(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 diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERPRETER-AR8538.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERPRETER-AR8538.TEST index 7b8262da..f2cafbac 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/INTERPRETER-AR8538.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERPRETER-AR8538.TEST @@ -1 +1,6 @@ -;;; 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 +;;; 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))) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/INTERPRETERS-AR8366.TEST b/internal/test/LANGUAGE/from-sun/language/other/INTERPRETERS-AR8366.TEST index 9bf6c5ba..269924a6 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/INTERPRETERS-AR8366.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/INTERPRETERS-AR8366.TEST @@ -1 +1,6 @@ -;;; 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 +;;; 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)) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/LLINTERP-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/LLINTERP-REGRESSION.TEST index 9177390d..1cca4f82 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/LLINTERP-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/LLINTERP-REGRESSION.TEST @@ -1 +1,12 @@ -;; 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 +;; 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 #'+))) + diff --git a/internal/test/LANGUAGE/from-sun/language/other/LLREAD.TEST b/internal/test/LANGUAGE/from-sun/language/other/LLREAD.TEST index 1301b72b..7af9499a 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/LLREAD.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/LLREAD.TEST @@ -1 +1,12 @@ -;;; 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 +;;; 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 + + diff --git a/internal/test/LANGUAGE/from-sun/language/other/LLSYMBOL-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/LLSYMBOL-REGRESSION.TEST index d932fde8..ca1f8bf4 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/LLSYMBOL-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/LLSYMBOL-REGRESSION.TEST @@ -1 +1,8 @@ -;; 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 +;; 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)))) diff --git a/internal/test/LANGUAGE/from-sun/language/other/LOCALFILE-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/LOCALFILE-REGRESSION.TEST index c117fec4..cc9d6f03 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/LOCALFILE-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/LOCALFILE-REGRESSION.TEST @@ -1 +1,24 @@ -;;; 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 +;;; 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") + ) + ) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/LONGFNCALL.TEST b/internal/test/LANGUAGE/from-sun/language/other/LONGFNCALL.TEST index 1b0562a8..b3c407b7 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/LONGFNCALL.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/LONGFNCALL.TEST @@ -1 +1,26 @@ -(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 +(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 diff --git a/internal/test/LANGUAGE/from-sun/language/other/NAMESTRING-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/NAMESTRING-REGRESSION.TEST index 7a5fac81..8d0bb51c 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/NAMESTRING-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/NAMESTRING-REGRESSION.TEST @@ -1 +1,9 @@ -;; 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 +;; 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))) + diff --git a/internal/test/LANGUAGE/from-sun/language/other/NLISTP.TEST b/internal/test/LANGUAGE/from-sun/language/other/NLISTP.TEST index 123b77c6..08ccb9ec 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/NLISTP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/NLISTP.TEST @@ -1 +1,125 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/NUMBERP.TEST b/internal/test/LANGUAGE/from-sun/language/other/NUMBERP.TEST index e242be3e..5906672a 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/NUMBERP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/NUMBERP.TEST @@ -1 +1,130 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-ARS.TEST b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-ARS.TEST index 356ed4ad..7eca9a7c 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-ARS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-ARS.TEST @@ -1 +1,241 @@ -;; ;; 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 +;; +;; 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 diff --git a/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONDITIONS.TEST b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONDITIONS.TEST index 55c64c33..d0aa9586 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONDITIONS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONDITIONS.TEST @@ -1 +1,227 @@ -;; ;; 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 +;; +;; 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 index fd36dc55..f225ba98 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER-TEST.DATA +++ b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER-TEST.DATA @@ -1 +1,190 @@ -(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 +(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 diff --git a/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER.TEST b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER.TEST index 830a96d7..b73b2066 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/PACKAGE-CONVERTER.TEST @@ -1 +1,102 @@ -;; ;; 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 +;; +;; 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 index 98772eae..89cc1bd9 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/PRETTY-CIRCLE-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/PRETTY-CIRCLE-REGRESSION.TEST @@ -1 +1,14 @@ -;;; 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 +;;; 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 index 2d9be223..727f4b9a 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/PRINTING-MINUS0.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/PRINTING-MINUS0.TEST @@ -1 +1,3 @@ -(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 +(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 index 5a8e9fde..c8105c7a 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/PROC-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/PROC-REGRESSION.TEST @@ -1 +1,28 @@ -;;; 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 +;;; 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 + + diff --git a/internal/test/LANGUAGE/from-sun/language/other/PROPERTY.TEST b/internal/test/LANGUAGE/from-sun/language/other/PROPERTY.TEST index 7ead376f..3499444c 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/PROPERTY.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/PROPERTY.TEST @@ -1 +1,116 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/REGRESSION.TEST index 2b2e951f..f626e7af 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/REGRESSION.TEST @@ -1 +1,51 @@ -(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 +(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))) +) + diff --git a/internal/test/LANGUAGE/from-sun/language/other/RESETVAR-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/RESETVAR-REGRESSION.TEST index c936428a..bdd17979 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/RESETVAR-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/RESETVAR-REGRESSION.TEST @@ -1 +1,5 @@ -(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 +(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 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 index 76716b94..5701e133 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/SIMPLE-SUPPLIED-P.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/SIMPLE-SUPPLIED-P.TEST @@ -1 +1,24 @@ -;;;; 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 +;;;; 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))) +) 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 index 0b7ff9d0..eb2f550d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/other/SINGLE-OP-ARITH.TEST 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 index de104fcd..38629864 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/SINGLE-VALUE.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/SINGLE-VALUE.TEST @@ -1 +1,3 @@ -(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 +(DO-TEST "AR 8409 - IL:MKATOM shouldn't return multiple values" + (NULL (CDR (MULTIPLE-VALUE-LIST (IL:MKATOM "FOO"))))) +STOP diff --git a/internal/test/LANGUAGE/from-sun/language/other/SMALLP.TEST b/internal/test/LANGUAGE/from-sun/language/other/SMALLP.TEST index b6f0d1bc..3b57e9b8 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/SMALLP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/SMALLP.TEST @@ -1 +1,125 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/SPECIALS.TEST b/internal/test/LANGUAGE/from-sun/language/other/SPECIALS.TEST index 5df26ea7..a4df8780 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/SPECIALS.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/SPECIALS.TEST @@ -1 +1,76 @@ -(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 +(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 index dc46be39..bac00fbe 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/STACK.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/STACK.TEST @@ -1 +1,17 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/from-sun/language/other/STRING.TEST b/internal/test/LANGUAGE/from-sun/language/other/STRING.TEST index 9a653eff..32cd1782 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/STRING.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/STRING.TEST @@ -1 +1,146 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/STRING.TESTS b/internal/test/LANGUAGE/from-sun/language/other/STRING.TESTS index 3fe235ca..2d1e1d1b 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/STRING.TESTS +++ b/internal/test/LANGUAGE/from-sun/language/other/STRING.TESTS @@ -1 +1,19 @@ -(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 +(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 index b73de165..639dc2c6 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/STRINGP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/STRINGP.TEST @@ -1 +1,127 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/STRINGS-AR7993.TEST b/internal/test/LANGUAGE/from-sun/language/other/STRINGS-AR7993.TEST index 26dee76e..c6b174e3 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/STRINGS-AR7993.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/STRINGS-AR7993.TEST @@ -1 +1,22 @@ -;; 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 +;; 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 index 0db29bdc..60397cbe 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/STRUCTURE-PRINT-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/STRUCTURE-PRINT-REGRESSION.TEST @@ -1 +1,13 @@ -;; 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 +;; 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 diff --git a/internal/test/LANGUAGE/from-sun/language/other/TIME-PATCH.TEST b/internal/test/LANGUAGE/from-sun/language/other/TIME-PATCH.TEST index 94e71cfd..3ffa1f60 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/TIME-PATCH.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/TIME-PATCH.TEST @@ -1 +1,18 @@ -(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 +(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 index d027cb78..81389fc5 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/TYPENAME.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/TYPENAME.TEST @@ -1 +1,72 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/TYPENAMEP.TEST b/internal/test/LANGUAGE/from-sun/language/other/TYPENAMEP.TEST index 4230910d..ad00f8b7 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/TYPENAMEP.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/TYPENAMEP.TEST @@ -1 +1,86 @@ -;; 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 +;; 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 + diff --git a/internal/test/LANGUAGE/from-sun/language/other/USERDEF.TEST b/internal/test/LANGUAGE/from-sun/language/other/USERDEF.TEST index ef59059a..a26c5522 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/USERDEF.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/USERDEF.TEST @@ -1 +1,34 @@ -(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 +(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 index 2b5f93ec..d68fef82 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/VECTOR.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/VECTOR.TEST @@ -1 +1,4 @@ -; 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 +; 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 index 03b3dc4e..0b7cfd41 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/WRAPPERS-AR7900.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/WRAPPERS-AR7900.TEST @@ -1 +1,5 @@ -;;; 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 +;;; 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) +) diff --git a/internal/test/LANGUAGE/from-sun/language/other/WRITEFILE-REGRESSION.TEST b/internal/test/LANGUAGE/from-sun/language/other/WRITEFILE-REGRESSION.TEST index e024eb2a..0638f846 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/WRITEFILE-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/WRITEFILE-REGRESSION.TEST @@ -1 +1,3 @@ -(do-test "WRITEFILE closes its file once" (il:writefile '((plus 2 3)(times 4 5)) '{dsk}foofile)) STOP \ No newline at end of file +(do-test "WRITEFILE closes its file once" + (il:writefile '((plus 2 3)(times 4 5)) '{dsk}foofile)) +STOP 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 index 87367d66..e6991210 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/XCL-COMPILER-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/XCL-COMPILER-REGRESSION.TEST @@ -1 +1,229 @@ -;; 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 +;; 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 index e2a4c7af..582de9d5 100644 --- a/internal/test/LANGUAGE/from-sun/language/other/XCLC-REGRESSION.TEST +++ b/internal/test/LANGUAGE/from-sun/language/other/XCLC-REGRESSION.TEST @@ -1 +1,155 @@ -;; 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 +;; 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)))))) + 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 index 6729c282..4fca3a71 100644 --- 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 @@ -1 +1,70 @@ -;; 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 +;; 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 + + + + 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 index bc20495e..ed2b6db1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GET-PROPERTIES.DFASL 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 index 8190a18d..739b274b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GET.DFASL 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 index a64b46f2..c7c65253 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-GETF.DFASL 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 index d48beabb..48e41324 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-REMF.DFASL 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 index 99dfb0ce..1dc68bba 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-REMPROP.DFASL 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 index 2a4f746c..17c86f55 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-1-SYMBOL-PLIST.DFASL 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 index df5817be..24478966 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-2-SYMBOL-NAME.DFASL 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 index 72776bb3..a0a7caf8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-COPY-SYMBOL.DFASL 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 index a1fd9e10..d29473e7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-GENSYM.DFASL 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 index 91fcafb4..d3bc0305 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-GENTEMP.DFASL 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 index 10a0b242..ae459397 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-KEYWORDP.DFASL 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 index 425dc7d4..0a2723ee 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-MAKE-SYMBOL.DFASL 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 index 1ac880d5..a9977dac 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/10-3-SYMBOL-PACKAGE.DFASL 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 index 28d8969a..0a9d03f2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-6-IMPORT.DFASL 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 index 662895b8..36d7b83b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-ALL-SYMBOLS.DFASL 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 index d46292b0..9c288806 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-EXTERNAL-SYMBOLS.DFASL 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 index 24700b43..eea18f70 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-DO-SYMBOLS.DFASL 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 index fb742032..cabc8b58 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-EXPORT.DFASL 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 index 1c29266f..a74f17a9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-ALL-SYMBOLS.DFASL 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 index fe0896f3..6d78f46e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-PACKAGE.DFASL 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 index e185e8c8..e5809f3d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-FIND-SYMBOL.DFASL 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 index cab7952b..086cb823 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-IMPORT.DFASL 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 index 6127e649..49ca00d8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-IN-PACKAGE.DFASL 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 index c10ba974..3d24010b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-INTERN.DFASL 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 index 5e155506..c63328be 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-LIST-ALL-PACKAGES.DFASL 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 index 88070d30..8cdc5a47 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-MAKE-PACKAGE.DFASL 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 index a64c827e..e6f21b7f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-NAME.DFASL 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 index 33ad1be1..d0d55e1d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-NICKNAMES.DFASL 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 index cd484fc1..9cc50860 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-SHADOWING-SYMBOLS.DFASL 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 index ed56cc99..3191268c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-USE-LIST.DFASL 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 index d44cbb36..01003650 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-PACKAGE-USED-BY-LIST.DFASL 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 index a0450ce7..961ada51 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-RENAME-PACKAGE.DFASL 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 index f75aa46c..32eff8ba 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-SHADOW.DFASL 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 index b020270d..96c355d4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-SHADOWING-IMPORT.DFASL 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 index b249238a..5ff11331 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNEXPORT.DFASL 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 index 8f9c0e12..39577cc5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNINTERN.DFASL 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 index f796c55c..37cf8890 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-UNUSE-PACKAGE.DFASL 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 index 3af07b5c..faa5e8ed 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-7-USE-PACKAGE.DFASL 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 index 9c4b403e..01e93248 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/11-8-PROVIDE.DFASL 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 index e6ebcf6c..48f29c24 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-10-IMPLEMENTATION-PARAMETERS.DFASL 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 index 6c263796..6fba3d36 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-EVENP.DFASL 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 index 87636c1c..e0f57cd2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-MINUSP.DFASL 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 index 0677139e..6b4f93ca 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-ODDP.DFASL 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 index fd398704..9bd6d1c1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-PLUSP.DFASL 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 index 96004e1e..873b0dee 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-2-ZEROP.DFASL 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 index 1f323114..22caef14 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-EQP.DFASL 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 index af8b8189..e1bc779e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-GEQ.DFASL 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 index d315d2f4..1bd5b660 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-GREATERP.DFASL 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 index 04fddfc1..445d59e4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-LEQ.DFASL 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 index 7d272754..99bac10c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-LESSP.DFASL 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 index b0c4dc13..11d62bb6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-MAX.DFASL 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 index d6ea5edf..2a257130 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-MIN.DFASL 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 index d2727e0c..81906601 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-3-NEQP.DFASL 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 index 7bb06066..b00a1053 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-+.DFASL 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 index 9a86d40c..163165c7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4--.DFASL 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 index 26a3b123..79f1e7bb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-1+.DFASL 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 index d291e91a..ed58dd9c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-1-.DFASL 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 index b1af9267..14119d6a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-CONJUGATE.DFASL 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 index 639240c2..5fd0feba 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-DECF.DFASL 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 index 1a7d2aac..3a7dd054 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-GCD.DFASL 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 index 645e96c5..d1b97dee 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-INCF.DFASL 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 index 8406d795..f6dc86ef 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-LCM.DFASL 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 index 1330a09d..e75bfad8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-QUOTIENT.DFASL 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 index 5d0f26f6..7ab1c52c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-4-TIMES.DFASL 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 index 134ccfa5..ca0c01d3 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-EXP.DFASL 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 index 97023147..2cd0c00a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-EXPT.DFASL 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 index 31064a09..637c99fa 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-ISQRT.DFASL 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 index 52cb5ad4..d80920fe 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-LOG.DFASL 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 index 5d9bef85..b83e9d82 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-1-SQRT.DFASL 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 index a85443eb..54a354d5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ABS.DFASL 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 index af7bfde0..7bfef9cf 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ACOS.DFASL 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 index 0babd097..4d207978 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ACOSH.DFASL 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 index c127ce2a..41cf3e71 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ASIN.DFASL 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 index 56d9b955..ae4cb3bb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ASINH.DFASL 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 index 7d003a92..a72d39fb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ATAN.DFASL 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 index 7a4bd970..7eeee78c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-ATANH.DFASL 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 index 2e4e2164..f96b3461 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-CIS.DFASL 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 index 1500e6ca..59361151 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-COS.DFASL 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 index 5d7190ef..67b7c948 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-COSH.DFASL 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 index 4695723c..dcc57f24 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-PHASE.DFASL 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 index 866665fb..64281de8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SIGNUM.DFASL 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 index 0927b084..569a74f9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SIN.DFASL 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 index 70a98602..1d1b6758 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-SINH.DFASL 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 index 5f9aab29..b3f30ab1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-TAN.DFASL 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 index 1cfaf94f..5213b348 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-5-2-TANH.DFASL 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 index 27798b65..c8df1ee8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-CEILING.DFASL 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 index 861ea10f..96bbe07e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-COMPLEX.DFASL 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 index 3fcbb3d5..1a455d9b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-DECODE-FLOAT.DFASL 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 index c709c252..55a717f1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-DENOMINATOR.DFASL 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 index 0bd76882..e2d8bfcb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FCEILING.DFASL 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 index 82b5029b..565bf10d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FFLOOR.DFASL 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 index c74fc801..ff1b8f1e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-DIGITS.DFASL 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 index 052268f2..b75cabd8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-PRECISION.DFASL 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 index fbb1a041..fdfa203f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-RADIX.DFASL 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 index a282844d..bc07ec63 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT-SIGN.DFASL 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 index d79f7f56..6e54f52c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOAT.DFASL 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 index 55806686..733b706d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FLOOR.DFASL 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 index 92698194..5d12b603 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FROUND.DFASL 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 index 48cbc0ca..65210ba4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-FTRUNCATE.DFASL 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 index e5b3fe50..9c8a73c2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-IMAGPART.DFASL 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 index eb99080e..c52ba581 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-INTEGER-DECODE-FLOAT.DFASL 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 index ebd1d962..dbd01fd0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-MOD.DFASL 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 index fa5a2d8a..8e1fecd7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-NUMERATOR.DFASL 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 index 62b206bf..4f78b3c4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-RATIONAL.DFASL 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 index 863ee24d..cb7c3321 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-RATIONALIZE.DFASL 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 index 859b2eb7..d949aef8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-REALPART.DFASL 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 index 48f2c106..e7fa5410 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-REM.DFASL 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 index 28ebef26..0888f8fe 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-ROUND.DFASL 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 index 3cea44d2..2e1fddfa 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-SCALE-FLOAT.DFASL 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 index 28b199e4..246004f8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-6-TRUNCATE.DFASL 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 index 96059e25..b16b6357 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-ASH.DFASL 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 index e5814b58..47cdb60b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-BOOLE.DFASL 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 index d75fa05a..945f71cb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-INTEGER-LENGTH.DFASL 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 index 46f2f8e2..70941b5e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGAND.DFASL 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 index 9c2eebf5..2ad3572c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGANDC1.DFASL 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 index 1a2bae27..a7e4ef77 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGANDC2.DFASL 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 index a6e264ac..c17321cd 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGBITP.DFASL 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 index 8d0954bb..e9e1e6ef 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGCOUNT.DFASL 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 index 4337e12f..5d98c972 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGEQV.DFASL 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 index 619ef08f..37d7e56c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGIOR.DFASL 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 index 25334118..b0c6f595 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNAND.DFASL 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 index 8adb2160..42926b8d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNOR.DFASL 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 index e04679d5..3678511e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGNOT.DFASL 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 index 49ebbbd3..b99f3871 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGORC1.DFASL 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 index 4c730c3f..5a8b89ae 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGORC2.DFASL 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 index fd316cb1..a6f2eb14 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGTEST.DFASL 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 index e0ac9086..59efdcbc 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-7-LOGXOR.DFASL 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 index 5ccd5880..b1675a22 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE-POSITION.DFASL 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 index fe485a64..1acb1e59 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE-SIZE.DFASL 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 index da67d003..954bcbfa 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-BYTE.DFASL 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 index 31f50c26..2370dd43 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-DEPOSIT-FIELD.DFASL 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 index fed7ff8d..794ebcdb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-DPB.DFASL 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 index b4ef2a98..3273a96a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-LDB-TEST.DFASL 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 index 957524c6..65fd663d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-LDB.DFASL 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 index fab175e1..ed4f0dd7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-8-MASK-FIELD.DFASL 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 index 17224daf..b74b3318 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-9-MAKE-RANDOM-STATE.DFASL 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 index f0da6bfd..185f83ae 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/12-9-RANDOM.DFASL 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 index 6c3868e5..493e3feb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-1-CHARACTERATTRIBUTES.DFASL 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 index 1c17bc96..b0ce064a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-ALPHA-CHAR-P.DFASL 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 index 03f20fe7..0af646e2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-ALPHANUMERIC-P.DFASL 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 index 7460aa14..c0ef6dba 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-BOTH-CASE-P.DFASL 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 index ee9d8667..186ebe7e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-EQUAL.DFASL 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 index 0af83b52..a2080e15 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GE.DFASL 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 index 004d2407..d93efe6f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GREATERP.DFASL 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 index 61e24482..e2436d8b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-GT.DFASL 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 index fffa1b05..8f7e78de 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LE.DFASL 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 index 4ff95024..bc0a1eef 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LESSP.DFASL 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 index 518f8fb7..c5b03f47 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-LT.DFASL 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 index ae1c7bac..7b34bdb5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-EQUAL.DFASL 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 index 4d8353bc..a98bf402 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-GREATERP.DFASL 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 index c54248ef..a9562549 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAR-NOT-LESSP.DFASL 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 index 9afb4d4b..64a7b32b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHAREQ.DFASL 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 index b5f19e2b..bf02dd21 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-CHARNEQ.DFASL 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 index fd9cb597..00f66e35 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-DIGIT-CHAR-P.DFASL 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 index 09672706..837b8b45 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-GRAPHIC-CHAR-P.DFASL 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 index d44f218c..444297a0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-LOWER-CASE-P.DFASL 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 index 2fe40eb4..0b684ca9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-STANDARD-CHAR-P.DFASL 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 index 4883752b..9d7d13a6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-STRING-CHAR-P.DFASL 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 index c7e6f071..604a7c58 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-2-UPPER-CASE-P.DFASL 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 index 08ec313d..162c730a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-BITS.DFASL 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 index cd743c45..9a3f5433 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-CODE.DFASL 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 index 9c5db677..c94f2de7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CHAR-FONT.DFASL 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 index e2b1f7f3..bb3524d0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-CODE-CHAR.DFASL 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 index 53298896..a5554531 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-3-MAKE-CHAR.DFASL 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 index 17376176..76cd2d8c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-DOWNCASE.DFASL 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 index 30fed284..b09334d5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-INT.DFASL 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 index 673ff432..6ec79c02 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-NAME.DFASL 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 index b602c632..98f3d3cc 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHAR-UPCASE.DFASL 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 index bfa3a3f3..24533be1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-CHARACTER.DFASL 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 index c52b48f7..57e1d83d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-DIGIT-CHAR.DFASL 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 index 2c13d0e5..bc6b6c72 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-INT-CHAR.DFASL 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 index b270db6f..8f9847e7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-4-NAME-CHAR.DFASL 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 index 5281db2d..f394cd6c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-5-CHAR-BIT.DFASL 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 index 1fe2e865..333b56fe 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/13-5-SET-CHAR-BIT.DFASL 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 index ae17143b..c122a12f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-COPY-SEQ.DFASL 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 index e965aa7c..ef0e9ff6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-ELT.DFASL 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 index bdc81e2f..b6e5be8f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-LENGTH.DFASL 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 index d3b90b60..3a9dcf24 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-MAKE-SEQUENCE.DFASL 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 index 3ffc5f5e..a2a0a438 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-NREVERSE.DFASL 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 index 7df65acf..26b9e150 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-REVERSE.DFASL 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 index d3673a22..45285ad7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-1-SUBSEQ.DFASL 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 index 08352fa3..d2378299 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-CONCATENATE.DFASL 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 index 2bb6ef00..3637c0d1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-EVERY.DFASL 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 index 61fe2602..bc3c25c2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-MAP.DFASL 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 index 91a6e80c..2a0c93e7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-NOTANY.DFASL 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 index 2345bddc..855a8325 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-NOTEVERY.DFASL 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 index 296f84e8..92e364a6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-REDUCE.DFASL 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 index 77aa73b1..81e23d2b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-2-SOME.DFASL 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 index 8cc60703..9c2870e8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-DUPLICATES.DFASL 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 index 3cbc8a1e..6b95a83d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-IF-NOT.DFASL 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 index 94bb6452..9aa0e646 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE-IF.DFASL 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 index f04311fb..3bdef7b8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-DELETE.DFASL 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 index bf174fea..64310148 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FILL.DFASL 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 index 06afa871..655c6a20 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND-IF-NOT.DFASL 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 index a2f7c4b9..bb7525d8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND-IF.DFASL 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 index 8f806d47..2e8f2aab 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-FIND.DFASL 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 index 6e5737c1..7a83127d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE-IF-NOT.DFASL 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 index 6c69f9ae..8b1d245d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE-IF.DFASL 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 index 83ed1a49..3aec7846 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-NSUBSTITUTE.DFASL 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 index 13ed8013..aa9ad85f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION-IF-NOT.DFASL 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 index 9c87410c..40107c18 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION-IF.DFASL 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 index adaca5a2..7f4d4b22 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-POSITION.DFASL 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 index 893d50d6..c0ac6caa 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-DUPLICATES.DFASL 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 index 35a1777e..f62a7c24 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-IF-NOT.DFASL 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 index 84483dd3..b8643edc 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE-IF.DFASL 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 index b311a9a2..19ad2e65 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-REMOVE.DFASL 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 index 3fe3649e..d8e7e225 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE-IF-NOT.DFASL 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 index 0e383f7f..a85c1ef0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE-IF.DFASL 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 index b472e39f..e450681e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-3-SUBSTITUTE.DFASL 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 index fb21e499..f7721acb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT-IF-NOT.DFASL 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 index 2c726210..e5d323ad 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT-IF.DFASL 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 index 0b107f52..49cd45c4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-COUNT.DFASL 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 index 8b06e578..ffb3c5fb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-4-MISMATCH.DFASL 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 index f090eb3e..ff7e231c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-MERGE.DFASL 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 index 32004db0..0c11b04e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-SORT.DFASL 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 index 785ac9f0..91dd26f0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/14-5-STABLE-SORT.DFASL 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 index bdc8b34a..a52523e3 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAAAR.DFASL 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 index b36fb5c1..83a0f9e1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAADR.DFASL 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 index 4059ed9f..c659b2aa 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAAR.DFASL 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 index 0531da85..83a18364 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADAR.DFASL 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 index 7f75e2ac..39b6c29e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADDR.DFASL 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 index 139da523..b5747ffe 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAADR.DFASL 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 index 82e127bc..38a7356d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAAR.DFASL 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 index 1c79b7cb..20f5ff92 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADAA.DFASL 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 index 34487b62..305bbe3b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADADR.DFASL 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 index 9183c5f6..f21ad982 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADAR.DFASL 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 index ae5bfd66..9b159db4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDAR.DFASL 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 index 17374008..ea9f9475 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDDR-AND-FOURTH.DFASL 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 index 366ca367..9db0231e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADDR-AND-THIRD.DFASL 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 index 88ef70b9..c1c4e305 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CADR-AND-SECOND.DFASL 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 index 392eac1d..b0fd2442 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CAR-AND-FIRST.DFASL 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 index d24fb7ee..6ea3dd67 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAAAR.DFASL 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 index 9cdc72c9..0f5e4b34 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAADR.DFASL 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 index 0318cbdc..ffe3a52c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAAR.DFASL 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 index 6b46fd84..e7b28d17 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADAR.DFASL 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 index ff17dc27..9b4e5cb1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADDR.DFASL 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 index 45e1fc46..bcb7d210 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDADR.DFASL 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 index b6a8c077..3c742b68 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDAR.DFASL 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 index dc54729e..686f052c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDAAR.DFASL 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 index c94be82e..3c0b3b49 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDADR.DFASL 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 index cc162b25..f076d076 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDAR.DFASL 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 index 5e1c43f9..a4af973d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDAR.DFASL 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 index 0ce5aacc..87303553 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDDR.DFASL 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 index b14962f7..096ff9db 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDDR.DFASL 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 index b79f95dd..c815a02e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDDR.DFASL 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 index f1c02095..6a7ca6eb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CDR-AND-REST.DFASL 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 index 88aa7b2a..f76aed4d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-CONS.DFASL 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 index 034658e0..ab985bfe 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-1-TREE-EQUAL.DFASL 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 index 9416c5a2..5e2b8459 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-APPEND.DFASL 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 index acf03d45..43d4149f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-BUTLAST.DFASL 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 index 709bb06f..a0d745e8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-ALIST.DFASL 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 index d91886a7..72bf0914 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-LIST.DFASL 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 index 5cfa7e66..68aec594 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-COPY-TREE.DFASL 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 index 2105724b..a9e243cd 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-EIGHTH.DFASL 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 index cb42b166..86e3f7fb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-ENDP.DFASL 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 index 546dad86..c95d547e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FIFTH.DFASL 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 index d948ff1a..dfba2855 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FIRST.DFASL 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 index 0c9b92dc..48ecc980 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-FOURTH.DFASL 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 index 8c9af132..263e4535 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LAST.DFASL 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 index e9af7281..a8da1ac4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LDIFF.DFASL 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 index caa62b35..46af6c48 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LIST-LENGTH.DFASL 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 index ba1292d1..b6a8cd65 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LIST.DFASL 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 index 1e643626..7401e9c7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-LISTSTAR.DFASL 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 index 042ff3bd..e4496a51 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-MAKE-LIST.DFASL 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 index c38b79e7..f17f2a82 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NBUTLAST.DFASL 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 index 5a54bc84..297e57d6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NCONC.DFASL 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 index b83f4772..54646c44 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NINTH.DFASL 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 index 3382886d..9fdc8dbe 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NRECONC.DFASL 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 index bf8ffd97..e5061938 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NTH.DFASL 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 index 5e02c7cc..afad474f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-NTHCDR.DFASL 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 index 19faf6d2..7864e39d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-POP.DFASL 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 index dc98fbc3..9e23ce9f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-PUSH.DFASL 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 index 0857a4c9..3b100606 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-PUSHNEW.DFASL 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 index 5f4efdc6..566ef593 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-REST.DFASL 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 index 2c6ad1d1..e285b4b6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-REVAPPEND.DFASL 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 index 241e62b6..fe20311e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SECOND.DFASL 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 index cc8cede8..22eeec6a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SEVENTH.DFASL 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 index 2e78f49c..0193861b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-SIXTH.DFASL 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 index c9f3aad4..7e812ceb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-TENTH.DFASL 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 index 844e030c..c41ba548 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-2-THIRD.DFASL 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 index 4618dd24..fd19a99e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-3-RPLACA.DFASL 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 index c20aeb33..0d924d69 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-3-RPLACD.DFASL 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 index a4f22773..6c6da6c0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBLIS.DFASL 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 index 6ef07d78..1b23e6af 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST-IF-NOT.DFASL 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 index 9e1479e1..5ff0ea26 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST-IF.DFASL 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 index 5a66cd13..de811bee 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-NSUBST.DFASL 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 index b6585e60..f8246102 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBLIS.DFASL 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 index fdefbaf4..47231210 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST-IF-NOT.DFASL 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 index b933b383..652a10c6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST-IF.DFASL 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 index df7e4c81..13b2fc94 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-4-SUBST.DFASL 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 index 0a562c90..d9896d87 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-ADJOIN.DFASL 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 index 7bd59703..c09a0ce9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-INTERSECTION.DFASL 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 index ac0e97ec..178fdf7d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER-IF-NOT.DFASL 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 index e922c593..0d7066dd 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER-IF.DFASL 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 index 57dec952..c0a3b602 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-MEMBER.DFASL 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 index 082dcb7b..1e1ff8e5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NINTERSECTION.DFASL 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 index d676aa62..d7b89a3f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NSET-DIFFERENCE.DFASL 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 index 7744e28e..2bbe5120 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NSET-EXCLUSIVE-OR.DFASL 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 index 747671d3..e41d000a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-NUNION.DFASL 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 index 7abdb163..ee7bd06e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-SET-DIFFERENCE.DFASL 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 index ec1d5752..d909a3b1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-SUBSETP.DFASL 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 index 4c81e2e2..e03618ff 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-TAILP.DFASL 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 index dfe9f825..6871a730 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-5-UNION.DFASL 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 index c449fae4..df1a0f63 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ACONS.DFASL 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 index dc76d324..db710f99 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC-IF-NOT.DFASL 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 index 04d60199..d812568a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC-IF.DFASL 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 index 40cf353f..3e1af72e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-ASSOC.DFASL 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 index 95e68155..48989d24 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-PAIRLIS.DFASL 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 index efab7bac..9bffd1e6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC-IF-NOT.DFASL 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 index 77f53c11..ee2df489 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC-IF.DFASL 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 index 21b79764..2346de9b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/15-6-RASSOC.DFASL 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 index 8de3af0b..0e2cecba 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-CLRHASH.DFASL 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 index 5a3d0137..aa8859cf 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-GETHASH.DFASL 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 index 486fef64..20618df2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-HASH-TABLE-COUNT.DFASL 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 index 498bbcb8..fabac651 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-HASH-TABLE-P.DFASL 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 index d3ad9392..12218987 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-MAKE-HASH-TABLE.DFASL 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 index 1bb34f08..274ee8f3 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-MAPHASH.DFASL 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 index 37b7b36b..55e25a8f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-1-REMHASH.DFASL 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 index 5fb1d339..3c40eada 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/16-2-SXHASH.DFASL 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 index 675f7c6e..b550eea8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-1-MAKE-ARRAY.DFASL 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 index d1e80647..ace97b94 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-1-VECTOR.DFASL 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 index fe350ac3..50add7a0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-2-AREF.DFASL 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 index 0bff00f8..e2b3afec 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-2-SVREF.DFASL 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 index 7160a5bd..8d6b964c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ADJUSTABLE-ARRAY-P.DFASL 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 index a7da2773..fd5414c0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-DIMENSION.DFASL 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 index 3f22f31a..bb24cbc4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-DIMENSIONS.DFASL 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 index f64e73b3..ad5cf0cf 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-ELEMENT-TYPE.DFASL 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 index 620c9c30..8abc3ad9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-IN-BOUNDS-P.DFASL 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 index ab325979..88d2360d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-RANK.DFASL 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 index 9e3211ef..a6334a6b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-ROW-MAJOR-INDEX.DFASL 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 index 0101ba7d..c158b2da 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-3-ARRAY-TOTAL-SIZE.DFASL 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 index 019b065d..038c2a49 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-AND.DFASL 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 index 5788b48f..5e8d3c23 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ANDC1.DFASL 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 index 258b779c..5a067c82 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ANDC2.DFASL 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 index 9ea46e53..51192295 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-EQV.DFASL 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 index 50cbd1c7..262edbf9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-IOR.DFASL 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 index 97c5aa7f..5316b067 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NAND.DFASL 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 index 348e3021..98d70304 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NOR.DFASL 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 index a72ccd2b..e0a85e10 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-NOT.DFASL 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 index 676f4ac6..9c1bbd9f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ORC1.DFASL 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 index 3ae1a89c..d2499024 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-ORC2.DFASL 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 index b9d23795..f9dbe6b7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT-XOR.DFASL 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 index 2025ec2a..3d4b99d2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-BIT.DFASL 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 index 6b8ee2cb..fc2aa092 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-4-SBIT.DFASL 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 index b5f4a714..7d60c557 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-ARRAY-HAS-FILL-POINTER-P.DFASL 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 index 9bedb1f7..0f51edb3 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-FILL-POINTER.DFASL 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 index 0511c4e5..a4e8f5a6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-POP.DFASL 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 index 761ec79b..1d74b73e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-PUSH-EXTEND.DFASL 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 index b1a05adf..f73aabf1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-5-VECTOR-PUSH.DFASL 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 index 78d1b3d1..e0150599 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/17-6-ADJUST-ARRAY.DFASL 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 index 9f6a81ea..590e1eea 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-1-CHAR.DFASL 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 index 415202ab..dc9b3ae4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-1-SCHAR.DFASL 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 index b691b9b3..e8e0a9c1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-EQ.DFASL 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 index f09e785c..bc41ecd9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-EQUAL.DFASL 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 index 81e063ec..e1332d95 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GE.DFASL 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 index 24196377..4cc2b26a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GREATERP.DFASL 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 index 9321bb41..761963ec 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-GT.DFASL 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 index 047a9221..408ecbbb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LE.DFASL 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 index 0a0e017b..8d667bab 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LESSP.DFASL 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 index 5a7c32b4..eb495883 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-LT.DFASL 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 index 6fbcf3e4..7bb4d7d8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NEQ.DFASL 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 index d28f1f91..4e6f49b8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-EQUAL.DFASL 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 index 615c8a7b..a1f171fa 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-GREATERP.DFASL 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 index b7ecdd94..7adfc623 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-2-STRING-NOT-LESSP.DFASL 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 index 11c9bff8..35371611 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-MAKE-STRING.DFASL 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 index 402fe0c0..7e64e81e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-CAPITALIZE.DFASL 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 index aef1aced..d0e49a2e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-DOWNCASE.DFASL 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 index 870d016a..0edca1cc 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-NSTRING-UPCASE.DFASL 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 index 57f962a0..44829ad1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-CAPITALIZE.DFASL 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 index fc979a19..8256595b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-DOWNCASE.DFASL 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 index d3edceb4..1cc8e33b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-LEFT-TRIM.DFASL 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 index 73ec7291..43d90dd5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-RIGHT-TRIM.DFASL 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 index 86f0308b..55f39626 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-TRIM.DFASL 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 index 9a59a064..d4c7055b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING-UPCASE.DFASL 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 index 1880be5d..b1121f2f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/18-3-STRING.DFASL 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 index 956ad958..58fd7b2a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-APPLYHOOK.DFASL 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 index 2991f22d..c30c379a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-CONSTANTP.DFASL 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 index da2e3e87..7e365c90 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/20-1-EVAL.DFASL 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 index 73f41b07..35acff81 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-COPY-READTABLE.DFASL 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 index 5d093244..c0f4d231 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-GET-DISPATCH-MACRO-CHARACTER.DFASL 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 index 49061ee0..143d4c4f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-GET-MACRO-CHARACTER.DFASL 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 index 572b506f..68021f3a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-MAKE-DISPATCH-MACRO-CHARACTER.DFASL 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 index e7a29899..ef40068b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-READTABLEP.DFASL 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 index bf369439..4e2ab468 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-DISPATCH-MACRO-CHARACTER.DFASL 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 index 9b3e2743..b34ab990 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-MACRO-CHARACTER.DFASL 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 index 861d7759..ede03ef2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-1-5-SET-SYNTAX-FROM-CHAR.DFASL 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 index 356b0dac..f2c7bccb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-LISTEN.DFASL 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 index 26a161b0..f453a2af 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-PARSE-INTEGER.DFASL 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 index 97eebfae..7e4eeb3a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-PEEK-CHAR.DFASL 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 index baac4a29..f9da7100 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-CHAR-NO-HANG.DFASL 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 index d5edee26..b726f5c2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-CHAR.DFASL 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 index e9ada3b3..0690cdd5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-DELIMITED-LIST.DFASL 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 index fa5ea2b4..d66fe4b5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ-PRESERVING-WHITESPACE.DFASL 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 index ef6a5aff..aaf29d4b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-READ.DFASL 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 index 6024e6d7..ec3d7cfb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-2-1-UNREAD-CHAR.DFASL 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 index 7ae5cdc1..5c7d0b9d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-FINISH-OUTPUT.DFASL 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 index 7e5e6648..59729313 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-FRESH-LINE.DFASL 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 index 182ad503..47caf54b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PPRINT.DFASL 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 index 87392812..4b20fad4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRIN1-TO-STRING.DFASL 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 index 506b2308..bec05ef2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRIN1.DFASL 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 index 733874a1..e6ba80f1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINC-TO-STRING.DFASL 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 index b01ccf24..59541789 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINC.DFASL 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 index a01fe223..762f0243 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-PRINT.DFASL 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 index 3576b03a..0ca41af3 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-TERPRI.DFASL 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 index 3c021f9c..87df1cdd 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-CHAR.DFASL 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 index a49afc60..040d0e30 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-LINE.DFASL 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 index 026dd632..c9ef035a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-1-WRITE-STRING.DFASL 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 index e0b92d1b..2c62ecb7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/22-3-3-FORMAT.DFASL 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 index b152cd21..3cd9f2f0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/23-FUNCTIONS.DFASL 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 index 19d14e50..4e7641c0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-BREAK.DFASL 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 index 305bee87..695dd306 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-CERROR.DFASL 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 index e2872f60..6b686769 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-ERROR.DFASL 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 index b8223d41..4a8410c4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-1-WARN.DFASL 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 index 373d67f9..9799d798 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-2-ASSERT.DFASL 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 index 4809f1cc..f48a153a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-CCASE.DFASL 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 index ecaae617..fd898079 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-CTYPECASE.DFASL 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 index 4733e3fc..9e01696a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-ECASE.DFASL 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 index c623a3bf..a3e8999e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/24-3-ETYPECASE.DFASL 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 index 21330442..e25970b6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-COMPILE-FILE.DFASL 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 index 7d0335ee..1917d686 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-COMPILE.DFASL 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 index 2652bbce..5cc353ae 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-1-DISASSEMBLE.DFASL 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 index 05156ceb..bc5ab603 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-2-DOCUMENTATION.DFASL 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 index 407fc391..dd098801 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-APROPOS-LIST.DFASL 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 index 3c468513..67bc0597 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-APROPOS.DFASL 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 index 30effa98..0e995d95 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-DESCRIBE.DFASL 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 index 11c0d959..a8479285 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-ED.DFASL 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 index 55d58378..96241f23 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-INSPECT.DFASL 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 index 23117622..d3b0d776 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-ROOM.DFASL 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 index da40ef37..55a0fbd9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-3-TIME.DFASL 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 index c57c6332..f70139b0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-DECODE-UNIVERSAL-TIME.DFASL 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 index c81b0630..a4b675f5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-ENCODE-UNIVERSAL-TIME.DFASL 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 index eec97a32..00c7450f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-DECODED-TIME.DFASL 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 index 3fe1009c..d89ff6f9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-INTERNAL-REAL-TIME.DFASL 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 index 1384490c..79bd1200 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-INTERNAL-RUN-TIME.DFASL 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 index 390df6d3..89bbf5f8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-GET-UNIVERSAL-TIME.DFASL 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 index 9e2225e3..f23acaea 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-LISP-IMPLEMENTATION-VERSION.DFASL 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 index 8181e2c4..b4cd9fff 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-LONG-SITE-NAME.DFASL 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 index 424df4b3..a241269c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-INSTANCE.DFASL 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 index a0734874..28075e81 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-TYPE.DFASL 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 index 402dccbe..14eb6bdd 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-MACHINE-VERSION.DFASL 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 index 7ff05ef3..65d2d9d4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SHORT-SITE-NAME.DFASL 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 index a9a7c508..cca5f320 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SLEEP.DFASL 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 index c1449780..7d2a7d47 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SOFTWARE-TYPE.DFASL 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 index f56800aa..b82aa4f1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-4-SOFTWARE-VERSION.DFASL 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 index 9f5bf905..169c73e6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/25-5-IDENTITY.DFASL 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 index 28ae008b..a5af9b07 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/4-8-COERCE.DFASL 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 index c1ede303..a9ea8edb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/4-9-TYPE-OF.DFASL 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 index 11384d54..c0030d01 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-EXPRESSIONS.DFASL 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 index 807f1de5..914201a0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-LIST-KEYWORDS.DFASL 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 index acb6eb2b..f202b72d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-2-2-LAMBDA-PARAMETERS-LIMIT.DFASL 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 index af2275b2..2cc25d39 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-1-DEFUN.DFASL 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 index 39ad15ba..2fb0ffcc 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFCONSTANT.DFASL 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 index c4ed2745..7052034a 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFPARAMETER.DFASL 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 index 0384a4b4..8b30d9e8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-2-DEFVAR.DFASL 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 index b451ee23..06d02b0c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/5-3-3-EVAL-WHEN.DFASL 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 index 50d7da4a..9e111f70 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-1-SUBTYPEP.DFASL 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 index 7d08bf8f..51572a36 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-1-TYPEP.DFASL 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 index 2a6f6f03..e0201509 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-ARRAYP.DFASL 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 index 8a1a73cf..dfce77f4 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-ATOM.DFASL 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 index 68e20a7f..1bb9a799 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-BIT-VECTOR-P.DFASL 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 index ca66bf3d..d41a151c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-CHARACTERP.DFASL 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 index 36f6dd3c..224f6138 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMMONP.DFASL 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 index a950f0ee..bca9c27b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMPILED-FUNCTION-P.DFASL 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 index c5a98ea5..860b15aa 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-COMPLEXP.DFASL 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 index ef5b15fa..b9f9d839 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-CONSP.DFASL 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 index 3d4d31e4..2ae00c2c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-FLOATP.DFASL 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 index a4b52c1a..959ce35e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-FUNCTIONP.DFASL 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 index fa0a9055..ed35eb93 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-INTEGERP.DFASL 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 index 401a7c8c..72c3ed5f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-LISTP.DFASL 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 index 6b1face3..d9493029 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-NULL.DFASL 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 index 83aa69b5..dea2543b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-NUMBERP.DFASL 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 index a8c62651..cf204bd9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-PACKAGEP.DFASL 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 index e05a3796..aabffecd 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-RATIONALP.DFASL 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 index 6b0dba36..14805882 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-BIT-VECTOR-P.DFASL 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 index f0d741f4..93038dc3 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-STRING-P.DFASL 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 index 07646e28..34f05395 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SIMPLE-VECTOR-P.DFASL 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 index 194281d5..56edc526 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-STRINGP.DFASL 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 index b0fc45b3..c6d7419d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-SYMBOLP.DFASL 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 index bbaa70d7..22dcefae 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-2-2-VECTORP.DFASL 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 index a475379f..ddcc78e5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQ.DFASL 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 index 64251c99..25e931dc 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQL.DFASL 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 index 09e05934..82e9ecae 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQUAL.DFASL 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 index 69e63f83..67e20207 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-3-EQUALP.DFASL 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 index 4a994deb..86cd1ee0 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-AND.DFASL 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 index 989c43eb..ebf4b196 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-NOT.DFASL 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 index 5d5f9bde..2c326617 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/6-4-OR.DFASL 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 index 50139375..92fb01fb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-BOUNDP.DFASL 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 index 0990fc2e..db1909f5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-FBOUNDP.DFASL 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 index 58a41f51..fd3a9ac2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-FUNCTION.DFASL 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 index ae6cbcb6..d4fc9bd8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-QUOTE.DFASL 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 index 98eb79a3..d7a27d4b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SPECIAL-FORM-P.DFASL 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 index 72ad45d2..cbbb307c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SYMBOL-FUNCTION.DFASL 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 index 171e3d9f..a1f3ccd9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-1-SYMBOL-VALUE.DFASL 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 index 471b4f23..5942a857 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-FMAKUNBOUND.DFASL 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 index 0fd7d9d0..5b0b7810 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-MAKUNBOUND.DFASL 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 index 1bfcada5..2c2c4b23 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-PSETQ.DFASL 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 index 4d37a885..d4735617 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-1-2-SET.DFASL 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 index 586ddb44..955b255e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-CATCH.DFASL 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 index 771f873b..b0fee100 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-THROW.DFASL 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 index d8bc20a0..dbf9141b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-10-UNWIND-PROTECT.DFASL 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 index 0e32d81c..fb44f204 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFINE-MODIFY-MACRO.DFASL 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 index e39c2837..e3528d90 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFINE-SETF-METHOD.DFASL 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 index 6caf8138..22e7879b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-DEFSETF.DFASL 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 index 87697dd3..1e5bd12d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-GET-SETF-METHOD-MULTIPLE-VALUE.DFASL 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 index a69f35f1..858e1e7b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-GET-SETF-METHOD.DFASL 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 index 659e61dd..b65a13d9 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-PSETF.DFASL 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 index 68cdc1bc..f89a816f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-ROTATEF.DFASL 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 index 298e4fe2..7b67205f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-SETF.DFASL 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 index 7d4d6392..93139207 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-2-SHIFTF.DFASL 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 index 71469a66..7d205a84 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-APPLY.DFASL 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 index 837eb021..86bd731b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-CALL-ARGUMENTS-LIMIT.DFASL 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 index 0749e3f2..62a00206 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-3-FUNCALL.DFASL 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 index 56335ae1..374001d1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROG1.DFASL 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 index 36ed2de8..e0661aac 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROG2.DFASL 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 index 3b290f27..adedf42c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-4-PROGN.DFASL 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 index bde2c130..3e634c0c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-FLET.DFASL 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 index 39cd1c77..f854ccfe 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-LET.DFASL 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 index 84a5d023..fca261d2 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-LETSTAR.DFASL 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 index 62082c99..6a6cf1a3 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-MACROLET.DFASL 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 index 992be3ba..9ff0422e 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-5-PROGV.DFASL 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 index 4d50ba83..3b0e50fb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-CASE.DFASL 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 index 0f38f99e..edf9d029 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-COND.DFASL 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 index c1f68434..f05c8fd8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-IF.DFASL 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 index bbb3b82f..bca0fbc5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-TYPECASE.DFASL 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 index 1492a14c..d1d87fc3 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-UNLESS.DFASL 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 index 74efc0cf..3205edf5 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-6-WHEN.DFASL 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 index e334df32..ce08f1ac 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-7-RETURN-FROM.DFASL 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 index bf9496a1..5123f735 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-7-RETURN.DFASL 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 index 22a10022..08ebac9c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-1-LOOP.DFASL 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 index f3046468..e4f33c03 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-2-DO.DFASL 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 index 23394660..ff072e48 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-2-DOSTAR.DFASL 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 index d5b0273a..49b43246 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-3-DOLIST.DFASL 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 index 6624bf74..c1922702 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-3-DOTIMES.DFASL 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 index bdd73131..fb4081b8 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPC.DFASL 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 index b4e27223..94ff4a7b 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCAN.DFASL 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 index 631f08d0..6466e94c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCAR.DFASL 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 index 6ac055d2..8c96ef04 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPCON.DFASL 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 index aec2214e..ff274a3c 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPL.DFASL 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 index 7f9dc3e7..181e6077 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPLIST.DFASL 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 index e2da1955..4a1c1a86 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-4-MAPPER.DFASL 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 index ee050df1..2ea34737 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-GO.DFASL 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 index 79b8283d..2ca6d934 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-PROG.DFASL 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 index 8907c505..bc7f6749 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-PROGSTAR.DFASL 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 index 241726d3..f034b2a6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-8-5-TAGBODY.DFASL 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 index bee2669d..63988a7f 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-BLOCK-CONSTRUCTS.DFASL 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 index 0bad97fd..3f4a3390 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-CATCH.DFASL 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 index 673f42d5..bc96c936 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-CONDITIONAL-CONSTRUCTS.DFASL 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 index 02adbd6f..e8d8a1df 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-EVALUATION-APPLICATION.DFASL 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 index 934b8db0..ad8ac6d6 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-IMPLICIT-PROGN-1.DFASL 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 index 6479481a..781c5dfe 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-2-MVR-MISC-SITUATIONS.DFASL 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 index f3178ae4..c562a3d7 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/7-9-MULTIPLE-VALUES.DFASL 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 index 2eb5cc9e..107071fb 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/8-1-PARSE-BODY.DFASL 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 index 18d23ece..496bdb2d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/9-3-THE.DFASL 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 index 9923628b..8413368d 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/ADDBASE-OP.DFASL 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 index 0d482f7b..e70417f1 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/CAR-CDRUFN.DFASL 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 index af473480..7511b641 100644 --- a/internal/test/LANGUAGE/from-sun/language/xcompiled/INIT.LISP +++ b/internal/test/LANGUAGE/from-sun/language/xcompiled/INIT.LISP @@ -1 +1,64 @@ -(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 +(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 diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/LONGFNCALL.DFASL b/internal/test/LANGUAGE/from-sun/language/xcompiled/LONGFNCALL.DFASL index f0b9c388..304e6afc 100644 Binary files a/internal/test/LANGUAGE/from-sun/language/xcompiled/LONGFNCALL.DFASL and b/internal/test/LANGUAGE/from-sun/language/xcompiled/LONGFNCALL.DFASL differ diff --git a/internal/test/LANGUAGE/from-sun/language/xcompiled/take-hard b/internal/test/LANGUAGE/from-sun/language/xcompiled/take-hard index 8ce1a31f..fd551932 100644 --- a/internal/test/LANGUAGE/from-sun/language/xcompiled/take-hard +++ b/internal/test/LANGUAGE/from-sun/language/xcompiled/take-hard @@ -1 +1,81 @@ -#.(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 +#.(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 diff --git a/internal/test/LANGUAGE/from-sun/sw/do-test b/internal/test/LANGUAGE/from-sun/sw/do-test index 9e6da885..e1626664 100644 --- a/internal/test/LANGUAGE/from-sun/sw/do-test +++ b/internal/test/LANGUAGE/from-sun/sw/do-test @@ -1 +1,360 @@ -(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 +(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 diff --git a/internal/test/LANGUAGE/from-sun/sw/do-test.dfasl b/internal/test/LANGUAGE/from-sun/sw/do-test.dfasl index e0e3e2b9..0303fe62 100644 Binary files a/internal/test/LANGUAGE/from-sun/sw/do-test.dfasl 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 index 870c2623..f90c1469 100644 Binary files a/internal/test/LANGUAGE/from-sun/sw/do-test.tedit 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 index a835fbce..ec534018 100644 Binary files a/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC 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~ index 83b42df1..4a023142 100644 Binary files a/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC.~1~ 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~ index a835fbce..ec534018 100644 Binary files a/internal/test/Library/4045xlpstream/Hand/4045XLPSTREAM.PROC.~2~ 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 index 83b42df1..4a023142 100644 Binary files a/internal/test/Library/4045xlpstream/Hand/4045xlpstream.u 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 index 1ec4b241..38f9677b 100644 Binary files a/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG 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~ index b65f9755..8d692a80 100644 Binary files a/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~1~ 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~ index b65f9755..8d692a80 100644 Binary files a/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~2~ 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~ index 1ec4b241..38f9677b 100644 Binary files a/internal/test/Library/4045xlpstream/Logs/4045XLPSTREAM.LOG.~3~ 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 index 867dbc8e..be5619c3 100644 Binary files a/internal/test/Library/4045xlpstream/Plans/4045XLPSTREAM.PLAN 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 index c5c792ec..df32acd8 100644 --- a/internal/test/Library/Auto/AR8230.TEST +++ b/internal/test/Library/Auto/AR8230.TEST @@ -1 +1,8 @@ -;; 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 +;; 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)) +) diff --git a/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TEST b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TEST index fb727988..9cbb295d 100644 --- a/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TEST +++ b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TEST @@ -1 +1,115 @@ -;;;; 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 +;;;; 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 + diff --git a/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS index 90392554..e690dff2 100644 --- a/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS +++ b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS @@ -1 +1,67 @@ -;;;; 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 +;;;; 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~ index 262e2cb0..cab66419 100644 --- a/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~1~ +++ b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~1~ @@ -1 +1,63 @@ -;;;; 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 +;;;; 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 diff --git a/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~2~ b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~2~ index 90392554..e690dff2 100644 --- a/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~2~ +++ b/internal/test/Library/CASH-FILE/HAND/CASH-FILE.TESTS.~2~ @@ -1 +1,67 @@ -;;;; 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 +;;;; 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 index 02e5b107..51064295 100644 Binary files a/internal/test/Library/GCHAX/Auto/GCHAX.TEST 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 index 50f8f4b3..e6fa467c 100644 --- a/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS +++ b/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS @@ -1 +1,169 @@ -;;;; 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 +;;;; 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") diff --git a/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~1~ b/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~1~ index a0884bec..672189f1 100644 --- a/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~1~ +++ b/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~1~ @@ -1 +1,159 @@ -;;;; 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 +;;;; 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")) + diff --git a/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~2~ b/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~2~ index 50f8f4b3..e6fa467c 100644 --- a/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~2~ +++ b/internal/test/Library/HASH-FILE/HAND/HASH-FILE.TESTS.~2~ @@ -1 +1,169 @@ -;;;; 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 +;;;; 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") diff --git a/internal/test/Library/MatMult/Auto/AR8230.TEST b/internal/test/Library/MatMult/Auto/AR8230.TEST index c5c792ec..df32acd8 100644 --- a/internal/test/Library/MatMult/Auto/AR8230.TEST +++ b/internal/test/Library/MatMult/Auto/AR8230.TEST @@ -1 +1,8 @@ -;; 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 +;; 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)) +) diff --git a/internal/test/Library/MatMult/Auto/DEGREES-TO-RADIANS.TEST b/internal/test/Library/MatMult/Auto/DEGREES-TO-RADIANS.TEST index e18fa93a..664bb82b 100644 --- a/internal/test/Library/MatMult/Auto/DEGREES-TO-RADIANS.TEST +++ b/internal/test/Library/MatMult/Auto/DEGREES-TO-RADIANS.TEST @@ -1 +1,20 @@ -;; 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 +;; 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 + + diff --git a/internal/test/Library/MatMult/Auto/IDENTITY-3-BY-3.TEST b/internal/test/Library/MatMult/Auto/IDENTITY-3-BY-3.TEST index cd08828d..bed15972 100644 --- a/internal/test/Library/MatMult/Auto/IDENTITY-3-BY-3.TEST +++ b/internal/test/Library/MatMult/Auto/IDENTITY-3-BY-3.TEST @@ -1 +1,33 @@ -;; 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 +;; 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 + + diff --git a/internal/test/Library/MatMult/Auto/IDENTITY-4-BY-4.TEST b/internal/test/Library/MatMult/Auto/IDENTITY-4-BY-4.TEST index 0fc9e2e6..a3f201d5 100644 --- a/internal/test/Library/MatMult/Auto/IDENTITY-4-BY-4.TEST +++ b/internal/test/Library/MatMult/Auto/IDENTITY-4-BY-4.TEST @@ -1 +1,33 @@ -;; 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 +;; 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 + + 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 index b456596f..f64d88ae 100644 --- a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-BY-3.TEST +++ b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-BY-3.TEST @@ -1 +1,36 @@ -;;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 +;;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 + + diff --git a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-VECTOR.TEST b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-VECTOR.TEST index 2b02e268..e2fdf40a 100644 --- a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-VECTOR.TEST +++ b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-3-VECTOR.TEST @@ -1 +1,42 @@ -;;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 +;;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 + + 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 index cbe66862..9f1e6f6c 100644 Binary files a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-4-BY-4.TEST 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 index 31c0100f..b8a4343f 100644 --- a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-4-VECTOR.TEST +++ b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-4-VECTOR.TEST @@ -1 +1,44 @@ -;;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 +;;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 + + 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 index 9d68d7b4..6d4d7b57 100644 --- a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-3.TEST +++ b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-3.TEST @@ -1 +1,31 @@ -;;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 +;;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 + + 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 index ddb2142f..f4b85a38 100644 --- a/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-4.TEST +++ b/internal/test/Library/MatMult/Auto/MAKE-HOMOGENEOUS-N-BY-4.TEST @@ -1 +1,33 @@ -;;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 +;;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 + + diff --git a/internal/test/Library/MatMult/Auto/PERSPECTIVE-4-BY-4.TEST b/internal/test/Library/MatMult/Auto/PERSPECTIVE-4-BY-4.TEST index 71501f1a..4fde27d7 100644 --- a/internal/test/Library/MatMult/Auto/PERSPECTIVE-4-BY-4.TEST +++ b/internal/test/Library/MatMult/Auto/PERSPECTIVE-4-BY-4.TEST @@ -1 +1,32 @@ -;; 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 +;; 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 + + diff --git a/internal/test/Library/MatMult/Auto/ROTATE-3-BY-3.TEST b/internal/test/Library/MatMult/Auto/ROTATE-3-BY-3.TEST index ebe3ead4..cfbac03f 100644 --- a/internal/test/Library/MatMult/Auto/ROTATE-3-BY-3.TEST +++ b/internal/test/Library/MatMult/Auto/ROTATE-3-BY-3.TEST @@ -1 +1,30 @@ -;; 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 +;; 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 + + 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 index a0cfe0df..3691edd8 100644 --- 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 @@ -1 +1,32 @@ -;; 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 +;; 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 + + 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 index 81c4c88a..f901eaca 100644 --- 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 @@ -1 +1,32 @@ -;; 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 +;; 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 + + 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 index c3fee637..0ce56aa9 100644 --- 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 @@ -1 +1,32 @@ -;; 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 +;; 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 + + diff --git a/internal/test/Library/MatMult/Auto/SCALE-3-BY-3.TEST b/internal/test/Library/MatMult/Auto/SCALE-3-BY-3.TEST index 843f23cf..d2e5be86 100644 --- a/internal/test/Library/MatMult/Auto/SCALE-3-BY-3.TEST +++ b/internal/test/Library/MatMult/Auto/SCALE-3-BY-3.TEST @@ -1 +1,32 @@ -;; 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 +;; 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 + + diff --git a/internal/test/Library/MatMult/Auto/SCALE-4-BY-4.TEST b/internal/test/Library/MatMult/Auto/SCALE-4-BY-4.TEST index 8b3fa726..650b9034 100644 --- a/internal/test/Library/MatMult/Auto/SCALE-4-BY-4.TEST +++ b/internal/test/Library/MatMult/Auto/SCALE-4-BY-4.TEST @@ -1 +1,39 @@ -;; 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 +;; 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 + + diff --git a/internal/test/Library/MatMult/Auto/TRANSLATE-3-BY-3.TEST b/internal/test/Library/MatMult/Auto/TRANSLATE-3-BY-3.TEST index c4a43802..841024e4 100644 --- a/internal/test/Library/MatMult/Auto/TRANSLATE-3-BY-3.TEST +++ b/internal/test/Library/MatMult/Auto/TRANSLATE-3-BY-3.TEST @@ -1 +1,32 @@ -;; 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 +;; 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 + + diff --git a/internal/test/Library/MatMult/Auto/TRANSLATE-4-BY-4.TEST b/internal/test/Library/MatMult/Auto/TRANSLATE-4-BY-4.TEST index 081e4ecf..59ed4904 100644 --- a/internal/test/Library/MatMult/Auto/TRANSLATE-4-BY-4.TEST +++ b/internal/test/Library/MatMult/Auto/TRANSLATE-4-BY-4.TEST @@ -1 +1,32 @@ -;; 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 +;; 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 + + diff --git a/internal/test/Library/TEdit/Hand-Aux/.read-me-first b/internal/test/Library/TEdit/Hand-Aux/.read-me-first index 398bc268..08f34d11 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/.read-me-first 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~ index 289059a6..e03a0e34 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~1~ 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~ index 65255cf5..ade30556 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~2~ 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~ index 398bc268..08f34d11 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/.read-me-first.~3~ 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 index 47a3bed4..58129fb9 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/AR10063.TEdit and b/internal/test/Library/TEdit/Hand-Aux/AR10063.TEdit differ diff --git a/internal/test/Library/TEdit/Hand-Aux/BIG-FOOTNOTE.TEDIT b/internal/test/Library/TEdit/Hand-Aux/BIG-FOOTNOTE.TEDIT index ddf44824..78e43d8a 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/BIG-FOOTNOTE.TEDIT 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 index f7a00dde..94c99d90 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/DANCER10-C0.DISPLAYFONT 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 index 4e3cda0a..03114167 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/DANCEROBJ.LCOM 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 index 9ae49c75..36ef5396 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/Dancer12-C0.DisplayFont 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 index c7c4027f..f6154d93 100644 --- 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 @@ -1,54 +1,7 @@ -Introduction - - AGAST is an attempt to produce a program that can write intelligent stories. With an eclectic combination of ideas from the work of both computer scientists and writers, we have produced the flexible core of what could be a very intelligent story teller. - Work being done in cognitive science, natural language processing, and other areas that are closely based on human actions fits neatly into the project. Story-telling is not one isolated behavior, but a combination of many; work from text generation, decision-making, story-planning, character development and other areas is needed. - AGAST uses a formula similar to those developed by various professional writers to teach beginning authors how to write stories*. This formula (described in detail in Part II) divides stories into five sections. AGAST attempts to model this formula by creating stories in the form of five inter-related sections. --------------------- -* i.e. to capture what is essential in a story as opposed to a random collection of sentences, or some other form of prosaic writing such as a newspaper article or master's thesis - AGAST is flexible because it "writes" stories in two stages. The first stage creates a story tree, where every action that happens is stored. As the tree in generated, the internal representation of the physical world (including locations, objects, and characters) is affected, which in turn affects the progress of the story. - A straight-forward depth-first traversal of the story tree produces a "chronological" account of the story. The second part, the text generator, walks the tree this way and thus tells the story. This part is extremely simple now; it just writes a sentence for each and every action, telling the story in excruciating detail. But since the story structure is unaffected by the telling, a different text generator could easily be used before, after, or instead of the one used now. Sequences of events could be summarized to different levels as needed, events could be told in varying orders, or two stories could be meshed together. - The fact that the story exists as a tree after its generation means also that actions can be undone and the story can take a new direction in the retelling. AGAST uses this feature to handle stories that end in story-telling failure. Like a human writer, AGAST can "change its mind" and rewrite the story to end successfully. This also means that AGAST doesn't need to plan every detail of the plot ahead of time. It can randomly generate complications for the plot, handle them using using any sort of decision making process, and know that if it paints itself into a corner, it can either undo the actions that got it into trouble, or change the situation so that the characters can successfully handle the problem. - Related Work - -A. James Meehan's "TALE-SPIN" - "Tale-Spin" [Meehan 76] seems to be the grandparent of computer story writing--at least, everyone who does work in the field must refer to James Meehan's ground-breaking work. - Like Tale-Spin, AGAST has a physical world, with objects and locations. Both have actions, although AGAST's actions are arranged in a writerly (GIVE, PICK-UP) rather than a formal (PTRANS, MTRANS) fashion. - Tale-Spin's stories are generated by goal stacks--the original goal puts other goals on the stack, the achievement of all of which completes the original goal. AGAST's stories have this feature as well. However, like AGAST actions, AGAST goals are arranged in a writerly fashion, each broken down into story parts. In addition there is the possibility of having multiple goals, all being solved simultaniously. - One example of this is when a character is looking for two different objects. First one object is sought, and when it is found, the other is sought. However, if the second object is run across in the search for the first, it is picked up and the search for it is never initiated. Although it isn't yet implemented in AGAST, characters can have other character's goals as subgoals, thus helping friends achieve their major goals. - Also, in storing actions and their side-effects as they occur, AGAST allows story revision and backpatching, which aren't conceivable in Tale-Spin. - Tale-Spin does have some level of social interaction, which AGAST is at present totally missing. - -B. Natalie Dehn's thesis - - Natalie Dehn [Dehn 81] makes the point that in writing a story, authors have a goal: to write an interesting story. Her project concentrates on author intentionality. AGAST attempts to emulate this goal with the plot formula that drives the story, and with backpatching that "saves" the story when it plots its way into a dead end. - However, there is also the point that characters must have goals. If they start without a specific goal, they are quickly given one, from simply staying alive to saving the universe. Dehn points this out (but not in terms of character goals) when she mentions justifying the situation a character finds him or herself in. A story goes wherever the author intends, but it won't be a very good story if the characters seem to be acting only on the author's whim. They should be following their own goals; their actions should make sense to them, not just to "The Story," of which characters generally aren't aware, anyway. AGAST attempts to combine the internal logic of goal-driven behavior of Tale-Spin with the author-intention-driven stories that Dehn promotes. -C. Michael Dyer's "BORIS" - Michael Dyer's work [Dyer 81] is more on story understanding than on story generation. Dyer's BORIS attempts to understand stories not only by general semantic, grammatical and lexical knowledge but by discerning the context that the story creates. AGAST creates and stores its context, but so far makes only a limited use of it. One example in which AGAST uses the context of an event is when an accident occurs (a character is injured--they trip, or some such accident). If the character is just travelling or exploring, they can cure themselves (but only if they're carrying a medikit). However, if they are fighting or escaping, they can't take the time to do anything about the injury. - While it would surely be interesting to have BORIS read in AGAST stories and answer questions about them, it would be more interesting to have a BORIS-like program enhance the context that AGAST builds. A memory of past events would allow characters to "learn" and would make social interaction easier to simulate. For instance, suppose Frank killed Libby's cat. When Libby next meets Frank, the past event might make her want to get revenge on Frank, and thus would influence what she did during the meeting. As in Tale-Spin, she would know Frank was not to be trusted--but she would conclude it rather than knowing it from the start. From the examples in Dyer's paper, it would seem possible to use such a system to determine characters' attitudes toward other characters and their current emotional states. - -D. Eduard H. Hovy's "PAULINE" - The actual text of AGAST stories is generated very simply--every object in a story tree knows how to print a description of the action it represents. This produces very lengthy, boring text (see sample stories). - Eduard H. Hovy [Hovy 87] discusses a much better text generation model. His program, PAULINE, groups related actions together and summarizes them, specifically mentioning only the "high points" of the event. PAULINE interprets the actions, draws conclusions, and adds them to its knowledge of the event. PAULINE can also "shade" what it tells, adding evocative words that can slant the meaning of the text, although the event is still accurately portrayed. - These abilities would greatly enhance the "story-ness" of AGAST's stories. Instead of: -Libby swung her sword at the giant centipede, injuring its leg. -The giant centipede bit Libby, injuring her arm. -...and so on, each exchanging many blows and ending with: -Libby swung her sword at the giant centipede, injuring its head. Its head was severed and dropped to the floor. The giant centipede was killed. -A program such as PAULINE might be able to produce more writerly text: -Libby drew her sword as the giant centipede attacked. She slashed at the slavering creature as it bit at her. Howling with rage, the giant centipede sank its mandibles into Libby's left arm. Libby raised her sword and with a cry of desperation cut off the centipede's head. - Since AGAST`s actions are already grouped and catalogued (a series of "injure" actions that constitute a "fight" are stored in a slot of a "fight" event), summarizing events and choosing weighted words that fit the situation (desperate, rage) and the characters in it ("slavering", since giant centipedes are defined as non-intelligent animals) should be relatively easy to do. - -E. Michael Lebowitz's "UNIVERSE" - Michael Lebowitz's UNIVERSE program generates plots for soap-opera-like stories. This is different from most other work in the field in that stories in UNIVERSE are deliberately constructed not to end, but to have continuing characters moving from mishap to mishap. Below we examine two versions of UNIVERSE which have appeared in the literature. -[Lebowitz 83] - While AGAST is action-heavy, Lebowitz is primarily concerned with character consistency and development. Past events affect the personality (and thus actions taken) of characters. Like UNIVERSE, AGAST creates important characters--the protagonist, the antagonist, anyone directly involved in the main goal--before the story starts. Unimportant characters--attacking monsters, for instance--are created on the fly. - AGAST reaches for this ideal with the Background section of the story providing the motivation for the story. However, UNIVERSE goes much further, with each character carrying around a changing history. Like Dyer's BORIS, a UNIVERSE-like program could significantly help the character development of AGAST's stories. - UNIVERSE also keeps track of character relationships in a more consistent way than AGAST. AGAST's characters can be related to one another (e.g. Libby is Frank's mother, and Frank is Libby's son), but if Frank is Stella's brother, all Libby knows is that she is somehow related to Stella. Relationships that change with time, such as marriage, exist, but are assumed permanent, with no history of past divorces or whatever. -[Lebowitz 87] - Using goal precedence and mutual-achievement critieria for goal selection, UNIVERSE nicely manages the interweaving of plots that is important for a complex, interesting story. AGAST currently has only one form of subplot implemented, the substory. Here the main goal is temporarily suspended while a subgoal (with a "subprotagonist") is "written" in a "meanwhile, back at the ranch..." type of story. The conclusion of the subgoal, usually with the subprotagonist and the protagonist joined as companions, then allows the completion of the major goal. The nesting of substories, however, can produce quite complex stories (Libby rescues Fred; they both rescue John; all three join with Natasha to continue the search for the Lost Ark of the Covenant...). - The "churning" of plots that UNIVERSE uses as one of its author goals is somewhat emulated by the introduction of obstacles and problems into the path of the protagonist. Plans have particular problems associated with them, and goals (which determine the type of story, such as the "quest") can also have special problems associated with them, especially at the climax of the story (which is a concept UNIVERSE doesn't have, since it writes "slice of life" narratives). - -F. Schank and Abelson's scripts - Schank and Abelson [Schank and Abelson 77] discuss many of the methods used in story writing programs. One important idea is that of scripts--an outline of how to behave in particular situations. They allow both understanding and generation of simple stories involving frequently done events, such as eating in restaurants or taking the bus. - Actions in the AGAST story tree are grouped and stored in PLAN objects. Many plans are similar to scripts in that they generate a restricted series of actions that constitute a type of event. For instance, if the event is a FIGHT between two parties: first, a character (randomly chosen from the first party) injures one (randomly chosen from the second party), then a return injury is done. These actions are repeated until one of the parties has no one left who can continue fighting. -(LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "- " " -") STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "- " " -")) (162 36 288 36) NIL) (TEXT NIL NIL (108 72 432 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "- " " -")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "- " " -")) (162 36 288 36) NIL) (TEXT NIL NIL (108 72 432 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "- " " -")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "- " " -")) (162 36 288 36) NIL) (TEXT NIL NIL (108 72 432 648) NIL))))) ,, - T, - T8 (FOOTNOTE T), , ,MODERN MODERN MODERNMODERN MODERNMODERN MODERN  TIMESROMAN   O=´J}Ó ąĐŸą•bOš0ÖĚY@1:‘G{!^˘@ŞůŘ Yë0ňrzş \ No newline at end of file +Introduction AGAST is an attempt to produce a program that can write intelligent stories. With an eclectic combination of ideas from the work of both computer scientists and writers, we have produced the flexible core of what could be a very intelligent story teller. Work being done in cognitive science, natural language processing, and other areas that are closely based on human actions fits neatly into the project. Story-telling is not one isolated behavior, but a combination of many; work from text generation, decision-making, story-planning, character development and other areas is needed. AGAST uses a formula similar to those developed by various professional writers to teach beginning authors how to write stories*. This formula (described in detail in Part II) divides stories into five sections. AGAST attempts to model this formula by creating stories in the form of five inter-related sections. -------------------- * i.e. to capture what is essential in a story as opposed to a random collection of sentences, or some other form of prosaic writing such as a newspaper article or master's thesis AGAST is flexible because it "writes" stories in two stages. The first stage creates a story tree, where every action that happens is stored. As the tree in generated, the internal representation of the physical world (including locations, objects, and characters) is affected, which in turn affects the progress of the story. A straight-forward depth-first traversal of the story tree produces a "chronological" account of the story. The second part, the text generator, walks the tree this way and thus tells the story. This part is extremely simple now; it just writes a sentence for each and every action, telling the story in excruciating detail. But since the story structure is unaffected by the telling, a different text generator could easily be used before, after, or instead of the one used now. Sequences of events could be summarized to different levels as needed, events could be told in varying orders, or two stories could be meshed together. The fact that the story exists as a tree after its generation means also that actions can be undone and the story can take a new direction in the retelling. AGAST uses this feature to handle stories that end in story-telling failure. Like a human writer, AGAST can "change its mind" and rewrite the story to end successfully. This also means that AGAST doesn't need to plan every detail of the plot ahead of time. It can randomly generate complications for the plot, handle them using using any sort of decision making process, and know that if it paints itself into a corner, it can either undo the actions that got it into trouble, or change the situation so that the characters can successfully handle the problem. Related Work A. James Meehan's "TALE-SPIN" "Tale-Spin" [Meehan 76] seems to be the grandparent of computer story writing--at least, everyone who does work in the field must refer to James Meehan's ground-breaking work. Like Tale-Spin, AGAST has a physical world, with objects and locations. Both have actions, although AGAST's actions are arranged in a writerly (GIVE, PICK-UP) rather than a formal (PTRANS, MTRANS) fashion. Tale-Spin's stories are generated by goal stacks--the original goal puts other goals on the stack, the achievement of all of which completes the original goal. AGAST's stories have this feature as well. However, like AGAST actions, AGAST goals are arranged in a writerly fashion, each broken down into story parts. In addition there is the possibility of having multiple goals, all being solved simultaniously. One example of this is when a character is looking for two different objects. First one object is sought, and when it is found, the other is sought. However, if the second object is run across in the search for the first, it is picked up and the search for it is never initiated. Although it isn't yet implemented in AGAST, characters can have other character's goals as subgoals, thus helping friends achieve their major goals. Also, in storing actions and their side-effects as they occur, AGAST allows story revision and backpatching, which aren't conceivable in Tale-Spin. Tale-Spin does have some level of social interaction, which AGAST is at present totally missing. B. Natalie Dehn's thesis Natalie Dehn [Dehn 81] makes the point that in writing a story, authors have a goal: to write an interesting story. Her project concentrates on author intentionality. AGAST attempts to emulate this goal with the plot formula that drives the story, and with backpatching that "saves" the story when it plots its way into a dead end. However, there is also the point that characters must have goals. If they start without a specific goal, they are quickly given one, from simply staying alive to saving the universe. Dehn points this out (but not in terms of character goals) when she mentions justifying the situation a character finds him or herself in. A story goes wherever the author intends, but it won't be a very good story if the characters seem to be acting only on the author's whim. They should be following their own goals; their actions should make sense to them, not just to "The Story," of which characters generally aren't aware, anyway. AGAST attempts to combine the internal logic of goal-driven behavior of Tale-Spin with the author-intention-driven stories that Dehn promotes. C. Michael Dyer's "BORIS" Michael Dyer's work [Dyer 81] is more on story understanding than on story generation. Dyer's BORIS attempts to understand stories not only by general semantic, grammatical and lexical knowledge but by discerning the context that the story creates. AGAST creates and stores its context, but so far makes only a limited use of it. One example in which AGAST uses the context of an event is when an accident occurs (a character is injured--they trip, or some such accident). If the character is just travelling or exploring, they can cure themselves (but only if they're carrying a medikit). However, if they are fighting or escaping, they can't take the time to do anything about the injury. While it would surely be interesting to have BORIS read in AGAST stories and answer questions about them, it would be more interesting to have a BORIS-like program enhance the context that AGAST builds. A memory of past events would allow characters to "learn" and would make social interaction easier to simulate. For instance, suppose Frank killed Libby's cat. When Libby next meets Frank, the past event might make her want to get revenge on Frank, and thus would influence what she did during the meeting. As in Tale-Spin, she would know Frank was not to be trusted--but she would conclude it rather than knowing it from the start. From the examples in Dyer's paper, it would seem possible to use such a system to determine characters' attitudes toward other characters and their current emotional states. D. Eduard H. Hovy's "PAULINE" The actual text of AGAST stories is generated very simply--every object in a story tree knows how to print a description of the action it represents. This produces very lengthy, boring text (see sample stories). Eduard H. Hovy [Hovy 87] discusses a much better text generation model. His program, PAULINE, groups related actions together and summarizes them, specifically mentioning only the "high points" of the event. PAULINE interprets the actions, draws conclusions, and adds them to its knowledge of the event. PAULINE can also "shade" what it tells, adding evocative words that can slant the meaning of the text, although the event is still accurately portrayed. These abilities would greatly enhance the "story-ness" of AGAST's stories. Instead of: Libby swung her sword at the giant centipede, injuring its leg. The giant centipede bit Libby, injuring her arm. ...and so on, each exchanging many blows and ending with: Libby swung her sword at the giant centipede, injuring its head. Its head was severed and dropped to the floor. The giant centipede was killed. A program such as PAULINE might be able to produce more writerly text: Libby drew her sword as the giant centipede attacked. She slashed at the slavering creature as it bit at her. Howling with rage, the giant centipede sank its mandibles into Libby's left arm. Libby raised her sword and with a cry of desperation cut off the centipede's head. Since AGAST`s actions are already grouped and catalogued (a series of "injure" actions that constitute a "fight" are stored in a slot of a "fight" event), summarizing events and choosing weighted words that fit the situation (desperate, rage) and the characters in it ("slavering", since giant centipedes are defined as non-intelligent animals) should be relatively easy to do. E. Michael Lebowitz's "UNIVERSE" Michael Lebowitz's UNIVERSE program generates plots for soap-opera-like stories. This is different from most other work in the field in that stories in UNIVERSE are deliberately constructed not to end, but to have continuing characters moving from mishap to mishap. Below we examine two versions of UNIVERSE which have appeared in the literature. [Lebowitz 83] While AGAST is action-heavy, Lebowitz is primarily concerned with character consistency and development. Past events affect the personality (and thus actions taken) of characters. Like UNIVERSE, AGAST creates important characters--the protagonist, the antagonist, anyone directly involved in the main goal--before the story starts. Unimportant characters--attacking monsters, for instance--are created on the fly. AGAST reaches for this ideal with the Background section of the story providing the motivation for the story. However, UNIVERSE goes much further, with each character carrying around a changing history. Like Dyer's BORIS, a UNIVERSE-like program could significantly help the character development of AGAST's stories. UNIVERSE also keeps track of character relationships in a more consistent way than AGAST. AGAST's characters can be related to one another (e.g. Libby is Frank's mother, and Frank is Libby's son), but if Frank is Stella's brother, all Libby knows is that she is somehow related to Stella. Relationships that change with time, such as marriage, exist, but are assumed permanent, with no history of past divorces or whatever. [Lebowitz 87] Using goal precedence and mutual-achievement critieria for goal selection, UNIVERSE nicely manages the interweaving of plots that is important for a complex, interesting story. AGAST currently has only one form of subplot implemented, the substory. Here the main goal is temporarily suspended while a subgoal (with a "subprotagonist") is "written" in a "meanwhile, back at the ranch..." type of story. The conclusion of the subgoal, usually with the subprotagonist and the protagonist joined as companions, then allows the completion of the major goal. The nesting of substories, however, can produce quite complex stories (Libby rescues Fred; they both rescue John; all three join with Natasha to continue the search for the Lost Ark of the Covenant...). The "churning" of plots that UNIVERSE uses as one of its author goals is somewhat emulated by the introduction of obstacles and problems into the path of the protagonist. Plans have particular problems associated with them, and goals (which determine the type of story, such as the "quest") can also have special problems associated with them, especially at the climax of the story (which is a concept UNIVERSE doesn't have, since it writes "slice of life" narratives). F. Schank and Abelson's scripts Schank and Abelson [Schank and Abelson 77] discuss many of the methods used in story writing programs. One important idea is that of scripts--an outline of how to behave in particular situations. They allow both understanding and generation of simple stories involving frequently done events, such as eating in restaurants or taking the bus. Actions in the AGAST story tree are grouped and stored in PLAN objects. Many plans are similar to scripts in that they generate a restricted series of actions that constitute a type of event. For instance, if the event is a FIGHT between two parties: first, a character (randomly chosen from the first party) injures one (randomly chosen from the second party), then a return injury is done. These actions are repeated until one of the parties has no one left who can continue fighting. (LIST ((PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "- " " -") STARTINGPAGE# 1) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "- " " -")) (162 36 288 36) NIL) (TEXT NIL NIL (108 72 432 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "- " " -")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "- " " -")) (162 36 288 36) NIL) (TEXT NIL NIL (108 72 432 648) NIL))) (PAGE NIL (PAPERSIZE Letter FOLIOINFO (ARABIC "- " " -")) (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 INVISIBLE OFF SELECTPOINT OFF PROTECTED OFF SIZE 10 FAMILY MODERN OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF EXPANSION REGULAR SLOPE REGULAR WEIGHT MEDIUM INVERTED OFF USERINFO NIL STYLE NIL) FORMATINFO (ARABIC "- " " -")) (162 36 288 36) NIL) (TEXT NIL NIL (108 72 432 648) NIL))))) ,, - T, - T8 (FOOTNOTE T), +, +,MODERN +MODERN MODERNMODERN +MODERNMODERN +MODERN  +TIMESROMAN   O=´J}Ó ąĐŸą•bOš0ÖĚY@1:‘G{!^˘@ŞůŘ Yë0ňrzş \ No newline at end of file diff --git a/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL b/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL index af591aa1..4154fbfb 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL 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 index d5d5882d..f5bd7e2f 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG.MAIL-LAFITE-TOC 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 index a82d42d9..a872f1fd 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/KANJI-DEBUG2.MAIL 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 index d4842ac2..2b58fd16 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/MASINTER-CAROL-NEWSLETTER 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 index fe062edc..a5fd5ba2 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/UNDERLINE-TEST.TEDIT 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 index 515df291..b5947519 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/abbrev-sample.tedit and b/internal/test/Library/TEdit/Hand-Aux/abbrev-sample.tedit 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 index daec3547..4c98b18d 100644 Binary files a/internal/test/Library/TEdit/Hand-Aux/new-page-after.tedit 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 index 402a8f66..c69d809c 100644 --- a/internal/test/Library/WHERE-IS/HAND/WHERE-IS.TESTS +++ b/internal/test/Library/WHERE-IS/HAND/WHERE-IS.TESTS @@ -1 +1,42 @@ -;;;; 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 +;;;; 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)) diff --git a/internal/test/Library/rs232/hand/TESTRECEIVE b/internal/test/Library/rs232/hand/TESTRECEIVE index c6a28f1a..d46693a6 100644 --- a/internal/test/Library/rs232/hand/TESTRECEIVE +++ b/internal/test/Library/rs232/hand/TESTRECEIVE @@ -1 +1,58 @@ -(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 +(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 diff --git a/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl b/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl index 2186b05a..69629a61 100644 Binary files a/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl 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~ index cfffe10c..10430f91 100644 Binary files a/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl.~1~ 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~ index 2186b05a..69629a61 100644 Binary files a/internal/test/Library/rs232/hand/TESTRECEIVE.dfasl.~2~ 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~ index 92746bf9..07c41101 100644 --- a/internal/test/Library/rs232/hand/TESTRECEIVE.~1~ +++ b/internal/test/Library/rs232/hand/TESTRECEIVE.~1~ @@ -1 +1,61 @@ -(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 +(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 diff --git a/internal/test/Library/rs232/hand/TESTRECEIVE.~2~ b/internal/test/Library/rs232/hand/TESTRECEIVE.~2~ index c6a28f1a..d46693a6 100644 --- a/internal/test/Library/rs232/hand/TESTRECEIVE.~2~ +++ b/internal/test/Library/rs232/hand/TESTRECEIVE.~2~ @@ -1 +1,58 @@ -(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 +(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 diff --git a/internal/test/Library/rs232/hand/TESTSEND b/internal/test/Library/rs232/hand/TESTSEND index a8d1f59a..f9df27d0 100644 --- a/internal/test/Library/rs232/hand/TESTSEND +++ b/internal/test/Library/rs232/hand/TESTSEND @@ -1 +1,29 @@ -(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 +(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 diff --git a/internal/test/Library/rs232/hand/TESTSEND.dfasl b/internal/test/Library/rs232/hand/TESTSEND.dfasl index 0be391a9..27be9e2e 100644 Binary files a/internal/test/Library/rs232/hand/TESTSEND.dfasl 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~ index 16d58d77..f28b259e 100644 Binary files a/internal/test/Library/rs232/hand/TESTSEND.dfasl.~1~ 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~ index 0be391a9..27be9e2e 100644 Binary files a/internal/test/Library/rs232/hand/TESTSEND.dfasl.~2~ 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~ index cdc675f1..37d14ee9 100644 --- a/internal/test/Library/rs232/hand/TESTSEND.~1~ +++ b/internal/test/Library/rs232/hand/TESTSEND.~1~ @@ -1 +1,33 @@ -(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 +(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 diff --git a/internal/test/Library/rs232/hand/TESTSEND.~2~ b/internal/test/Library/rs232/hand/TESTSEND.~2~ index a8d1f59a..f9df27d0 100644 --- a/internal/test/Library/rs232/hand/TESTSEND.~2~ +++ b/internal/test/Library/rs232/hand/TESTSEND.~2~ @@ -1 +1,29 @@ -(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 +(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 diff --git a/internal/test/Maiko/ARs/AR-TEST-CASE.Auto-log b/internal/test/Maiko/ARs/AR-TEST-CASE.Auto-log index c202b6da..584cbb17 100644 --- a/internal/test/Maiko/ARs/AR-TEST-CASE.Auto-log +++ b/internal/test/Maiko/ARs/AR-TEST-CASE.Auto-log @@ -1 +1,73 @@ -(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 +(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") diff --git a/internal/test/Maiko/ARs/ENDLESS-PUSHES b/internal/test/Maiko/ARs/ENDLESS-PUSHES index 057a4424..717c48a9 100644 --- a/internal/test/Maiko/ARs/ENDLESS-PUSHES +++ b/internal/test/Maiko/ARs/ENDLESS-PUSHES @@ -1 +1,20 @@ -(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 +(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 diff --git a/internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL b/internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL index 09f581cd..bc280a96 100644 Binary files a/internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL and b/internal/test/Maiko/ARs/ENDLESS-PUSHES.DFASL differ diff --git a/internal/test/Maiko/ARs/optests.dfasl b/internal/test/Maiko/ARs/optests.dfasl index c35f1ca1..c760ba43 100644 Binary files a/internal/test/Maiko/ARs/optests.dfasl and b/internal/test/Maiko/ARs/optests.dfasl differ diff --git a/internal/test/Maiko/ARs/optests.dfasl.~1~ b/internal/test/Maiko/ARs/optests.dfasl.~1~ new file mode 100644 index 00000000..5aede485 Binary files /dev/null and b/internal/test/Maiko/ARs/optests.dfasl.~1~ differ diff --git a/internal/test/Maiko/ARs/optests.dfasl.~2~ b/internal/test/Maiko/ARs/optests.dfasl.~2~ new file mode 100644 index 00000000..c760ba43 Binary files /dev/null and b/internal/test/Maiko/ARs/optests.dfasl.~2~ differ diff --git a/internal/test/Maiko/ARs/optests.lisp b/internal/test/Maiko/ARs/optests.lisp index 76b1c18f..5242c85b 100644 --- a/internal/test/Maiko/ARs/optests.lisp +++ b/internal/test/Maiko/ARs/optests.lisp @@ -1 +1,26 @@ -;;; 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 +;;; 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))) + diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL b/internal/test/Maiko/AUTO/OPCODES.DFASL index 07c9f625..468a3799 100644 Binary files a/internal/test/Maiko/AUTO/OPCODES.DFASL and b/internal/test/Maiko/AUTO/OPCODES.DFASL differ diff --git a/internal/test/Maiko/AUTO/OPCODES.DFASL.~1~ b/internal/test/Maiko/AUTO/OPCODES.DFASL.~1~ index ff19eef8..efac5f45 100644 Binary files a/internal/test/Maiko/AUTO/OPCODES.DFASL.~1~ 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~ index 0db47210..308f11c6 100644 Binary files a/internal/test/Maiko/AUTO/OPCODES.DFASL.~2~ 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~ index d5ad86e5..63c8df5d 100644 Binary files a/internal/test/Maiko/AUTO/OPCODES.DFASL.~3~ 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~ index 60aa16b2..70f15e07 100644 Binary files a/internal/test/Maiko/AUTO/OPCODES.DFASL.~4~ 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~ index 125b8386..28d53575 100644 Binary files a/internal/test/Maiko/AUTO/OPCODES.DFASL.~5~ 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~ index 07c9f625..468a3799 100644 Binary files a/internal/test/Maiko/AUTO/OPCODES.DFASL.~6~ 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 index 1913c86b..e4195bd2 100644 --- a/internal/test/Maiko/AUTO/OPCODES.TEST +++ b/internal/test/Maiko/AUTO/OPCODES.TEST @@ -1 +1,1834 @@ -(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 +(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 diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~1~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~1~ index 2c0b47d0..d12fd4dd 100644 --- a/internal/test/Maiko/AUTO/OPCODES.TEST.~1~ +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~1~ @@ -1 +1,705 @@ -(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 +(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 diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~2~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~2~ index 272d4d6f..d4973141 100644 --- a/internal/test/Maiko/AUTO/OPCODES.TEST.~2~ +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~2~ @@ -1 +1,712 @@ -(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 +(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 diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~3~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~3~ index ebf2fd09..ab9bc97b 100644 --- a/internal/test/Maiko/AUTO/OPCODES.TEST.~3~ +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~3~ @@ -1 +1,792 @@ -(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 +(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 diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~4~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~4~ index fbb78460..9e21a385 100644 --- a/internal/test/Maiko/AUTO/OPCODES.TEST.~4~ +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~4~ @@ -1 +1,803 @@ -(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 +(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 diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~5~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~5~ index 2dd3e331..586072c7 100644 --- a/internal/test/Maiko/AUTO/OPCODES.TEST.~5~ +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~5~ @@ -1 +1,823 @@ -(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 +(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 diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~6~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~6~ index f3084829..608b0988 100644 --- a/internal/test/Maiko/AUTO/OPCODES.TEST.~6~ +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~6~ @@ -1 +1,823 @@ -(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 +(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 diff --git a/internal/test/Maiko/AUTO/OPCODES.TEST.~7~ b/internal/test/Maiko/AUTO/OPCODES.TEST.~7~ index 1913c86b..e4195bd2 100644 --- a/internal/test/Maiko/AUTO/OPCODES.TEST.~7~ +++ b/internal/test/Maiko/AUTO/OPCODES.TEST.~7~ @@ -1 +1,1834 @@ -(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 +(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 diff --git a/internal/test/Maiko/Aux/BBTESTS b/internal/test/Maiko/Aux/BBTESTS index cb5e0f21..07609333 100644 --- a/internal/test/Maiko/Aux/BBTESTS +++ b/internal/test/Maiko/Aux/BBTESTS @@ -1 +1,235 @@ -(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 +(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 diff --git a/internal/test/Maiko/Aux/BBTESTS.DFASL b/internal/test/Maiko/Aux/BBTESTS.DFASL index 36a75527..45d6b60b 100644 Binary files a/internal/test/Maiko/Aux/BBTESTS.DFASL 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 index c35f1ca1..5aede485 100644 Binary files a/internal/test/Maiko/Aux/OPTESTS.DFASL 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 index 76b1c18f..5242c85b 100644 --- a/internal/test/Maiko/Aux/optests.lisp +++ b/internal/test/Maiko/Aux/optests.lisp @@ -1 +1,26 @@ -;;; 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 +;;; 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))) + diff --git a/internal/test/Maiko/Aux/optests.lisp.~1~ b/internal/test/Maiko/Aux/optests.lisp.~1~ index 76b1c18f..5242c85b 100644 --- a/internal/test/Maiko/Aux/optests.lisp.~1~ +++ b/internal/test/Maiko/Aux/optests.lisp.~1~ @@ -1 +1,26 @@ -;;; 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 +;;; 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))) + diff --git a/internal/test/Maiko/Aux/optests.lisp.~2~ b/internal/test/Maiko/Aux/optests.lisp.~2~ index 76b1c18f..5242c85b 100644 --- a/internal/test/Maiko/Aux/optests.lisp.~2~ +++ b/internal/test/Maiko/Aux/optests.lisp.~2~ @@ -1 +1,26 @@ -;;; 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 +;;; 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))) + diff --git a/internal/test/Maiko/BAD-XREF b/internal/test/Maiko/BAD-XREF index fb3b294f..aebc4764 100644 --- a/internal/test/Maiko/BAD-XREF +++ b/internal/test/Maiko/BAD-XREF @@ -1 +1,58 @@ -(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 +(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 diff --git a/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS index d1fb8840..76480885 100644 --- a/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS +++ b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS @@ -1 +1,514 @@ -(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 +(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 diff --git a/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.DFASL b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.DFASL index e097e6ea..4b084338 100644 Binary files a/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.DFASL 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~ index ab44cedd..f4126326 100644 --- a/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~1~ +++ b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~1~ @@ -1 +1,519 @@ -(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 +(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 diff --git a/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~2~ b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~2~ index d1fb8840..76480885 100644 --- a/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~2~ +++ b/internal/test/Maiko/HAND/MAIKO-ARRAY-TESTS.~2~ @@ -1 +1,514 @@ -(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 +(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 diff --git a/internal/test/Maiko/OBSOLETE/AREF-TESTER b/internal/test/Maiko/OBSOLETE/AREF-TESTER index 4dc187de..84b3c7b0 100644 --- a/internal/test/Maiko/OBSOLETE/AREF-TESTER +++ b/internal/test/Maiko/OBSOLETE/AREF-TESTER @@ -1 +1,47 @@ -(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 +(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 diff --git a/internal/test/Maiko/OBSOLETE/AREF-TESTER.DFASL b/internal/test/Maiko/OBSOLETE/AREF-TESTER.DFASL index d705603d..f1403542 100644 Binary files a/internal/test/Maiko/OBSOLETE/AREF-TESTER.DFASL 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 index 9d8c281d..09c5c087 100644 --- a/internal/test/Maiko/OBSOLETE/ARRAY-TESTER +++ b/internal/test/Maiko/OBSOLETE/ARRAY-TESTER @@ -1 +1,65 @@ -(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 +(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 diff --git a/internal/test/Maiko/OBSOLETE/ARRAY-TESTER.DFASL b/internal/test/Maiko/OBSOLETE/ARRAY-TESTER.DFASL index a176ab17..09b744c0 100644 Binary files a/internal/test/Maiko/OBSOLETE/ARRAY-TESTER.DFASL 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 index f16a4e28..0810e33e 100644 --- a/internal/test/Maiko/OBSOLETE/ARRAY-TESTER.TEST +++ b/internal/test/Maiko/OBSOLETE/ARRAY-TESTER.TEST @@ -1 +1,335 @@ -;;; File converted on 14-Jun-88 15:01:09 from source array-tester ;;; Original source {qv}lisp>array-tester.;1 created 14-Jun-88 14:57:44 ;;; Copyright (c) 1988 by Xerox Corporation ;; array-read and array-write (do-test "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" (equal '(1 0 1 0) (flet ((array-read-bit (base index) ((il:opcodes il:misc3 9) base 0 index))) (let ((base (il:%make-array-storage 8 0))) (il:\\putbasebyte base 0 160) (with-collection (dotimes (i 4) (collect (array-read-bit base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" (equal '(0 23 255 4) (flet ((array-read-byte (base index) ((il:opcodes il:misc3 9) base 3 index))) (let ((base (il:%make-array-storage 4 3))) (do ((i 0 (1+ i)) (x '(0 23 255 4) (cdr x))) ((eq i 4)) (il:\\putbasebyte base i (car x))) (with-collection (dotimes (i 4) (collect (array-read-byte base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" (equal '(0 23 255 65535) (flet ((array-read-word (base index) ((il:opcodes il:misc3 9) base 4 index))) (let ((base (il:%make-array-storage 4 4))) (do ((i 0 (1+ i)) (x '(0 23 255 65535) (cdr x))) ((eq i 4)) (il:\\putbase base i (car x))) (with-collection (dotimes (i 4) (collect (array-read-word base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" (equal '(0 -23 255 -32768) (flet ((array-read-signed-word (base index) ((il:opcodes il:misc3 9) base 20 index))) (let ((base (il:%make-array-storage 4 20))) (do ((i 0 (1+ i)) (x '(0 -23 255 -32768) (cdr x))) ((eq i 4)) (il:\\putbase base i (il:\\loloc (car x)))) (with-collection (dotimes (i 4) (collect (array-read-signed-word base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" (equal '(0 -23 65536 -2147483648) (flet ((array-read-fixp (base index) ((il:opcodes il:misc3 9) base 22 index))) (let ((base (il:%make-array-storage 4 22))) (do ((i 0 (1+ i)) (x '(0 -23 65536 -2147483648) (cdr x))) ((eq i 4)) (il:\\putbasefixp base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-fixp base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type single-float" (equal '(0.0 -23.0 3.4456E+24 -4.562435E-12) (flet ((array-read-floatp (base index) ((il:opcodes il:misc3 9) base 54 index))) (let ((base (il:%make-array-storage 4 54))) (do ((i 0 (1+ i)) (x '(0.0 -23.0 3.4456E+24 -4.562435E-12) (cdr x))) ((eq i 4)) (il:\\putbasefloatp base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-floatp base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type string-char" (equal '(#\a #\b #\c #\A) (flet ((array-read-thin-char (base index) ((il:opcodes il:misc3 9) base 67 index))) (let ((base (il:%make-array-storage 4 67))) (do ((i 0 (1+ i)) (x '(#\a #\b #\c #\A) (cdr x))) ((eq i 4)) (il:\\putbasebyte base i (char-code (car x)))) (with-collection (dotimes (i 4) (collect (array-read-thin-char base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type fat-string-char" (equal '(#\a #\b #\c #\A) (flet ((array-read-fat-char (base index) ((il:opcodes il:misc3 9) base 68 index))) (let ((base (il:%make-array-storage 4 68))) (do ((i 0 (1+ i)) (x '(#\a #\b #\c #\A) (cdr x))) ((eq i 4)) (il:\\putbase base i (char-code (car x)))) (with-collection (dotimes (i 4) (collect (array-read-fat-char base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type t" (equal '(2 #\c 2.3 (a . b)) (flet ((array-read-pointer (base index) ((il:opcodes il:misc3 9) base 38 index))) (let ((base (il:%make-array-storage 4 38))) (do ((i 0 (1+ i)) (x '(2 #\c 2.3 (a . b)) (cdr x))) ((eq i 4)) (il:\\rplptr base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-pointer base i)))))))) (do-test "Opcode ARRAYREAD (MISC3 9), type il:xpointer" (equal '(2 #\c 2.3 (a . b)) (flet ((array-read-xpointer (base index) ((il:opcodes il:misc3 9) base 86 index))) (let ((base (il:%make-array-storage 4 86))) (do ((i 0 (1+ i)) (x '(2 #\c 2.3 (a . b)) (cdr x))) ((eq i 4)) (il:\\putbaseptr base (ash i 1) (car x))) (with-collection (dotimes (i 4) (collect (array-read-xpointer base i)))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" (equal '(1 0 1 0 (1 0 1 0)) (flet ((array-write-bit (new-value base index) ((il:opcodes il:misc4 7) new-value base 0 index))) (let ((base (il:%make-array-storage 8 0))) (il:\\putbasebyte base 0 160) (with-collection (do ((i 0 (1+ i)) (x '(1 0 1 0) (cdr x))) ((eq i 4)) (collect (array-write-bit (car x) base i))) (collect (let ((byte (il:\\getbasebyte base 0))) (list (ldb (byte 1 7) byte) (ldb (byte 1 6) byte) (ldb (byte 1 5) byte) (ldb (byte 1 4) byte))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" (equal '(0 23 255 4 (0 23 255 4)) (flet ((array-write-byte (new-value base index) ((il:opcodes il:misc4 7) new-value base 3 index))) (let ((base (il:%make-array-storage 4 3))) (with-collection (do ((i 0 (1+ i)) (x '(0 23 255 4) (cdr x))) ((eq i 4)) (collect (array-write-byte (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasebyte base i)))))) )))) (do-test "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" (equal '(0 23 255 65535 (0 23 255 65535)) (flet ((array-write-word (new-value base index) ((il:opcodes il:misc4 7) new-value base 4 index))) (let ((base (il:%make-array-storage 4 4))) (with-collection (do ((i 0 (1+ i)) (x '(0 23 255 65535) (cdr x))) ((eq i 4)) (collect (array-write-word (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbase base i)))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" (equal '(0 -23 255 -32768 (0 -23 255 -32768)) (flet ((array-write-signed-word (new-value base index) ((il:opcodes il:misc4 7) new-value base 20 index))) (let ((base (il:%make-array-storage 4 20))) (with-collection (do ((i 0 (1+ i)) (x '(0 -23 255 -32768) (cdr x))) ((eq i 4)) (collect (array-write-signed-word (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (let ((word (il:\\getbase base i))) (if (> word 32767) (il:\\vag2 15 word) word))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" (equal '(0 -23 65536 -2147483648 (0 -23 65536 -2147483648)) (flet ((array-write-fixp (new-value base index) ((il:opcodes il:misc4 7) new-value base 22 index))) (let ((base (il:%make-array-storage 4 22))) (with-collection (do ((i 0 (1+ i)) (x '(0 -23 65536 -2147483648) (cdr x))) ((eq i 4)) (collect (array-write-fixp (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasefixp base (ash i 1))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type single-float" (equal '(0.0 -23.0 3.4456E+24 -4.562435E-12 (0.0 -23.0 3.4456E+24 -4.562435E-12)) (flet ((array-write-floatp (new-value base index) ((il:opcodes il:misc4 7) new-value base 54 index))) (let ((base (il:%make-array-storage 4 54))) (with-collection (do ((i 0 (1+ i)) (x '(0.0 -23.0 3.4456E+24 -4.562435E-12) (cdr x))) ((eq i 4)) (collect (array-write-floatp (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (il:\\getbasefloatp base (ash i 1))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" (equal '(#\a #\b #\c #\A (#\a #\b #\c #\A)) (flet ((array-write-thin-char (new-value base index) ((il:opcodes il:misc4 7) new-value base 67 index))) (let ((base (il:%make-array-storage 4 67))) (with-collection (do ((i 0 (1+ i)) (x '(#\a #\b #\c #\A) (cdr x))) ((eq i 4)) (collect (array-write-thin-char (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (code-char (il:\\getbasebyte base i))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" (equal '(#\a #\b #\c #\A (#\a #\b #\c #\A)) (flet ((array-write-fat-char (new-value base index) ((il:opcodes il:misc4 7) new-value base 68 index))) (let ((base (il:%make-array-storage 4 68))) (with-collection (do ((i 0 (1+ i)) (x '(#\a #\b #\c #\A) (cdr x))) ((eq i 4)) (collect (array-write-fat-char (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (code-char (il:\\getbase base i))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type t" (equal '(2*#\c a (a . b) ((2 . 1) (#\c . 1) (a . 1) ((a . b) . 3))) (flet ((array-write-pointer (new-value base index) ( ((il:opcodesőil:misc4 7) new-value base 38 index))) (let ((base (il:%make-array-storage 4 38))) (with-collection (do ((i 0 (1+ i)) (x (list 2 #\c 'a (cons 'a 'b)) (cdr x))) ((eq i 4)) (collect (array-write-pointer (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (cons (il:\\getbaseptr base (ash i 1)) (il:\\refcnt (il:\\getbaseptr base (ash i 1))))))))))))) (do-test "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" (equal '(2 #\c a (a . b) ((2 . 1) (#\c . 1) (a . 1) ((a . b) . 2))) (flet ((array-write-xpointer (new-value base index) ((il:opcodes il:misc4 7) new-value base 86 index))) (let ((base (il:%make-array-storage 4 86))) (with-collection (do ((i 0 (1+ i)) (x (list 2 #\c 'a (cons 'a 'b)) (cdr x))) ((eq i 4)) (collect (array-write-xpointer (car x) base i))) (collect (with-collection (dotimes (i 4) (collect (cons (il:\\getbaseptr base (ash i 1)) (il:\\refcnt (il:\\getbaseptr base (ash i 1))))))))))))) \ No newline at end of file +;;; File converted on 14-Jun-88 15:01:09 from source array-tester +;;; Original source {qv}lisp>array-tester.;1 created 14-Jun-88 14:57:44 + +;;; Copyright (c) 1988 by Xerox Corporation + + + +;; array-read and array-write + + +(do-test "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 1)" + (equal '(1 0 1 0) + (flet ((array-read-bit (base index) + ((il:opcodes il:misc3 9) + base 0 index))) + (let ((base (il:%make-array-storage 8 0))) + (il:\\putbasebyte base 0 160) + (with-collection (dotimes (i 4) + (collect (array-read-bit base i)))))))) + +(do-test "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 8)" + (equal '(0 23 255 4) + (flet ((array-read-byte (base index) + ((il:opcodes il:misc3 9) + base 3 index))) + (let ((base (il:%make-array-storage 4 3))) + (do ((i 0 (1+ i)) + (x '(0 23 255 4) + (cdr x))) + ((eq i 4)) + (il:\\putbasebyte base i (car x))) + (with-collection (dotimes (i 4) + (collect (array-read-byte base i)))))))) + +(do-test "Opcode ARRAYREAD (MISC3 9), type (unsigned-byte 16)" + (equal '(0 23 255 65535) + (flet ((array-read-word (base index) + ((il:opcodes il:misc3 9) + base 4 index))) + (let ((base (il:%make-array-storage 4 4))) + (do ((i 0 (1+ i)) + (x '(0 23 255 65535) + (cdr x))) + ((eq i 4)) + (il:\\putbase base i (car x))) + (with-collection (dotimes (i 4) + (collect (array-read-word base i)))))))) + +(do-test "Opcode ARRAYREAD (MISC3 9), type (signed-byte 16)" + (equal '(0 -23 255 -32768) + (flet ((array-read-signed-word (base index) + ((il:opcodes il:misc3 9) + base 20 index))) + (let ((base (il:%make-array-storage 4 20))) + (do ((i 0 (1+ i)) + (x '(0 -23 255 -32768) + (cdr x))) + ((eq i 4)) + (il:\\putbase base i (il:\\loloc (car x)))) + (with-collection (dotimes (i 4) + (collect (array-read-signed-word base i)))))))) + +(do-test "Opcode ARRAYREAD (MISC3 9), type (signed-byte 32)" + (equal '(0 -23 65536 -2147483648) + (flet ((array-read-fixp (base index) + ((il:opcodes il:misc3 9) + base 22 index))) + (let ((base (il:%make-array-storage 4 22))) + (do ((i 0 (1+ i)) + (x '(0 -23 65536 -2147483648) + (cdr x))) + ((eq i 4)) + (il:\\putbasefixp base (ash i 1) + (car x))) + (with-collection (dotimes (i 4) + (collect (array-read-fixp base i)))))))) + +(do-test "Opcode ARRAYREAD (MISC3 9), type single-float" + (equal '(0.0 -23.0 3.4456E+24 -4.562435E-12) + (flet ((array-read-floatp (base index) + ((il:opcodes il:misc3 9) + base 54 index))) + (let ((base (il:%make-array-storage 4 54))) + (do ((i 0 (1+ i)) + (x '(0.0 -23.0 3.4456E+24 -4.562435E-12) + (cdr x))) + ((eq i 4)) + (il:\\putbasefloatp base (ash i 1) + (car x))) + (with-collection (dotimes (i 4) + (collect (array-read-floatp base i)))))))) + +(do-test "Opcode ARRAYREAD (MISC3 9), type string-char" + (equal '(#\a #\b #\c #\A) + (flet ((array-read-thin-char (base index) + ((il:opcodes il:misc3 9) + base 67 index))) + (let ((base (il:%make-array-storage 4 67))) + (do ((i 0 (1+ i)) + (x '(#\a #\b #\c #\A) + (cdr x))) + ((eq i 4)) + (il:\\putbasebyte base i (char-code (car x)))) + (with-collection (dotimes (i 4) + (collect (array-read-thin-char base i)))))))) + +(do-test "Opcode ARRAYREAD (MISC3 9), type fat-string-char" + (equal '(#\a #\b #\c #\A) + (flet ((array-read-fat-char (base index) + ((il:opcodes il:misc3 9) + base 68 index))) + (let ((base (il:%make-array-storage 4 68))) + (do ((i 0 (1+ i)) + (x '(#\a #\b #\c #\A) + (cdr x))) + ((eq i 4)) + (il:\\putbase base i (char-code (car x)))) + (with-collection (dotimes (i 4) + (collect (array-read-fat-char base i)))))))) + +(do-test "Opcode ARRAYREAD (MISC3 9), type t" + (equal '(2 #\c 2.3 (a . b)) + (flet ((array-read-pointer (base index) + ((il:opcodes il:misc3 9) + base 38 index))) + (let ((base (il:%make-array-storage 4 38))) + (do ((i 0 (1+ i)) + (x '(2 #\c 2.3 (a . b)) + (cdr x))) + ((eq i 4)) + (il:\\rplptr base (ash i 1) + (car x))) + (with-collection (dotimes (i 4) + (collect (array-read-pointer base i)))))))) + +(do-test "Opcode ARRAYREAD (MISC3 9), type il:xpointer" + (equal '(2 #\c 2.3 (a . b)) + (flet ((array-read-xpointer (base index) + ((il:opcodes il:misc3 9) + base 86 index))) + (let ((base (il:%make-array-storage 4 86))) + (do ((i 0 (1+ i)) + (x '(2 #\c 2.3 (a . b)) + (cdr x))) + ((eq i 4)) + (il:\\putbaseptr base (ash i 1) + (car x))) + (with-collection (dotimes (i 4) + (collect (array-read-xpointer base i)))))))) + +(do-test "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 1)" + (equal '(1 0 1 0 (1 0 1 0)) + (flet ((array-write-bit (new-value base index) + ((il:opcodes il:misc4 7) + new-value base 0 index))) + (let ((base (il:%make-array-storage 8 0))) + (il:\\putbasebyte base 0 160) + (with-collection (do ((i 0 (1+ i)) + (x '(1 0 1 0) + (cdr x))) + ((eq i 4)) + (collect (array-write-bit (car x) + base i))) + (collect (let ((byte (il:\\getbasebyte base 0))) + (list (ldb (byte 1 7) + byte) + (ldb (byte 1 6) + byte) + (ldb (byte 1 5) + byte) + (ldb (byte 1 4) + byte))))))))) + +(do-test "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 8)" + (equal '(0 23 255 4 (0 23 255 4)) + (flet ((array-write-byte (new-value base index) + ((il:opcodes il:misc4 7) + new-value base 3 index))) + (let ((base (il:%make-array-storage 4 3))) + (with-collection (do ((i 0 (1+ i)) + (x '(0 23 255 4) + (cdr x))) + ((eq i 4)) + (collect (array-write-byte (car x) + base i))) + (collect (with-collection (dotimes (i 4) + (collect (il:\\getbasebyte base i)))))) + )))) + +(do-test "Opcode ARRAYWRITE (MISC4 7), type (unsigned-byte 16)" + (equal '(0 23 255 65535 (0 23 255 65535)) + (flet ((array-write-word (new-value base index) + ((il:opcodes il:misc4 7) + new-value base 4 index))) + (let ((base (il:%make-array-storage 4 4))) + (with-collection (do ((i 0 (1+ i)) + (x '(0 23 255 65535) + (cdr x))) + ((eq i 4)) + (collect (array-write-word (car x) + base i))) + (collect (with-collection (dotimes (i 4) + (collect (il:\\getbase base i)))))))))) + +(do-test "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 16)" + (equal '(0 -23 255 -32768 (0 -23 255 -32768)) + (flet ((array-write-signed-word (new-value base index) + ((il:opcodes il:misc4 7) + new-value base 20 index))) + (let ((base (il:%make-array-storage 4 20))) + (with-collection (do ((i 0 (1+ i)) + (x '(0 -23 255 -32768) + (cdr x))) + ((eq i 4)) + (collect (array-write-signed-word (car x) + base i))) + (collect (with-collection (dotimes (i 4) + (collect (let ((word (il:\\getbase + base i))) + (if (> word 32767) + (il:\\vag2 15 word) + word))))))))))) + +(do-test "Opcode ARRAYWRITE (MISC4 7), type (signed-byte 32)" + (equal '(0 -23 65536 -2147483648 (0 -23 65536 -2147483648)) + (flet ((array-write-fixp (new-value base index) + ((il:opcodes il:misc4 7) + new-value base 22 index))) + (let ((base (il:%make-array-storage 4 22))) + (with-collection (do ((i 0 (1+ i)) + (x '(0 -23 65536 -2147483648) + (cdr x))) + ((eq i 4)) + (collect (array-write-fixp (car x) + base i))) + (collect (with-collection (dotimes (i 4) + (collect (il:\\getbasefixp base + (ash i 1))))))))))) + +(do-test "Opcode ARRAYWRITE (MISC4 7), type single-float" + (equal '(0.0 -23.0 3.4456E+24 -4.562435E-12 (0.0 -23.0 3.4456E+24 -4.562435E-12)) + (flet ((array-write-floatp (new-value base index) + ((il:opcodes il:misc4 7) + new-value base 54 index))) + (let ((base (il:%make-array-storage 4 54))) + (with-collection (do ((i 0 (1+ i)) + (x '(0.0 -23.0 3.4456E+24 -4.562435E-12) + (cdr x))) + ((eq i 4)) + (collect (array-write-floatp (car x) + base i))) + (collect (with-collection (dotimes (i 4) + (collect (il:\\getbasefloatp + base + (ash i 1))))))))))) + +(do-test "Opcode ARRAYWRITE (MISC4 7), type thin-string-char" + (equal '(#\a #\b #\c #\A (#\a #\b #\c #\A)) + (flet ((array-write-thin-char (new-value base index) + ((il:opcodes il:misc4 7) + new-value base 67 index))) + (let ((base (il:%make-array-storage 4 67))) + (with-collection (do ((i 0 (1+ i)) + (x '(#\a #\b #\c #\A) + (cdr x))) + ((eq i 4)) + (collect (array-write-thin-char (car x) + base i))) + (collect (with-collection (dotimes (i 4) + (collect (code-char (il:\\getbasebyte + base i))))))))))) + +(do-test "Opcode ARRAYWRITE (MISC4 7), type fat-string-char" + (equal '(#\a #\b #\c #\A (#\a #\b #\c #\A)) + (flet ((array-write-fat-char (new-value base index) + ((il:opcodes il:misc4 7) + new-value base 68 index))) + (let ((base (il:%make-array-storage 4 68))) + (with-collection (do ((i 0 (1+ i)) + (x '(#\a #\b #\c #\A) + (cdr x))) + ((eq i 4)) + (collect (array-write-fat-char (car x) + base i))) + (collect (with-collection (dotimes (i 4) + (collect (code-char (il:\\getbase + base i))))))))))) + +(do-test "Opcode ARRAYWRITE (MISC4 7), type t" + (equal '(2*#\c a (a . b) + ((2 . 1) + (#\c . 1) + (a . 1) + ((a . b) . 3))) + (flet ((array-write-pointer (new-value base index) + ( ((il:opcodesőil:misc4 7) + new-value base 38 index))) + (let ((base (il:%make-array-storage 4 38))) + (with-collection + (do ((i 0 (1+ i)) + (x (list 2 #\c 'a (cons 'a 'b)) + (cdr x))) + ((eq i 4)) + (collect (array-write-pointer (car x) + base i))) + (collect (with-collection (dotimes (i 4) + (collect (cons (il:\\getbaseptr base + (ash i 1)) + (il:\\refcnt + (il:\\getbaseptr base + (ash i 1))))))))))))) + +(do-test "Opcode ARRAYWRITE (MISC4 7), type il:xpointer" + (equal '(2 #\c a (a . b) + ((2 . 1) + (#\c . 1) + (a . 1) + ((a . b) . 2))) + (flet ((array-write-xpointer (new-value base index) + ((il:opcodes il:misc4 7) + new-value base 86 index))) + (let ((base (il:%make-array-storage 4 86))) + (with-collection + (do ((i 0 (1+ i)) + (x (list 2 #\c 'a (cons 'a 'b)) + (cdr x))) + ((eq i 4)) + (collect (array-write-xpointer (car x) + base i))) + (collect (with-collection (dotimes (i 4) + (collect (cons (il:\\getbaseptr base + (ash i 1)) + (il:\\refcnt + (il:\\getbaseptr base + (ash i 1))))))))))))) diff --git a/internal/test/Maiko/OBSOLETE/FLOAT-TESTER b/internal/test/Maiko/OBSOLETE/FLOAT-TESTER index e5b96d2e..7d1a579f 100644 --- a/internal/test/Maiko/OBSOLETE/FLOAT-TESTER +++ b/internal/test/Maiko/OBSOLETE/FLOAT-TESTER @@ -1 +1,116 @@ -(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 +(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 diff --git a/internal/test/Maiko/OBSOLETE/FLOAT-TESTER.DFASL b/internal/test/Maiko/OBSOLETE/FLOAT-TESTER.DFASL index 784f4e61..74f29898 100644 Binary files a/internal/test/Maiko/OBSOLETE/FLOAT-TESTER.DFASL 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 index 37389d90..76b6aab3 100644 --- a/internal/test/Maiko/OBSOLETE/FLOAT-TESTER.TEST +++ b/internal/test/Maiko/OBSOLETE/FLOAT-TESTER.TEST @@ -1 +1,309 @@ -;;; 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 +;;; 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)))))) diff --git a/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS b/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS index 0b8a94a6..8528c11e 100644 --- a/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS +++ b/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS @@ -1 +1,39 @@ -(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 +(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 diff --git a/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL b/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL index ab34422a..8e30158b 100644 Binary files a/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL and b/internal/test/Maiko/OBSOLETE/MAIKO-UNWIND-TESTS.DFASL differ diff --git a/internal/test/Maiko/OBSOLETE/TESTER b/internal/test/Maiko/OBSOLETE/TESTER index c5233a96..0dc1461a 100644 --- a/internal/test/Maiko/OBSOLETE/TESTER +++ b/internal/test/Maiko/OBSOLETE/TESTER @@ -1 +1,51 @@ -(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 +(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 diff --git a/internal/test/Maiko/OBSOLETE/TESTER.DFASL b/internal/test/Maiko/OBSOLETE/TESTER.DFASL index 43733862..2e225117 100644 Binary files a/internal/test/Maiko/OBSOLETE/TESTER.DFASL and b/internal/test/Maiko/OBSOLETE/TESTER.DFASL differ diff --git a/internal/test/Maiko/OBSOLETE/unwindtest b/internal/test/Maiko/OBSOLETE/unwindtest index 2668bb24..15ad52a1 100644 --- a/internal/test/Maiko/OBSOLETE/unwindtest +++ b/internal/test/Maiko/OBSOLETE/unwindtest @@ -1 +1,31 @@ -(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 +(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 diff --git a/internal/test/Maiko/OBSOLETE/unwindtest.dfasl b/internal/test/Maiko/OBSOLETE/unwindtest.dfasl index 1b89b425..b543d129 100644 Binary files a/internal/test/Maiko/OBSOLETE/unwindtest.dfasl 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 index 0222bb5d..6721d99a 100644 Binary files a/internal/test/Maiko/OBSOLETE/unwindtest.lcom and b/internal/test/Maiko/OBSOLETE/unwindtest.lcom differ diff --git a/internal/test/Maiko/OBSOLETE/xclopcodetests b/internal/test/Maiko/OBSOLETE/xclopcodetests index 09990a86..a762eacb 100644 --- a/internal/test/Maiko/OBSOLETE/xclopcodetests +++ b/internal/test/Maiko/OBSOLETE/xclopcodetests @@ -1 +1,227 @@ -(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 +(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 diff --git a/internal/test/Maiko/OBSOLETE/xclopcodetests.lcom b/internal/test/Maiko/OBSOLETE/xclopcodetests.lcom index 4f34b32d..eaf320c9 100644 Binary files a/internal/test/Maiko/OBSOLETE/xclopcodetests.lcom and b/internal/test/Maiko/OBSOLETE/xclopcodetests.lcom differ diff --git a/internal/test/Maiko/STACKHAX b/internal/test/Maiko/STACKHAX index 889043c4..51aae49f 100644 --- a/internal/test/Maiko/STACKHAX +++ b/internal/test/Maiko/STACKHAX @@ -1 +1,78 @@ -(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 +(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 diff --git a/internal/test/Maiko/STACKHAX.LCOM b/internal/test/Maiko/STACKHAX.LCOM index 8912c48e..e69de29b 100644 Binary files a/internal/test/Maiko/STACKHAX.LCOM and b/internal/test/Maiko/STACKHAX.LCOM differ diff --git a/internal/test/Maiko/STACKHAX.LCOM.~1~ b/internal/test/Maiko/STACKHAX.LCOM.~1~ index 6e51f093..276ba8fa 100644 Binary files a/internal/test/Maiko/STACKHAX.LCOM.~1~ 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~ index fa289775..3cc91b84 100644 Binary files a/internal/test/Maiko/STACKHAX.LCOM.~2~ 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~ index 11580a06..4bfedffa 100644 Binary files a/internal/test/Maiko/STACKHAX.LCOM.~3~ 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~ index 8912c48e..7a4198f6 100644 Binary files a/internal/test/Maiko/STACKHAX.LCOM.~4~ and b/internal/test/Maiko/STACKHAX.LCOM.~4~ differ diff --git a/internal/test/Maiko/STACKHAX.LCOM.~5~ b/internal/test/Maiko/STACKHAX.LCOM.~5~ new file mode 100644 index 00000000..7a4198f6 Binary files /dev/null and b/internal/test/Maiko/STACKHAX.LCOM.~5~ differ diff --git a/internal/test/Tools/TESTER.LCOM b/internal/test/Maiko/STACKHAX.LCOM.~6~ similarity index 100% rename from internal/test/Tools/TESTER.LCOM rename to internal/test/Maiko/STACKHAX.LCOM.~6~ diff --git a/internal/test/Maiko/STACKHAX.~1~ b/internal/test/Maiko/STACKHAX.~1~ index 5422fe0c..17bbff0a 100644 --- a/internal/test/Maiko/STACKHAX.~1~ +++ b/internal/test/Maiko/STACKHAX.~1~ @@ -1 +1,62 @@ -(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 +(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 diff --git a/internal/test/Maiko/STACKHAX.~2~ b/internal/test/Maiko/STACKHAX.~2~ index f02958aa..d90c5997 100644 --- a/internal/test/Maiko/STACKHAX.~2~ +++ b/internal/test/Maiko/STACKHAX.~2~ @@ -1 +1,77 @@ -(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 +(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 diff --git a/internal/test/Maiko/STACKHAX.~3~ b/internal/test/Maiko/STACKHAX.~3~ index 8b70cf31..b2e1753f 100644 --- a/internal/test/Maiko/STACKHAX.~3~ +++ b/internal/test/Maiko/STACKHAX.~3~ @@ -1 +1,78 @@ -(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 +(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 diff --git a/internal/test/Maiko/STACKHAX.~4~ b/internal/test/Maiko/STACKHAX.~4~ index 889043c4..51aae49f 100644 --- a/internal/test/Maiko/STACKHAX.~4~ +++ b/internal/test/Maiko/STACKHAX.~4~ @@ -1 +1,78 @@ -(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 +(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 diff --git a/internal/test/Maiko/STACKTAKESHI b/internal/test/Maiko/STACKTAKESHI index 1884a4d6..c206fd6e 100644 --- a/internal/test/Maiko/STACKTAKESHI +++ b/internal/test/Maiko/STACKTAKESHI @@ -1 +1,73 @@ -(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 +(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 diff --git a/internal/test/Maiko/STACKTAKESHI.LCOM b/internal/test/Maiko/STACKTAKESHI.LCOM index 0040cc3e..cec9de4f 100644 Binary files a/internal/test/Maiko/STACKTAKESHI.LCOM and b/internal/test/Maiko/STACKTAKESHI.LCOM differ diff --git a/internal/test/Maiko/display.cl b/internal/test/Maiko/display.cl index 019fac6c..3c33fa9b 100644 --- a/internal/test/Maiko/display.cl +++ b/internal/test/Maiko/display.cl @@ -1 +1,460 @@ -;;; -*- 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 +;;; -*- 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")) diff --git a/internal/test/README.TEDIT b/internal/test/README.TEDIT new file mode 100644 index 00000000..c035304f Binary files /dev/null and b/internal/test/README.TEDIT differ diff --git a/internal/test/README.md b/internal/test/README.md deleted file mode 100644 index ec17ca3a..00000000 Binary files a/internal/test/README.md and /dev/null differ diff --git a/internal/test/TEST-RESULTS b/internal/test/TEST-RESULTS index 3de2fab9..b4e3ef6d 100644 --- a/internal/test/TEST-RESULTS +++ b/internal/test/TEST-RESULTS @@ -1 +1,136 @@ -;;; 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 +;;; 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 deleted file mode 100644 index 544cb0c4..00000000 --- a/internal/test/Tools/AUTOTEST +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index a8c20040..00000000 Binary files a/internal/test/Tools/AUTOTEST.LCOM and /dev/null differ diff --git a/internal/test/Tools/DO-TEST b/internal/test/Tools/DO-TEST deleted file mode 100644 index 7245314f..00000000 Binary files a/internal/test/Tools/DO-TEST and /dev/null differ diff --git a/internal/test/Tools/DO-TEST-MENU b/internal/test/Tools/DO-TEST-MENU deleted file mode 100644 index 3427113a..00000000 --- a/internal/test/Tools/DO-TEST-MENU +++ /dev/null @@ -1 +0,0 @@ -(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.~1~ b/internal/test/Tools/DO-TEST-MENU.dfasl.~1~ deleted file mode 100644 index 813fdabb..00000000 Binary files a/internal/test/Tools/DO-TEST-MENU.dfasl.~1~ and /dev/null differ diff --git a/internal/test/Tools/DO-TEST-MENU.dfasl.~2~ b/internal/test/Tools/DO-TEST-MENU.dfasl.~2~ deleted file mode 100644 index 64794fb4..00000000 Binary files a/internal/test/Tools/DO-TEST-MENU.dfasl.~2~ and /dev/null differ diff --git a/internal/test/Tools/DO-TEST.LCOM b/internal/test/Tools/DO-TEST.LCOM deleted file mode 100644 index 6bbca04c..00000000 Binary files a/internal/test/Tools/DO-TEST.LCOM and /dev/null differ diff --git a/internal/test/Tools/DO-TEST.dfasl.~1~ b/internal/test/Tools/DO-TEST.dfasl.~1~ deleted file mode 100644 index dfa9d21e..00000000 Binary files a/internal/test/Tools/DO-TEST.dfasl.~1~ and /dev/null differ diff --git a/internal/test/Tools/DO-TEST.dfasl.~2~ b/internal/test/Tools/DO-TEST.dfasl.~2~ deleted file mode 100644 index 6c7f65a0..00000000 Binary files a/internal/test/Tools/DO-TEST.dfasl.~2~ and /dev/null differ diff --git a/internal/test/Tools/FDEVTEST b/internal/test/Tools/FDEVTEST deleted file mode 100644 index 6427bf61..00000000 --- a/internal/test/Tools/FDEVTEST +++ /dev/null @@ -1 +0,0 @@ -(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/FILEBANGER b/internal/test/Tools/FILEBANGER deleted file mode 100644 index 9e1b5a4e..00000000 --- a/internal/test/Tools/FILEBANGER +++ /dev/null @@ -1 +0,0 @@ -(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/RANDOM-GENERATOR b/internal/test/Tools/RANDOM-GENERATOR deleted file mode 100644 index c19af9a6..00000000 --- a/internal/test/Tools/RANDOM-GENERATOR +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index 03f79229..00000000 Binary files a/internal/test/Tools/RANDOM-GENERATOR.LCOM and /dev/null differ diff --git a/internal/test/Tools/TEST-ARITHMETIC-UTILS b/internal/test/Tools/TEST-ARITHMETIC-UTILS deleted file mode 100644 index d046c152..00000000 --- a/internal/test/Tools/TEST-ARITHMETIC-UTILS +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index d52d98ba..00000000 Binary files a/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM and /dev/null differ diff --git a/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~1~ b/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~1~ deleted file mode 100644 index de62470c..00000000 Binary files a/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~1~ and /dev/null differ diff --git a/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~2~ b/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~2~ deleted file mode 100644 index d52d98ba..00000000 Binary files a/internal/test/Tools/TEST-ARITHMETIC-UTILS.LCOM.~2~ and /dev/null differ diff --git a/internal/test/Tools/TEST-DISPLAY-UTILS b/internal/test/Tools/TEST-DISPLAY-UTILS deleted file mode 100644 index e491daab..00000000 --- a/internal/test/Tools/TEST-DISPLAY-UTILS +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index 593c7161..00000000 Binary files a/internal/test/Tools/TEST-DISPLAY-UTILS.LCOM and /dev/null differ diff --git a/internal/test/Tools/TEST-FILING-UTILS b/internal/test/Tools/TEST-FILING-UTILS deleted file mode 100644 index 09eb1c53..00000000 --- a/internal/test/Tools/TEST-FILING-UTILS +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index 4380140e..00000000 Binary files a/internal/test/Tools/TEST-FILING-UTILS.LCOM and /dev/null differ diff --git a/internal/test/Tools/TEST-REMOTE-EVAL b/internal/test/Tools/TEST-REMOTE-EVAL deleted file mode 100644 index 5d3963f7..00000000 --- a/internal/test/Tools/TEST-REMOTE-EVAL +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index 15696f7c..00000000 Binary files a/internal/test/Tools/TEST-REMOTE-EVAL.LCOM and /dev/null differ diff --git a/internal/test/Tools/TESTER b/internal/test/Tools/TESTER deleted file mode 100644 index 1b8aaf20..00000000 --- a/internal/test/Tools/TESTER +++ /dev/null @@ -1 +0,0 @@ -(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.TEDIT b/internal/test/Tools/TESTER.TEDIT deleted file mode 100644 index 44d6cc29..00000000 --- a/internal/test/Tools/TESTER.TEDIT +++ /dev/null @@ -1,85 +0,0 @@ -THE INTERLISP-D TESTING SYSTEM -The Interlisp-D testing system is an integrated system built for creating, managing and using a large set of programmed tests for testing the correctness and the performance of the Interlisp-D programming environment. -The system is consisted of three parts : The test driver, the data base management system, and a graphic control tool. In addition, there are various tools for helping the test builders in the process of creating new tests. -All parts of the system assumes the structure of a TEST which is a data type consists of several fields, of which the most important are the expression which has to be evaluated, and a predicate which takes the results of this evaluation and determines whether the test was a success or a failure (i.e. whether the actual result is the same as the expected result). -The test driver is in principal a function which gets an object of type TEST, performs the test, and return either success or failure plus some additional information. It includes facilities for monitoring the test execution, tracing and recording the testing process to enable reproducing tests, Remote Eval protocols to enable performing tests with two machines and more. -The data base management system works in two levels. In the low level, the "test cluster" level, the system manages and organizes the tests in the file system, enable retrieving tests through a cashing system, and allows concurrent access to test files using a simple locking scheme. -In the high level, the system enables each user to manipulate the database using its own VIEW of the system. This view is implemented through the CONCEPT SPACE which is a directed acyclic graph that will usually reflect the logic structure of the system as seen by the user. -The graphic control tool displays a concept space as a graph and allows the user to perform most of the Test system operations by selecting nodes from the graph. -The tools for building and manipulating tests include test inspector (and editor), a random generator which can generate random specified Lisp objects, Indirect reference to other tests in TEST fields for shrinking the space of the tests themselves and avoiding redundant work when creating tests which share some of their fields, and more . -In the next sections the different parts of the system will be described as well as the interaction between them. - The TEST data type -The TEST is the data type of test objects. Its structure reflects the various properties that tests have. It includes the following fields: -TestID : The tests are identified by an integer. -Input : This field contains an expression that, when evaluated, will generate the list of arguments on which the tested expression will be applied. There are several tools which help in creating this entry. The random generator helps in generating random objects with specified restrictions. The SYSTEMATIC operation helps in generating systematically all the combinations over finite ranges. -Expression: It can contain a function name, a lambda expression or arbitrary sexpression. In the first two cases it will be applied on the input. -Success Predicate: This field contains a lambda expression with two arguments - the ACTUAL input for the test, and the result of the evaluation. It returns one of the two atoms: Success or Failure. When performing tests with random input, some tricks may have to be used as demonstrated in the examples in the end. -Timeout :This is a lambda expression which gets the ACTUAL input as an argument, and produces an upper limit to the estimated time of evaluation. -EvalBefore and EvalAfter: expressions to be evaluated before and after the test execution. usually, before the test we may want to set the appropriate environment for the test (like loading certain files), and after the test we may want to clean up the environment (like deleting files which the test created). -Pretests: Contains a list of links to other tests. These links may influence the order of an execution of a set of tests. Currently there are two types of links. A STRONG link to other test means that whenever the current test is going to be executed, the pretest must be executed first. An example for such pretest may be tests for the tests themselves. If a test generates a few thousands combinations of some arguments, it may be useful to test first if the test itself works correctly by executing a simplified test which works only on one set of arguments, and check that the test outcome is reasonable. A WEAK link to other test means that whenever a SET of tests is being executed, and both the test and pretest are in this set, the pretest will be executed before the test (thus it defines a partial order on any set of tests). This link may be used in cases where there is logical order on the execution of tests - for example, it is reasonable to test opening a file before testing writing to a file. -The Test Driver -The test driver accept a test as its input and returns either success or failure. It will evaluate the input and the tested expression itself on a remote machine if requested, or on the local machine otherwise. All the process of the testing is recorded on a trace file, such that as much information as possible will be available if needed. -The driver evaluates the EVALBEFORE form, evaluates the input expression to generate the input for the tested expression, applies the tested expression on the generated input, applies the success predicate on the result and the generated input, and evaluates the EVALAFTER form. After some of the above stages the appropriate information is written on the trace file. The most important one is the input generated, especially in cases of random input. -All the evaluation done by the driver uses the Interlisp-D ERRORSET command, thus allowing evaluation that will not break under error condition. The error type may be used by the success predicate to determine if the result is a success or a failure. Thus one test for many arithmetic functions can be to supply them with non numeric arguments and to check that the error reported will the right one. -The evaluation of the tested expression is done as a separated process, such that the driver will be able to try to interrupt it in case where the time of execution is larger then the value of TIMEOUT field of the test. This interrupt will work only if the test execution process will release voluntarily the cpu (when waiting on I/O for example) since Interlisp-D uses non preemptive scheme for process scheduling. -Remote evaluation will not benefit us much in this type of problems. If the remote machine is in infinite loop for example, it will not listen to interrupt attempts as well. The advantages of using remote machine are two: If a long sequence of tests are executed, and the machine "freezes", a remote test will freeze the remote machine and the local machine will be able to call for help and resume operation (as soon as the remote machine does not respond for more then some estimated limit of time, the local machine sends messages to a preset distribution list and asking for human help). A second benefit of remote evaluation is when we need to evaluate the tested expression in a different environment than the Testing system resides. We will want the testing system to work in considerably nvironment (software release), while we are testing an experimental different environment. - -The data base management system: the "test cluster" level. -The user can retrieve a test by calling the GetTest function. The low level of the dbms is responsible for performing the appropriate operations to retrieve the requested test. If the test is not already loaded it will be loaded from its file. There is a limit on the number of the tests that are loaded, and if these number is exceeded a replacement will take place and a test will be removed. The replacement policy is LRU (least recently used) and is implemented by moving each test being referenced to the front of the list of the loaded tests. Thus the last test in the list will be the one to be removed. The limit on the number of loaded tests is dynamically modified according to the amount of the available memory. -The Interlisp-D testing system is designed to work with several users uses it concurrently. There are no problems if the users were only retrieving tests from the data base. Problems may occur if two users modify the same part of the data base in the same time. -For such cases a locking scheme was integrated into the system. There is a special designated file which is the "gate" for the data base. Users can obtain write LOCKS on tests. The file contains the list of users with their locked tests. The basic locking function is ObtainDatabaseWriteLock(testnumber) which checks the LOCK file, and registers the tests that are not already locked . The user has the option of automatically generated messages that will be sent to the locking users, inform them that somebody is waiting for their locked test s and request them to release them as soon as they are not needed. -Thus, either automatically or manually, whenever a user edits a test, he will first obtain LOCK on tests. The locking scheme will work only if the users will follow the rules and will not try to access tests not through the testing system. -The basic operation - ObtainDatabaseWriteLock is "atomic" in the sense that the LOCK file is opened for read and write throughout the execution of this procedure, and thus no other user will be able to open it. The time interval in which the file is opened is very short. -Another problem that may arise from concurrent access to the data base is test numbering. As mentioned above, each test has a unique integer as an ID. Thus there is a file which contains the last ID issued, and the procedures for creating new tests will access and update this file. - The "Concept Space" level. -What is the "thing" which is being tested by the test? it may be a specific low level system function, a library package, or a new representation scheme for integers. It is hard to find a common class to which all these entities belong. Thus the testing system assumes that it is some CONCEPT of the Interlisp-D system that is being tested. -While it is true that when a test is CREATED, its creator intent to test a specific concept, the test itself is not necessarily a test only for this concept. A test that was built for testing the READ function, may actually test also the NS communication protocols, the OPENFILE function etc. -For this reason the tested concept is not considered to be a part of the test itself. There is a separated knowledge strpace" which is the way that the user views the test cluster. A concept space is an acyclic directed graph of CONCEPTS. Each node of the graph is of type CONCEPT which has four fields: The concept name, the tests that tests this concept, the subconcepts and the superconcepts. -The main purpose of the concept space is to enable the user to group tests in a logical way and to perform operations on these sets of tests. The semantic of a concept node is : "the tests which tests this concept are the tests of the concept itself plus the tests that tests its subconcepts (recursively)". -Such a definition allows us to build concept spaces which view the tests from different points of view. We may have a concept named "Arithmetic system" with subconcepts "Integer arithmetic", "Flote arithmetic"and "Arithmetic functions". The "Arithmetic functions" will have as subconcepts, the concepts "IPLUS", "FPLUS", "PLUS" etc. "IPLUS" is also a subconcept of "Integer arithmetic", and "FPLUS" of "Float arithmetic". Thus, if a new representation for the integers was introduced to the system, we will test the "Integer Arithmetic" concept, while in other cases we may want to test the "Arithmetic Functions". -From the above example and from the more detailed example at the end, we can conclude that the organization of the test system should be very flexible, since there can be many parallel views into the same part of the system. We can also see why a tree structure would not be sufficient as a representation scheme. The Testing system supports the the co-existence of several concept spaces, and thus each user can build and use his own concept space(s) to reflect his view of the system. -THE CONCEPT SPACE BROWSER -Most of the operations of the Interlisp-D testing system are done through the "Concept Space Browser". The browser is a graphic tool which is applied on a concept space. -It has a few types of operations. Any operation that require a concept as an argument will get it by a selection from the displayed graph. -The first type of operations are operations for modifications of the concept space itself. There are commands to add new concept, to delete a concept, to ad and delete a link and to add and delete a test to a concept. -Second type of operations are data base operations. The user can edit a test selected from specific concept, can hardcopy all (or part of) the tests of a selected concept, and can request to lock all (or part of) the tests of a concept. -A third type are display op can be specified, a browser of a subgraph can be created, and the tests can be dre are commands to execute all (or part of) the tests of a certain concept, with different modes of execution . -The browser also allows to copy subgraphs between two displayed concept spaces, and to get all the tests of a node by a copy selection so that functions that are not available in the browser can use the concept space as well. - .—˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üřŔ*ŞŞŻęŞŞŞŞŞŤęŞŞŞŞŞŤţŞŞŞ>˙˙đ˙˙˙˙˙óă˙˙ř€üř1™€UUU]UUUUUUWuUUUUUU]UUTc˙˙ç?˙˙˙˙˙ăÉ˙˙ř€üř`ŰUUU]UUUUUUWuUUUUUU]UUTc˙˙ç?˙˙˙˙˙ƒœ˙˙ř€üř`Ţ*ŞŞżŞŞŞŞŞŞŽŞŞŞŞŞŞŞşŞŞŞc˙˙ç?˙˙˙˙˙óœ˙˙ř€üř`Ü6*ŞŞşęŞŞŞŞŞŻęŞŞŞŞŞŞşŞŞŞ>˙˙ç?˙˙˙˙˙óœ˙˙ř€üř`ŢfUUU]ŐUUUUUWuUUUUUUuUUTc˙˙đ?˙˙˙˙˙óœ˙˙ř€üř`ŰfUUUUŐUUUUUWuUUUUUUuUUTc˙˙˙?˙˙˙˙˙óœ˙˙ř€üř`ـ*ŞŞşęŞŞŞŞŞŽşŞŞŞŞŞŞęŞŞŞc˙˙ç?˙˙˙˙˙óœ˙˙ř€üř1˜Ŕ*ŞŞşęŞŞŞŞŞŽşŞŞŞŞŞŞęŞŞŞc˙˙ć˙˙˙˙˙óÉ˙˙ř€üř`UUU_ŐUUUUUWőUUUUUUŐUUT>˙˙đ˙˙˙˙˙˙óă˙˙ř€üřUUUUUUUUUUUUUUUUUUUUUT˙˙˙˙˙˙˙˙˙˙˙˙˙řüř*ŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞ˙˙˙˙˙˙˙˙˙˙˙˙˙řüř*ŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞ˙˙˙˙˙˙˙˙˙˙˙˙˙řüř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙üř€Ăŕ0ř˙˙ƒă˙˙˙˙˙ŕđ˙˙˙˙ř?Ÿ˙˙€đü|˙˙ŕŕ?˙˙üřŔĆ0qŒ˙˙9É˙˙˙˙˙Îg?˙˙˙˙óŸ˙˙€ŔĆ3˙˙Î?˙˙üřŔĆ0ńŒ˙˙9œ˙˙˙˙˙Îg?˙˙˙˙óž˙˙€ŔĆc˙˙Î~˙˙üřŔŔ01Œ˙˙ůœ˙˙˙˙˙ţ?˙˙˙˙˙žŸ˙˙€ř`˙˙ţ|˙˙˙üř€Ŕŕ0ř˙˙óœ˙˙˙˙˙üü˙˙˙˙˙<Ÿ˙˙€1Œ ~˙˙üü˙˙˙üřŔ01Œ˙˙çœ˙˙˙˙˙ů˙?˙˙˙˙ţyŸ˙˙€aŒc˙˙ůů˙˙˙üřŔ01Œ˙˙Ϝ˙˙˙˙˙ó˙?˙˙˙˙üůŸ˙˙€Ŕ 0c˙˙óů˙˙˙üř Ć01Œ˙˙Ÿœ˙˙˙˙˙çç?˙˙˙˙ůř˙˙€Œ`c˙˙çó˙˙˙üřĆ01Œ˙˙?É˙˙˙˙˙Ďç?˙˙˙˙ó˙Ÿ˙˙€ŒŔc˙˙Ďó˙˙˙üřŔĂŕ0ř˙˙ă˙˙˙˙˙Ŕp˙˙˙˙đŸ˙˙€řřţ>˙˙Ŕs˙˙˙üř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙üř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙üř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üđ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<óŔ Ŕ<ň @@<ň#‹XŘâĂ@8đÄM–X@€<ň$Lˆ"d¨#$Ŕ"D@$J™"d@€<óÇČ"@¨"$@>0@$J‘>@<ň"@¨"$@ @$J‘ @<ňH"@¨"$Ŕ "DH$ʙ"@@<ňˆ@¨"#@80#J–@@<đ@!<đ€@."—=g<đ@!1"˜‘¨‘<đ@!!‘Ÿ<đ@!!‘<đ!!1‘˜‘‘<đ.— -<đ <đ 0<đ<đ<đ<đ<đ<đ<đ<đ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ý˝ ;î8p˙ěp`ß˙˙˙÷ń˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ýŢýŰíۡ~íŰ˝ďÎ~ötçœcîǞy˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ý­Ţ;î{ˇ>źýáÎ~ý˛ŰmˇóŰmś˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ýľŢýŰď¸wgß}ďŐ~ýśß -ˇýۍđ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ýšŢýŰíŰ÷~ď{˝ďŐ~őśŰ}ˇîŰmˇ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ý˝Ţ -Ř.;đ˙|}ŕŰvçŒsńÇx˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ý˙˙ß˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ý˙˙ß˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<đ<đ <đ <đ‡‹‡.x<đ##HLH‘1 <đ"!!HH! <đ>!!HH! <đA##HHH‘1 <đA‡ˆG.<đ <đ <đ<đ<đ<đ<đ<đ<đ<đ<đ<đé Ŕń<đ’ (‰<đČb (ń<đňcĆD‰<đţ’|‰<đž|xůŕxŸ"A>|ţ ‚‰<đ˜ˆ@„D„"c €ţ<đ”ˆx€ńŕx„>c<ţ<đ’ˆ@œ"D„"U ><đ‘ˆ@Œ>D„"U ťř<đˆ|tůAD„"I>đ<đ€ŔÄx…<đ -ŕ?€$„Ĺ<đ@ XĀĽ|@<đ@&ň$œ•¨B@<đ€€$Œ¨AG<ŕ8x¸pâç€<đ`Ät„âHA"H‘D„ĉ<đƒA>O‘đ@„„ň<đ@†A H@„„<đ@A€B"H‘D„„‰<đ 0`|G ŕ8x„pâá€<đ <đú‚‡‰ň$çČđP<đ ‚EDHB&2 H<đ@ňEGˆCć3Á H€Ŕ<đ€‚H„2$HB%R $`0<đ€‚O„äHB%R €" <đƒçDHB$“áđ`<đ 8Ŕ<đ@€0<đ€€€Ŕ <đ`@ <đŘ Ŕ<đ & 0ä‚|N<đ ‚ „Ć@Ž<đ@ a€„ĆxN<đ€@@„Ş@<đ€†„ „Ş@Ž<đa‚„’|N<đâ<đ Y<đG<đĄ€`<đ ``p<đ Ŕ0XHÄ€<đA&„$"€<đB€$<đ„ `“Ä—<đČ"##˜’<đ$Î"!!”<đ >!!š<đ@`A##‘<đ€X A€<đ€†Ŕ<đá€<đ$€R`x‚#Ž<đH€LD‚$N<đ°@*D‚#<đŔ@ x‚ Ž<đ€ @@‚$N<đ'ȐOŸ#Ă (° @ůÎ<đ!˜Č$&K0<đ!˜Ď$„Ŕ<đH‘!•H$ <đ‘!•H$#  Ŕ<đQ!’O„#Ŕŕ! <đ Ŕŕ|OŽ<đ€˜Č<đŔ"@˜Ď<đ0F •H<đ™` •H<đ€!€ŕ’OŽ<đ`F€<đˆ€č<đ0O<đ ŕ Ŕđ<đ  <đ@!â|‰ůň<˘ByňO‘đI @<đ‰$řB<BxB!!@ <đˆx A##D‰<đHA8pŔ<đD<đ$<đ <đ@ <đ@â#ÇÎ<đ€$!<đ€’$!<đ’’$!<đR$!<đáĂÁ<đ<đ<đ<đ<đ<đ#ăĂĂώHO<đ $B$$("LP€<ń!|ůâăŔx #Ä$ JP<ń1  D@˙Č ‚â$$IS€<ń)ńâ D@˙ţ$B$$("Hр<ń%#ĆD˙ࣂ#ĂώHN€<ń# Dţ<ń!ůčâxQđ<đl<đbř|@@<đ1€ŔB@@<đ(@<OžAG<ŕó‡<<đ(0ŕP˜Č’A"H‘DH<đ˜Č’A>O‘đGÇ<đČ•OA HD<đ P•HB"H‘DH<đ ŔHď‘|G ŕ3‡ <đ <đ€<đ€<đ@˙˙˙˙˙˙˙˙˙˙Î<đ Ŕ<đ <đŠBđńN>|‚"źN<đŠb‰ H‘@Ć"˜˘BDALPˆN<đRR‰Ş xĆT”˘B*äJPN<đ€ĹRJ‰Ş`‚@Ş˙˙˙˙ńT’˘B*™IPN<đ„`ü"F‰DB@ވ‘˘BHЈN<đ‚ţ"BđđD‚|’ˆź<ˆON<đ‚ Lj‚?<đA’$HDŔ<đ@€ˆ‘„H(ŕ<đ@€HGˆ"đ˙˙˙˙˙˙˙˙˙˙Î<đ @’$>€˙˙˙˙˙˙˙˙˙˙˙ţ<đ @ÄÁ~@<đ ř@<đŕž!|pOž!|pD„óäx„â<đ€!1ˆH!1ˆDĹ„„Ĺ<đ~!)`O!)`DĽ„„¤Â<đČ!%˙˙˙˙˙Č!%D•„„”"<đ!#ˆH!#ˆD„„ <đ!pH!p8„đ„x„â$<đ@@<đ@@/pç€<đ€@~#$‰<đ€˙˙˙˙˙˙˙˙˙˙˙ţ@!$řâ<đ@@!$€<đ@@#$‰<đ „ŕ>HO#pá€<đĹ LP€<đ€¤Ŕ<JP<đ€”# IS€<đ€ Hр<đ@`„ŕ ŸHN€<đ@€<đ <đ <đ `<đ€€<đ@đâ } ž<đ@ ‰@A ˜Ą<đ 0ˆÂ€y ” <đ Ŕ ˆ#FA ’§<đđ‰ A ‘Ł<đ đâA><đ0đ<đ@<đ€x<đ€<đ8<đ ÄO‚DB <đ@ ‚<8!Á<đŸAxA#‹ˆâ <đ@ŔA$LI źđ@8pA#ˆHq@<đ €€A HI‘@ <đ xxB$LI€<đ €|#‹ˆč€<đđ‚<Ń!<ů!8<$'€<đ‚B1B!!1DŔ‘&(€<đđ„B‘)@!!)0<ž% €UUUUUUUUUUUU|đ ˆBd%@!!%˙˙˙˙˙Ď$§ŞŞŞŞŞŞŞŞŞŞŞŞźđˆB#B!!#D<$hŞŞŞŞŞŞŞŞŞŞŞŞźđ<!|qńŔ8ŕ<đ€ř@ˆB pE<đpđx`A€E<đ @@G˙˙˙˙ţ„E<đ€@ˆB E<đ`|pAŔ8ŕ<đ<đ<đŔ<đ8<đ<đ€<…áâ!|đCăǀ<đp"(Ő1@ˆ „$@A@<đ <(Ľ)xđ „'€A@ <đ"D•Š“%@‰„$@AYŃĂĹÄCÎó…<đ"|¨#@‰đ„$@"j2$&$A"DJźđ"‚…áâHŸ!|ŠƒÄ@AB$"C…<đA2B$"@J<đA"B2$&!"DD<đAAŃĂĹÁÎ3ˆ<đ<đ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üđ<đ<đ <đ <đ €xX Ŕ<<đ @ €h - <đ@ €@ <đ@ @ <đ@ €@ <đ@@čŔ <đ<đ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üőUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU_˙˙˙˙˙˙˙˙ýUU|˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü -Test creation tools and misc tools -There are several tools that were created to help the tests builders in their task. -In each field of a test the user can write (& n) when n is a test number. This tells the system that to retrieve the value for this field it should refer to the same field in test n. This was done since many tests share values for some of their fields. -The test inspector is built on the top of the Interlisp-D inspector. The user can inspect and modify the various fields of a test. In addition he can call the inspector on indirect referenced tests. -There are functions which keep tracks of changes done to tests, and functions which stores modified tests. -The Random Generator is a very important tool for creating a test. It has many entries for different Lisp objects which he can generate randomly. These set of possible entries will grow constantly as test builders will need more types of random objects. -The random generator function gets as an argument an object type and a list of modifiers. The test builder can specify in the input field of a test a call like (GenerateRandom 'LARGE-INTEGER), or (GenerateRandom 'WINDOW) or (GenerateRandom '(LIST-OF-ITEMS WINDOW 50 100)) to get a random list of length between 50 and 100 of windows. -From the experiments done with the Testing system it was clear that random tests are an important part of any testing and can discover bugs that would be hard to find otherwise. -Another tool is the SYSTEMATIC input generator. Many times we want to test a function if it works right with all the possible combinations of values of its arguments, or to find out whether an library package works with all possible settings for its flags. For such cases the test builder can specify in the input field that he wants a systematic test, and supply the expressions that produces the ranges of values to combine. - - - - TEST EXAMPLES: -EXAMPLE 1 -Ř ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙đđóüĂŕđ`€Ć0đ`€Ć0đ`řóŕ˜ßsńóŕĆ0đa™€Řٛ`ĂŕđaÁ€ŘٛĆ0đaüń€ŘٛűĆ0đa€9€ŘٛĆ0đa™€ŘٛĆ0đ`řđŕĎٛńóĂŕđđđđđđóçĎßż<üđGó6l0f1˜Bó6l0p1ŔfBó6o†><0đeBóçĚ00xBól00Âól0f1˜dÂóoĆ?|1đdGđđđđó÷矟8î;÷đŕ€áŔ@ÀđĆ Ć1ą¸î;˜ŔT  @ @€đĆ1ą˝ď{˜ŔÄ8ŇxpŕˆŽ<8ŘăÇ"p @°áŇxŕ@€đÇdž01˝ď{ćŘŔÄT&H™ ‰H‘D¨ˆ‚" @"ČFH€" @€đĆĆ01ˇmŰŘŔsäO řŔŒ|¨ńˆ"x @>ˆđD" đ@€đĆĆ1ąˇmŰxŔH" € …@Šˆˆ @ ‰D" @€đĆ Ć1ąˇmŰxŔÄ$H"$‰EDŠ ˆ‚ˆ @‘"ÉD€" @€đÇď†2l›ö8ŔÂáÄGpŕ‚ 8¨đŔ‡x @°đD đ@€đ€đ 0€đđđ€€ đ€đŇ8°áÇ°áĽˆ›đH€DÉ €‚Č"fH•"đO€0‰ň‡‚ˆ"$H•đH‰ˆ‚ˆ"$H•đ$H€DÉ ˆ‚Č"dI•"đÄG8°áŔ‡‚°!¤F•đ€ đ€Ŕđđ@đ€@>8řƒ‡"DăÇÇ@$N<8 ‚đ€ D A™"l$„@’&É"Dđ,8hŀ D A™"l$„@’&É"DâŔ8đD2D˜F@<0 Á"TÂ'ˆ@R%O<0# Dđ |ˆD@  ! •"Tř#Ä"@ůR%H(" |đ„ @ˆD@ D !“"T„>@2%H$D" @đD‘ D˜D@ D B!“"T„"@2%H"D" Dđƒƒ 8hD@>8 CÇDâÇ"|ÄO"8" 8đ€đ@đđ đçÇđăäHŸ>8p'Çđ„„(ˆ@„Mˆ!"đ„„(ˆ@„Mˆ!"đ‡†(đ@‡Ęž€!đ„>D @„Jň!đ„„|@„Jˆ!"đ„„Dˆ@„Jˆ!"đ‡ÇDˆŕ„HŸ8pÁđđ đđđqâGxqóçĎ"8řđ!H€‚D!2D€đŋ"!H€Xầ8řřŇD!2D€đ&L‚"!F"dƒ$J€ ͘H€D!ăǏ*@đđäH‚"!âA"D‚'ʀ<͘O€D! *@€đ$H‚!H€"D‚$ €l͘HD! &D€đ&L‚!H€"D’$J€l͘$H€D!&D€đĺ‹qă‡Db#Š€>ĚřÄGxqȟ"8řđđ0đđđpđA€đpăe‡ńaŔ DáŔ€đ™&‰Ś@™"A’ ‘"D‚ €đ‘"¤G>AŕD€€đ‘"¤H AD€@€đ‘&‰ŚH"I "L’ €đ‘p⥇1Ŕ4aÁđđđđpŕóöC‡ďßžA„N!ăă€<8p óăĆ3AFÉ!@ "Dˆ ó0ăĆ3 AFÉA@ "Dˆ óă1łgĂ3 AEOAăĂ <@` ó!łf>A%H‘"AB€(\ óáóć3AĺH‘>A"@$Dˆ óĂ63 A%H‘"A@"Dˆ óđĂö6ł Aň$O"!ă€"8p đ@ đpŕđđ óöCĎߟ>~@€óăl1ł`A@ó0ăl1ł`@óă1łϟ1ł|€€ ó!łl1ž`P óáól1ł`‚ ‚óĂl1ł`‚ óđĂ÷ĎŘ3~AĐđ@đ đđóöăż>c~ÄđĆă°cc„đĆ÷°cc„đĆ÷žccP„đĆÝ°ccP„đĆÝ°cc0„đĆÝ°cc0„đĆÉż>>ÇŔđđđđóöăż<@đĆă°fŔđĆ÷°p@đĆ÷ž<@đĆÝ°@đĆÝ°@đĆÝ°f@đĆÉż|đđđđđŕ ńć3ăçç>|ýůŸ?~‚œ<CÇÇxpŕ€ó6666 ŮłfÁąŽ `‚’"(B$€D‰€ó†6663fÁąŽ `‚’"(‚$€D‰@ńć6Ǐ3fů° |‚Šž"(ƒÇ†x€Ŕ@đö6Çž|Á° `‚J‘"D‚„"P¸ @đ6666Á°fÁąŸ `‚ʑ"|‚D€>H‰@ó6666 Ů°fÁąąŒ`‚J‘"D‚$€"D‰@óăăăçďŸ0fýůŸ1Œ~ƒäHž|đƒˆ<|đ„H‘@A"@đó<đH‘@A"@đ›e˜H‘xáAD!ńÀ>8řƒ‡"DăÇÇ@$N<8óyłcB$H„ lP@„@ D A™"l$„@’&É"Dóyłc‚"ˆ„ lP@„@ D A™"l$„@’&É"Dómłc‚†@2%H$Dóg°c‚!„ Tˆ@„@ D B!“"T„"@2%H"Dóc°>AÁ>DˆAÀ>8 CÇDâÇ"|ÄO"8đ@đ đđ@đ>8řƒ‡"DăÇÇ@$N<8 đ D A™"l$„@’&É"D đ D A™"l$„@’&É"Dđ<0 Á"TÂ'ˆ@R%O<0đ  ! •"Tř#Ä"@ůR%H(đ D !“"T„>@2%H$Dđ D B!“"T„"@2%H"Dđ>8 CÇDâÇ"|ÄO"8 đ đ@đđóöCěß>qâGóă Ůł!H€ó0㙳 !H€óă1łĂł !Fó!ł>!âAóáó˜3!H€óĂ Ř3 !H€óđĂ÷ěŘ3 qă‡đđđđó÷矷ŕđĆ Ć60đĆ60ĘđÇdž60ÂđĆĆ60đĆĆ60đĆ Ć60ÂđÇď†7ŕώđđđđńÄ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ -EXAMPLE 2 -Űœ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕřŕůţ€`0ŕř0Ŕ€ŕpŕř0Ŕ€ŕđŕř0|yđĚošřůđ`°ŕř0ĆĚŔ ll͍°a°ŕř0ĆŕŔ ll͍€c0ŕř0ţxŔ ll͍ý€c0ŕř0ŔŔ ll͍€cřŕř0ĆĚŔ ll͍€`0ŕř0|xp gěÍřů€`0ŕřŕřŕřŕřŕřŕř@€ŕůóçďߞ~xŸDAÁŕů›63́HÂ!ŕů›68ŕ1 PB`ŕů›7Ăx1 žpB ŕůóć< "HB ŕůƒ6 >HC ŕůƒ63Ě1"DB ŕůƒ7ăžř0"DńÁŕřŕř@€ŕřŕř€ŕůűóĎϏœwűřp@€@ŕřccŘÜwƒĚ` €*ˆ€ŕřcŘŢ÷˝ƒĚ`b‰aÏpË -lņŽ"aË,8pǀpŕřcăĂŢ÷˝ól`b €*’ D" L“"TFI‘"’$L2DˆB"ŕřcăŰśíƒl`ăÄxȑ"TPDH‘*ă"|`B"xŕřccŘŰśíƒ<`‰DˆH‘"TPDH‘*ˆ‘"@B"ˆŕřccŘŰśíƒ<`b‰$D‘"ˆH“"T DI‘0$H‘2DˆB@ "ˆŕřc÷Ï™6Mű`aqĂĂxȍT DFŽȏ,8pA€xŕř ŕř€ ŕřŕřŕřŔ ŕř ŕřáĂHŽ,8pǀXhă` 8qaŔ||aÉXhŕ‡ŕř$ȑ2Dˆ"d™  ‘&‰’ f̐$J"d™€ŕřĂäHŸ"@ř"D‰ "‰€fĚä "@ˆŔ€ŕř"H"@€""D‰ "‰@6fĚ$ "@ˆ €ŕř$ɑ"Dˆ""D™ &‰#6fĚ’$I "@™H€ŕřáĂFŽ"8pÂDhâ qÁf|a㈊@hŕ‡ŕř@ŕř@ŕřŕřŕř @@ŕř‚@"@AŕřâÀ,8hâÁXqaŔ"XpâC€<ńaŔ,8q`ŕřƒ$@2˜# A"d ’  d‰„@A’ ‘2D‰ŕř‚'Ŕ ˆ"#ÁDyŕ DůAŕ |ůŕř‚$ ˆ"$AD‰"D€€A @ŕř’$@ ˜"$A"D‰’ "D‰D@I ‘ D‰ŕřb#€ h"#ÁDyaŔDpâ#€1Ŕ 8qŕřŕřpŕřŕřŕř@€€Ŕŕ@ŕř€Ŕ€ŕřaǍŽ,8ăŔ°áŁ‹,4ÇÇŔ,4ăŔXqáËŕřB 2D"É`Œ‚2LflŔ2L™"d€DL‘ŕřB "0ń>‰ň ˆ‚"DćlŔ"D‘>@x€DHŒŕřB ‘" ‰ ˆ‚"DflŔ"D‘ @ˆ€DH‚ŕřBJ‘2D ‘"É`ˆ‚"LflŔ"L™"@ˆDH‘ŕř`AŠ,8đŔ°á ˆ‚"4ögŔ"4á@x`CˆŽŕř ŕř Ŕ8ŕřŕřŕřŕ€ŕř €ŕřâÀDp @ŕř$@&D @ŕřňŔ"Dx @ŕř"Dˆ @ŕř@&Lˆ @ŕřň€4x €ŕř€ŕřŕřŕř8@ŕůű !€C÷ďß €B'ńńŔ8 ŕůƒ q€ăŒ€ €ŁdˆŠ‰ "D ŕů˜q€ăŒ€ €ŁdˆŠ ‰ "Dŕůń˜Ůłá™€ €˘§ˆŠ ńဠ0ŕů€ŮłŒ ¤H‘ Ą@”.ŕů€đůóŒ€ ň¤HŸ ‘ ’"Dŕů€aƒŒ€ ¤H‘ ‰ ‘"DŕůřaűŮ€ ů'‰ńŔ‘8 ŕř  ŕř8@ŕřŕř8ŕř8€áÇȀ8!ŕŕřD$€DQˆ‘"ŕřD$ €DQˆ‘"ŕř@‡Š€@Qŕŕř@D €@‰@JŕřD$Dů É"ŕřD$D‰H‘"ŕř8řáÇĹ8‰HŽŕřŕř8ŕřŕřŕůű !ƒçďϟ?ˆâŕůƒ qƒ6 Ů°ČBŕů˜qƒ6 Ů° ČBŕůń˜ŮƒçϘٞ ¨Bŕů€Ůƒ6 ß0¨Bŕů€đůƒ6 Ů°˜Bŕů€aƒ6 Ů° ˜Bŕůřaűç왿 ˆăŕŕřŕřŕřŕřpŕůűqߟ1żA„N CÇŕřcqŘ1ąŒAFÉ ˘$H„ŕřc{Ř1ąŒ AFÉ@˘$H‚ŕřc{ß1ąŒ AEO@ŁÄŕřcnŘ1ąŒA%H‘"A…ÁŕřcnŘ1ąŒAĺH‘>AňDH‚ŕřcnŘ1ąŒ A%H‘"A$H‚ŕřcdߟ Aň$O"!#‡ŕř@ ŕřpŕřŕřpŕř8ŕř"Dŕř &Lŕř*Tŕř*Tŕř2dŕř"DŕřŽ8ŕřŕřpŕřŕřŕůűqߞ ŕřcqŘ3`ŕřc{Ř8  ŕřc{ß ŕřcnŘ ŕřcnŘ ŕřcnŘ3 ŕřcdßž řŕřŕřŕřŕřp€ŕřóńóóǟ>~üςżA„N!ăă€<8p@ŕů›lŮł`ĆŘÇ0AFÉ!@ "Dˆ@ŕůĂł`ĆŘÇ0 AFÉA@ "Dˆ ŕřóăǙł|ĆŘ -†> AEOAăĂ <@` ŕř{ăß>`ĆŘ -†0A%H‘"AB€(\ ŕř`Ř3`ĆŘφ0AĺH‘>A"@$Dˆ ŕů›lŘ3`ĆŘŘĆ0 A%H‘"A@"Dˆ ŕůńńńó÷Ϙ3~üϘĆ? Aň$O"!ă€"8p@ŕř@ @ŕřp€ŕřŕř`ŕřc€|řăŕ"x!ăŕ>D!áŔ ŕ‡xpŕŕř€‘6DQ lQ "!DH€D‰ŕřo€€‘6DQ lQ "ADH€D‰@€ŕřfđŔ€*DQăŔTQ€ADOx€Ŕ@€ŕřf€ €*x‰BȄT‰ŕ@ A$J"P¸ @€ŕřf€‘*@ů"„Tů "AäI>H‰@€ŕřf‘*@‰„T‰ "A$H€"D‰@€ŕřfřŕ"@‰ŕD‰ŔŸ â'ˆ€"Dpŕŕř ŕřŕřŕřŕř qÇπDpăă‡ŕřŒ‰!"D‰H„ŕřď> ‰!"D‰H‚ŕřŒŮł ‰!DĂŕřŒßł ‰!DŕřŒŘ3 ‰!"D‰H‚ŕřŒŮł ‰!"D‰H‚ŕřěĎ3páÁ€8păă‡ŕř ŕřŕřŕř 8ŕř€AÄG>řAÄž>ŕř€B$H„ € „‘ ŕřyžx‚$H„ € „‘ ŕřͲ̂$H„<đ „ž<ŕřý¸ü‚$H„ „” ŕřÁŽŔ‚$H„ đ„’ ŕřͦ̂$H„ „‘ ŕřyźxAÇ>ÇÇ>ŕř@€ŕř `8ŕřŕřpŕů¸ß1żAπ|řăŕ"|đCçŔDđâ "8ůđG<8ˆ@€ŕůźŮąŒA„B€2@ˆ „d‰`"D!B"Dˆ@€ŕůźŮąŒ A„B€2@ˆ „d‰`"D!B"D¨ @ŕůśŮąŒ AƒđŔ€*x𠇀T‰ "D!ŕB"D¨ @ŕůśß1ŒA€‚€ € *@Ą„”"T‰ "D!B"D¨ @ŕůłŘ1ŒA„B€&@‘đ„>L‰ "D!‚"DP @ŕůłŘ1Œ A„B&@‰„"L‰ "D!‚"DP @ŕůąŘ AńÂřŕ"|‰‡Ŕ"Dđâ 8!đ‡<8P@€ŕř@@€ŕřpŕřŕř@ @ŕřpqň!xˆƒ‡>|‰ÁÇȄ< ŕřH Cbˆ‘"Dˆ„H‘ @É  -Š" ŕřH Cbˆ‘"DPH‘ @É  -Š"ŕřx B˘ˆ"DP|‰áÁ‘  ŕř€ ŕř@ @ŕřŕř€ŕř|řăŕ"|đCçŔDđâ "8ůđ|ăŕ>DpÇÇDŕř€2@ˆ „d‰`"D!" lˆ$„"dŕř€2@ˆ „d‰`"D!" lˆ$„"dŕřđŔ€*x𠇀T‰ "D!ŕŔL‰ "D!" TˆD„"Lŕř&@‰„"L‰ "D!" Tˆ$„"Lŕřřŕ"|‰‡Ŕ"Dđâ 8!đŽâ>Dp'ÇDŕřŕř€ŕřŕř8ŕřƒ€ŕř„@"ŕř„Ŕ&ŕř…@*ŕř…@*ŕř†@2ŕř„@"ŕřă€ŕřŕř8ŕřŕř8ŕůű !ƒöoŸ €B'ˆâ'‡8áÏ>Dăă‡"€áÇÂŕůƒ qƒlـ €ŁdˆŠˆC$H‘D$H dB2€B!ŕů˜qƒĚـ €ŁdˆŠ ¨C$H•D$H dB2€B!ŕůń˜ŮƒáŒŮ€ €˘§ˆŠ ¨B¤H•D„Dă‡"řáÁŕř ŕř8ŕřŕř€ŕřPp„J‚ŕř H‰"PBdHŠH„I‚ŕř D‰"PBdHŠD„I‚ŕř Dpŕ<Pâ'‡ DřáȄŕřŕř€ŕřŕř€€ŕř>8â€Dđâ 8qŽ"xqLJŕřD@d‰ "‰„2D‰$H‘ŕřD@d‰ "‰ „2D‰R$H‘ŕřD@T‰  ‰P „*D‰R'ˆ‘ŕřDO•T‰§Ę.‰P „*D‰SĹžŕřD@ L‰@ "‰0&Dˆ˘ˆŕřD@ L‰@"‰0&Dˆ˘Hŕř8ăç€ Dđá@Ÿ8q"xp˘Gŕřŕř€ €ŕřŕřŕřDqȀŕřD!’$H€ŕřT!’$J€ŕřT!R$J€ŕřT!R$J€ŕř(!2$Eŕř(!2$Eŕř(qÅŕřŕřŕřŕřŕřqÇπ<|páÄBŕř‰!"@ˆB&Bŕř ‰!"@ˆB&Aŕř ‰!DÄO"đ@€ŕřB$E D†H‘"ˆ@€ŕř>x‚$E TP†H‘*ˆ @ŕřf́‡ĹxAÄH>(ĄÄOˆ@€ŕř@@€ŕř ŕřŕř€€€ ŕřŔ<|‰ŕ"|đăŕ8q>ŕř  "@ɐ"@‰"‰ŕř<ř ŕ"@ɐ"@‰"‰ŕř fŘŔ0"xŠxđĂŔ ‰P ŕř fŔ€0ž<@Š @ " .‰Säŕř fŔ@0 @™ @‘ "‰0ŕř fŔ 0 @™@‰"‰0ŕř <Ŕ 0 |‰ŕŸ|ˆăŕŸ8qÇŕřŕř€€€ ŕřŕřŕř 8qđˆDqȀ<|páÄBŕř ˆ@HD!’$H€"@ˆB&Bŕř ˆ@HT!’$J€"@ˆB&Aŕř `@HT!R$J€T!R$JŸ(@¸B%Aŕř ˆ@H(!2$E$@ˆB$Áŕř ˆ@H(!2$E"@ˆB$Áŕř>8p@ž(qÅ"|páÄBŕřŕřŕřŕř ŕřAÄB>DÄO"đ@€ŕřB$E D†H‘"ˆ@€ŕř>x‚$E TP†H‘*ˆ @ŕřf́‡ĹxAÄH>(ĄÄOˆ@€ŕř@@€ŕř ŕřŕř€€ŕř>Dń>D!áÏpăÇϑ88ů‡ŕřD‰ lQ$H‘‰$$!ąDAŕřD‰ lQ$HŠ ‰$$!ąDAŕřDńPTQHŠ aǏ<!QDAŕř DĄP„T‰âO „"!R'ŕř D‘0„Tů$H ‰D"!SäŕřD‰0„T‰$H ‰$"!R$ŕřŸ8‰D‰Èpâ'ϑ<8!$ŕřŕř€€ŕřŕřŕůűóĎŰđŕřccŕřceŕřcăĂa ŕřcă ŕřcc€ŕřccaŕřc÷ĂđgÁŕřŕřŕřŕřŕřˆâŕřČBŕřČBŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ -EXAMPLE 3 -Řł˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙đđóüŔđ`€Ŕđ`€Ŕđ`řóŕ˜ßsńóŕŔđa™€Řٛ`ŔđaÁ€Řٛ Ŕđaüń€Řٛű Ŕđa€9€Řٛŕđa™€ŘٛŔđ`řđŕĎٛńóŔđđđđđđ€óçĎßż<üđ>xqŔ8p@ó6l0f1˜D‰’  Dˆ@ó6l0p1ŔbD‰’ D ó6o†><0đb x‰Rp óçĚ00xP‰Rŕ ól00H‰2   ól0f1˜bD‰2 @ˆ óoĆ?|1đaDqŔŸ|p@đ@đ€đđđ"|!Âđ"@Q Bđ*@Q@đ*xQŔđ*@‰ đ@ů đ@‰đ|‰đđđđó÷矟8î;÷đŕŕáÄH‘pŔđĆ Ć1ą¸î;˜ŔT "B&H›"€ " đĆ1ą˝ď{˜ŔÄ8Ňxpŕ&B&H›"qŕ‹xqc` &`đÇdž01˝ď{ćŘŔÄT&H™ ‰*đBH•ˆ€ ‘ ‰’ * đĆĆ01ˇmŰŘŔsäO řŔ*ˆBĺH•ˆ€Ÿ ‰ * đĆĆ1ąˇmŰxŔH" € 2ˆB$ȕ"ˆ€ ‰ 2 đĆ Ć1ąˇmŰxŔÄ$H"$‰"ˆB$ȕ"ˆ€H‘ ‰ " B#đÇď†2l›ö8ŔÂáÄGpŕŔđáÄGp€ˆŽ q Ž AÁđđđđđÇÇ>8đ Dđŋ8p DâŔlđ&L‚Dˆ<0 "TđäH‚|`  >Tđ$H‚@ D  Tđ&L‚Dˆ D ‘"T`đĺ‹8pÁ>8â T đ đ@đđđ€Ŕ pđ € €đ>>qaÉx°ăŔ°áÄA8pǀ,8áō€đ3f‰’$J Č"É$Aˆ"2D‚&J€đ3fä ˆń>ń„A`""|‚$ €đ3f  ‰ DA""@‚$ €đ3f‰$I$‰ ‘"$Á ˆ" "D‚$ €đł>qȎˆđŔ€áĂApÂ"8Ä €đđđđđƒ‡áŔ@€ Ŕ>xp€đ„H€ @‚€€  Dˆ€đ„É€2`ŽDpŕ€đ€đ8đđóöC‡ďßžˆâóăĆ3ČBó0ăĆ3 ČBóă1łgĂ3 ¨Bó!łf>¨Bóáóć3˜BóĂ63 ˜BóđĂö6ł ˆăŕđđđđ óöCĎߟ>~B‚ â#Ÿ|řăŕ|‰çÇDřâ‚óăl1ł`BE"!$B€‰˛D BBó0ăl1ł`‚E"A$B€‰˛D BAóă1łϟ1ł|‚EA$BđŔ€ůSÁD Bó!łl1ž`‚H‘A$B€ ‡Č”‰R>D Bóáól1ł`‚O‘A$B€’‰RD BAóĂl1ł`‚H‘A$B€‘‰RD BAóđĂ÷ĎŘ3~C㈞ áÂřŕ€‘‰á8 ăă‚đ@ @đ 0đđŕ óöăż>c~‚œ<@‡‡đĆă°cc‚’"(ADH‘đĆ÷°cc‚’"(DH‘đĆ÷žcc‚Šž"(Gˆ đĆÝ°cc‚J‘"D‚% ‚đĆÝ°cc‚ʑ"|ƒäˆ‘đĆÝ°cc‚J‘"D‚$H‘đĆÉż>>ƒäHž|ýůŸ?~‚œ<CÇÇxpŕ€ó6666 ŮłfÁąŽ `‚’"(B$€D‰€ó†6663fÁąŽ `‚’"(‚$€D‰@ńć6Ǐ3fů° |‚Šž"(ƒÇ†x€Ŕ@đö6Çž|Á° `‚J‘"D‚„"P¸ @đ6666Á°fÁąŸ `‚ʑ"|‚D€>H‰@ó6666 Ů°fÁąąŒ`‚J‘"D‚$€"D‰@óăăăçďŸ0fýůŸ1Œ~ƒäHžD‘ "D€@@đ@‰ "T&D!I"D‰ "D€@@đ@ˆáŔDâŸ"8!ˆ"8‰óŔŸ8ř@€đ€đđđđ>|pÄH€|äG"đ ˆ$M€"@H„"đ ˆ$M€"@H„"đ <ˆ„J€"xĹH>đ ˆDJŸ"@ůK„"đ ˆ$J€"@Ȅ"đ ˆ$J€"@Ȅ"đ>pȀ@óäG"đ đđđđ8<8!áÀđ` "DQ$@đůçŔ "D|Q$@đc6Ŕ <@fQâđc6(\f‰Bŕ€đc6$Dfů"$@đc6"Df‰$@đać"8f‰Àđđđđ@€đƒˆœ!äG"!'‚"!áŔ€đ„H’!H„"!$E$Q €đěŢđH’(AH„"A$E(Q €đ,٘žAĹH>A¤E8Qâ€đŒŮ˜ˆ‘AK„"A§ˆ$‰Bŕ€đě٘H‘AȄ"Ad‘$ů" €đl٘H‘AȄ"Ad‘"‰ €đÇ٘ƒ‡>!óäG" â$Ž"‰Ŕ€đ€ €đ@€đđ@đ>|p$ODůŕŽ"@ř„Hž8ˆÇÇđ ˆ&HŠ"HH"@ „L‘D$„đ ˆ&HŠ"PH"@ L‘D $‚đ <ˆ%HŠ pń "@ J‘@ŕdžđ ˆ%O Hĺ"@ Jž"@„đ ˆ$Č"Hˆ"@ I>DD‚đ ˆ$Č"DH"@ I"Dˆ$‚đ>pÄHDůŕOŽ| ƒˆ"8ˆ'Çđ €đ@đđ0đ1Ŕđđ7Ŕđ3đ3đ3đ3đ3đđđđ€đ‰ŕŽ< CǂDˆÇŔ>Dqň!đ(É" ˘$F"DŘ$ dˆB!đ(É"@˘$J"DŘ$ dˆB €đ(Š"@˘$BD¨'€DpB!đ đ€đđ @đ!äG"‰Á>xă㈐> đ!H„"‰’"ˆ’ DH đAH„"‰’"ˆ” DHđAĹH>‰R"ˆx㇠đ  đ @đđ€đŽpCŔ‘<qç€>8‰áđˆ˘ ™"(‰"@ D‰đ ˆ˘ ™"(‰B@ D‰€€đ €ŁŔ•"(ĂÄ@<0‰€€đ €•8qđđđ€đđ @đqÇπ đ‰! đ ‰!(đ ‰!đ ‰!đ ‰!đ ‰!đpáÁ€> đ  đ @đđ€đÇ>đ !„đ<ř!„đ fŘ!đ fŔ! „đ fŔ!„đ fŔ!„đ <ŔÇđđ€đđ`€đ`xđ$ODůŕŽ"@ř@đ"Dˆ&HŠ"HH"@ @đo€"Dˆ&HŠ"PH"@ đlŔ Dđ%HŠ pń "@ đlŔ D %O Hĺ"@ đlŔ"D$Č"Hˆ"@ đlŔ"Dˆ$Č"DH"@ đlŔxˆÄHDůŕOŽ| @đ@đ€đđđŔ>8áÇđŔ D„Bđ8ٙĆ3Ŕ D„Bđ ٘f6@Ćađ‡€>8áÇđ€đ đđ ŕđAÄG>p đB$H„ ˆ đ‚$H„ ˜ đ‚$H„<¨ đ‚$H„ ¨ đ‚$H„ Č đ‚$H„ ˆ đAÇ>p đ@€ đ `ŕđđđxůň'ˆ€8ˆăçŔ"8qńÂđĆD€B$L€D‰„"D‰$Bđ÷ǟD€B$L€D‰„"D‰$AđĆlـxđB'Š€D‰‡€ "@áƒđĆoـP€B% €D‰„"@@đĆl€H€B$‰€D‰„"D‰$AđĆlـD€B$I€D‰„"D‰$Ađvg™€DřAÄH€8pŕ‡Ŕ8qńÂđđ đđđŔ!ăçȞ" â#Ÿ| âOđŔ!‘2!$B@PBHđ<Ď<A‘2A$B@PBHđfŮfAăÁž*A$BxPBOđ~Ü~AB”*A$B@ˆBJđ`Ç`A"’&A$B@řBIđfÓfA‘&A$B@ˆBHđ<Ţ<!á" áÂ@ˆă㈟đ @đ0đđ óqžc~CçÇ8ůç‚>đB'‡qÇπ@păŕ8ůň#€óyłc@„„D’E ˆŁ$H›‰!@!€!d@óyłc€„„D’E ˆŁ$H› ‰!@!€!d@ómłc€‡†@ńSDž<đ˘¤H• ‰!@ Ŕ€ž!âŁómžc€„\R„ |Ą¤H• ‰!@ ‡Č>! €óg°c€„„D2„ ‘ňdH• ‰!@!€!¤@óg°c€„„D2H„ ‰dH• ‰!@!€!¤@óc°>@‡Ç8ůäH„>‰'‡páÁ€|pŕ€8!ň#€đ@ đ đđđ8řâ'ŔDůáÇÂppâ$H€đ‘" B$"D$H!$M€đ‘" B$"T$ H!$M€(đ‘ AG€"Tńâ'‚x!¤J€đ ADž"TB$>D!r¤J€đ" AD"("$D!dJ€đ" @„"($D!dJ€đ8 ŕ‡Ŕ(ůÄŽxpâ#ˆ€>đđđđ @€đ @đ" @đ& đ* đ* đ2 đ" đ @đ @đ @€đđóöCěß>qńÄOŽóă Ůł @†Čó0㙳 @†Čóă1łĂł @…O ó!ł> @…Hóáó˜3 @…HóĂ Ř3 @…HóđĂ÷ěŘ3 pAÄOŽđđđđó÷矷ŕđĆ Ć60đĆ60ĹđÇdž60ÉđĆĆ60 đĆĆ60€đĆ Ć60ÁđÇď†7ŕÁđđđđńÄ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ -EXAMPLE 4 -Ůw˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€ř€ř€ůţ€`đ€ř0Ŕ€á˜€ř0Ŕ€ă€ř0|yđĚošřůđc€ř0ĆĚŔ ll͍°cđ€ř0ĆŕŔ ll͍€c€ř0ţxŔ ll͍ý€c€ř0ŔŔ ll͍€c€ř0ĆĚŔ ll͍€c€ř0|xp gěÍřů€ađ€ř€ř€ř€ř€ř€ř€ůóçďߞ~x#ˆ€ů›63Ě!€ů›68ŕ3!€ů›7Ăx2Ą€ůóć<Ą€ůƒ6 a€ůƒ63Ě2a€ůƒ7ăžř2#€€ř€ř€ř€ř€€ůűóĎϏœwűřů@ €8p€řccŘÜwƒĚ` €*!@@€€řcŘŢ÷˝ƒĚ`b!aÀ8đŇ<8â#68đáŔˆ€€řcăĂŢ÷˝ól`b €*!D@"D@&HD$D*@" ˆ€€řcăŰśíƒl`!C>0@|Â#*<@"ˆ€€řccŘŰśíƒ<`!@€ @@!@„*D@"…"€řccŘŰśíƒ<`b!D@ "DH$‘DDD‘*DH" …"€řc÷Ï™6Mű`a!C€80Ä 8ŕƒƒ*<0!Ŕ‚€ř€€ř€ €ř€ř€ř >8‰ńǏ„>|€ř@ @ DČB$H @€řáĆË,8đáŇxâĂH›Xđŕ‡ DČB$H @€ř%L‚2@"&H€" $ȕ"dA€D@Ŕ€ D¨B@€ř%H‚"D@"$A" H• D@ € D˜B$ˆ@€ř%L‚"DH"$H€" ɕ"DIH€ D˜B$H@€řáĹK"<0!ÄG ňF•D0ŕ‡ 8ˆAÄO‘|€ř@€ř€€ř€ř€řp€ř€€řâ%‡8°€ř‚&HˆDČ€ř‚$HDˆ€ř‚$HDˆ€ř‚dH‰DˆŔ€ř¤G8ˆ@€ř@€ř€€ř€ř€ř  €€ř  A €€ř‹ -xpăÀ,8ńaŀ,8âŔˆ€X°âŔ€řL“ ‰@2DA’&@2D ˆ€"dÉ €řȑ řÁ"|Aä"| ˆ€>@ €řH‘ €!€"@A"@ … @€řH“$‰$@ "DI$ "D …"@€řȍpŕÀ "81Ä"8⠂@€â€ř€ř €ř€ř €ř(8!Ŕp€ř(@@ €€ř(đŕC€xáÄK -€ř@ D@" ‚$L“€ř@ GŔ" ‚$H‘€ř@ D" ‚$H‘€ř@ D@"$‚$ȓ€ř@ C€ĂH€ř€ř €ř€ř8@€ůű !€C÷ďß €B'ńńŔ8 €ůƒ q€ăŒ€ €ŁdˆŠ‰ "D €ů˜q€ăŒ€ €ŁdˆŠ ‰ "D€ůń˜Ůłá™€ €˘§ˆŠ ńဠ0€ů€ŮłŒ ¤H‘ Ą@”.€ů€đůóŒ€ ň¤HŸ ‘ ’"D€ů€aƒŒ€ ¤H‘ ‰ ‘"D€ůřaűŮ€ ů'‰ńŔ‘8 €ř  €ř8@€ř€řŔ€řLjăŕ>8řç8 CäHŽ"@ă‚€ř€ř€ř€ř €ř CLjqÇπ|ůńÄOž>8qáǏŽ<€ř ˘$H‰!"@!&B D‰„B"€řß|@˘$H ‰!"@!&B D‰„B"€řłf@˘$H ‰!x!â%B<0ŕ„B<€řżfALj ‰!@!%B @‡‚(€ř°fAň ‰!"@!$ D‰ „$€řłfA ‰!"@!$ D‰„"€řٞf!„páÁ€|!ÄB>8qÄ"€ř  €ř €ř€řŔ€řxpŕ@€řD‰@€řD‰@€řx€Ŕ@€ř"P¸ @€ř>H‰@€ř"D‰@€ř"Dpŕ@€ř@€řŔ€ř€ř€ůű !ƒçďϟ?ˆâ€ůƒ qƒ6 Ů°ČB€ů˜qƒ6 Ů° ČB€ůń˜ŮƒçϘٞ ¨B€ů€Ůƒ6 ß0¨B€ů€đůƒ6 Ů°˜B€ů€aƒ6 Ů° ˜B€ůřaűç왿 ˆăŕ€ř€ř€ř€ř€ůűqߟ1żˆâ€řcqŘ1ąŒČB€řc{Ř1ąŒ ČB€řc{ß1ąŒ ¨B€řcnŘ1ąŒ¨B€řcnŘ1ąŒ˜B€řcnŘ1ąŒ ˜B€řcdߟ ˆăŕ€ř€ř€ř€ř€ůűqߞ €řcqŘ3`€řc{Ř8  €řc{ß €řcnŘ €řcnŘ €řcnŘ3 €řcdßž ř€ř€ř€ř€řp€€řóńóóǟ>~üςżA„N!ăă€<8p@€ů›lŮł`ĆŘÇ0AFÉ!@ "Dˆ@€ůĂł`ĆŘÇ0 AFÉA@ "Dˆ €řóăǙł|ĆŘ -†> AEOAăĂ <@` €ř{ăß>`ĆŘ -†0A%H‘"AB€(\ €ř`Ř3`ĆŘφ0AĺH‘>A"@$Dˆ €ů›lŘ3`ĆŘŘĆ0 A%H‘"A@"Dˆ €ůńńńó÷Ϙ3~üϘĆ? Aň$O"!ă€"8p@€ř@ @€řp€€ř€ř`@ @€řc€8đ„GůńÇŔ8đƒ‚<ńńÁ€ř Dˆ„E"‰!€ř DˆE"‰ €€ř8€ƒˆž"‰ńÁ€ř€€ř @€ř€ř€ř‡Â€ř€B€ř€€ř€€ř€ř€ř‚€řâ€ř€ř€ř€ř€ř qÇπDpă㇀řŒ‰!"D‰H„€řď> ‰!"D‰H‚€řŒŮł ‰!DĂ€řŒßł ‰!D€řŒŘ3 ‰!"D‰H‚€řŒŮł ‰!"D‰H‚€řěĎ3páÁ€8pă㇀ř €ř€ř€ř 8€ř€AÄG>řAÄž>€ř€B$H„ € „‘ €řyžx‚$H„ € „‘ €řͲ̂$H„<đ „ž<€řý¸ü‚$H„ „” €řÁŽŔ‚$H„ đ„’ €řͦ̂$H„ „‘ €řyźxAÇ>ÇÇ>€ř@€€ř `8€ř€ř€€ů¸ß1ż â#Ÿ"řáŔ"8ůđD #ˆ€ůźŮąŒ!$B6( B "D!Š"DP!€ůźŮąŒ ADB6( B "D!Š"DP!€ůśŮąŒ @ÁC*( B"D!ŕ |PĄ€ůśß1Œ@ €‚*D B"D! ‘ DˆĄ€ůłŘ1ŒA„B*| B "D!Ÿ"Dřa€ůłŘ1Œ A„B*D B "D!‘"Dˆa€ůąŘ ŕƒ‚"D áŔ8!đDˆ#„€ř €ř€€ř€ř€€ř"8ůđp#ˆ€ř"D! 0ˆ!€ř"D!Pˆ!€ř"D!ीř"D!„ Ą€ř"D!@a€ř"D!€a€ř8!đ|ř#„€ř€ř€€ř€ř€ř>8ř„8‰ÁÄB8ˆŕ€ř D D"DŮ †EDÉ€ř D D"DŮ †EDÉ€ř<0 D DŠŕ…ED¨Ŕ€ř  $ DŠ…H„D¨ €ř D ä"DŠ„Ď„D™€ř D B$"DŠ„Č„D™€ř>8 B'π8‰áÄH„8ˆŕ€ř€ř€ř€ř@€ř8ˆăçŔpqŔŸ<8‰"| €řD‰„H‰ -"‰°" €řD‰„H‰ -"‰°"€řD‰‡€x‰ ž"‰P>€řD‰„D‰ "‰P"€řD‰„D‰ "‰P"€řD‰„D‰ "‰P"€ř8pŕ‡ŔxqóŔŸ<8qÇ" €ř €ř @€ř€ř€řqđ„xřâ$€ř ADD$€ř ADD$€ř ADxń$€ř B$Pr$”€ř CäH$’€ř B$D$‘€řpB'ÇDřáÇȑ€ř€ř€ř€ř€€řńńÄH<pâ'8ůŕȞDńóŔ€€ř‰$H "‰dH"D‘d‰ €€ř ‰$H "‰dH"Dd‰ €€ř ńâH <¤O0ń‚T‰â €€ř ĄäH(§Š"T‰ €€ř ‘$H$‰¤ "D>L‰ €€ř ‰$H"‰¤"D"L‰ €€ř‰ńϑ"pâ$Ÿ8ůŕȐ"DńóŔ€€ř€€ř€€ř€ř€€ř"8ůđ8Ä€ř"D!€"D„€ř"D! €"L„€ř"D!ŕ €"TP„€ř"D! €TP„€ř"D! €d0„€ř"D!€"D0„€ř8!đ8Ç€ř€ř€€ř€ř€ €ř"8ůđx€B >8p#ˆ€ř"D!„"D€˘ ‘ Dˆ!€ř"D!„"D€Ą@‘ Dˆ!€ř"D!ŕ„D€Ą@ž<0`Ą€ř"D!„x€ Ą€ř"D!„"@đ€ Dˆa€ř"D!„"@€ Dˆa€ř8!đ@ů€>8p#„€ř€ř€ €ř€ř€ůű !ƒöoŸ|qă|ř€ůƒ qƒlـ@‰„H€€ů˜qƒĚـ@‰„H€€ůń˜ŮƒáŒŮ€x‰P„đ€ů€ŮƒŸ@‰P„ "€€ů€đůƒĚ€@‰0„I>€€ů€aƒl€@‰0„H"€€ůřaűöl€@qƒˆŸ"ř€ř€ř€ř€ř€ůűóĎŰđ€řcc€€řce€řcăĂa€řc　řcc€€řcca€€řc÷ĂđgÇ€ř€ř€ř€ř€řˆâ€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€' T& ' T'H T&H & MODERN MODERNMODERN Úánw˘Wr2’;“7ůYĹ“Łz;ŘgđX&Ž4h덋ÚďÜâl& BMOBJ.GETFN2#U˙ÇkP´Ź >ž BMOBJ.GETFN2MODERN  `š BMOBJ.GETFN2MODERN  eţ BMOBJ.GETFN2MODERN  Wî BMOBJ.GETFN2MODERN Bzş \ No newline at end of file diff --git a/internal/test/Tools/TESTERLOADER b/internal/test/Tools/TESTERLOADER deleted file mode 100644 index 824d8a0c..00000000 --- a/internal/test/Tools/TESTERLOADER +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index c137fbce..00000000 --- a/internal/test/Tools/TESTERLOADER.LCOM +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index 61a90656..00000000 --- a/internal/test/Tools/TESTERVARS +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index 7affcd04..00000000 Binary files a/internal/test/Tools/TESTERVARS.DFASL and /dev/null differ diff --git a/internal/test/Tools/TESTUSERS.TEDIT b/internal/test/Tools/TESTUSERS.TEDIT deleted file mode 100644 index 6107b8ac..00000000 --- a/internal/test/Tools/TESTUSERS.TEDIT +++ /dev/null @@ -1,113 +0,0 @@ -THE INTERLISP-D TESTING SYSTEM - USER GUIDE -This document should be used as a guide for users of the testing system, and it assumes that the reading of "The InterlispD Testing System" document. -LOADING THE TESTING SYSTEM -The testing system resides on the directory {Eris}tools>. To load the testing system, LOAD the file TESTERLOADER. This file contains the correct loading sequence for the testing system files. -FILES: -TESTER.DCOM - Contains the main part of the tester program. -TESTERVARS - Contains most of the tester global variables. -TEST-REMOTE-EVAL.DCOM -Contains the functions for executing remote eval. -RANDOM-GENERATOR.DCOM - Contains functions and variables for random generation. -VARBROWSER.DCOM - A user package for manipulating the programs global variables. -THERMOMETER.DCOM - A user package for displaying the progress of a program in execution. -INTERLISPD-SYSTEM.CONCEPTSPACE - The file contains the global concept space of the system. - -EXECUTING TESTS -Usually execution of tests will be done through the Concept Space Browser. The basic function which is called by the browser is: -(TEST.PERFORM-TEST TEST TIMES LOCATION TRACE-FILE TRACE-MODE) [ function] -Only the first argument is necessary. TEST must be of type TEST. TIMES is the number of times that the test will be performed and is defaulted to the value of the field TIMES of TEST. If this value is NIL it will be executed once. LOCATION can be either the atom "Local" or the atom "Remote" and is defaulted to the value of the global variable TEST.DEFAULT-LOCATION. TRACE-FILE is the name of the file on which the test execution process should be traced. The default name is the value of the global variable TEST.TRACE-FILE-NAME. TRACE-MODE can be the atom "On" or the atom "Off". It is defaulted to the value of the global vcariable TEST.DEFAULT-TRACE-MODE. When TRACE-MODE is "On" every testing step will be recorded on the trace file as soon as possible. The tracing will be done in a "careful" way - as soon as a new information is available (The input was generated, the result from the tested expression evaluation is returned, etc. ) , the trace file will be opened the information will be written and the file will be cvlosed. If the trace mode is Off, the function will check at the end of each iteration of the function to see if the outcome was a failure and only in such a case it will write it down on the trace file. -There are two ways in which the PERFORM-TEST function can iterate. One way is if the TIMES argument is greater then one (or the times field of the test is greater then one). The other way is when the input expression is a list starts with the atom SYSTEMATIC. In such a case each of the elemnets of the CDR of the list will be evaluated. The tester expect them to produce sets (lists) which are the ranges of the arguments. It will then collect all the possible combinations of the elements in these finite ranges and perform the test on each of these combinations. -The function returns the name of the trace file. -(TEST.HARDCOPY-TRACE-FILE TRACE-FILE OUTPUT-FILE FAILURES-ONLY) -The default for TRACE-FILE is the value of TEST.TRACE-FILE-NAME. The default for OUTPUT-FILE is the value of TEST.DEFAULT-HARDCOPY-DEVICE (usually {LPT}). The trace file is written in a way that is hard for reading. This function prints the trace file in a "pretty" way. if FAILURES-ONLY is non-NIL only the trace of tests that failed will be printed out. -Manipulating Concept Spaces -Concept spaces are stored in files, each concept space in its own file. usually the name of the file can be XXX.CONCEPTSPACE where XXX is the name of the concept space. This name can be retrieved by calling -(TEST.CANONICAL-CONCEPT-SPACE-FILE-NAME CONCEPT-SPACE-NAME) -Returns XXX.CONCEPTSPACE where XXX is the value of CONCEPT-SPACE-NAME. -A concept space is of type CONCEPTSPACE which is record with the fields CONCEPTSPACENAME ROOTCONCEPT and CONCEPTLIST. ROOTCONCEPT is the name of the root concept. CONCEPT list is a list of concepts. A concept is an instance of the record CONCEPT which has the fields CONCEPTNAME, TESTS, SUBCONCEPTS and SUPERCONCEPTS. SUBCONCEPTS and SUPERCONCEPT are NAMES of concepts. TESTS is a list of tests ids. Usually the initial concept space will be created by the function -(TEST.CREATE-NEW-CONCEPT-SPACE CONCEPT-SPACE-NAME ROOT-CONCEPT-NAME) -which returns an instance of CONCEPTSPACE with one concept. The rest of the concept space will be most conveniently built using the Concept Space Browser. -The system maintains a global list of the concept spaces that are "known" to the system. It is convenient to work with concept spaces that appear in that list since this will enable the user to perform certain operations on the concept space using the background menu. The global list is stored in the global variable TEST.CONCEPT-SPACES. This variable can be manipulated directly or by calling the function -(TEST.ADD-CONCEPT-SPACE-TO-CONCEPT-SPACES CONCEPTSPACE) -If a concept space with the same name is already in the list, it will be removed and the new one will be added. The function -(TEST.GET-CONCEPT-SPACE NAME) -Returns the concept space with name NAME (if there is one in TEST.CONCEPT-SPACES). -Concept spaces that are on the TEST.CONCEPT-SPACES can be stored by calling the function -(TEST.STORE-CONCEPT-SPACE CONCEPTSPACENAME) -The function will prompt for a file name, suggesting the canonical name. If the concept space was loaded before through the TEST.LOAD-CONCEPT-SPACE function then the candidate file name will be the same as the one that it was loaded from (but with higher version). The user can also choose the subitem "Store Concept Space" from the background menu. -(TEST.LOAD-CONCEPT-SPACE CONCEPT-SPACE-FILE-NAME) - Loads the concept space from the specified file, adds it to TEST.CONCEPT-SPACES and keeps the file name in the property CONCEPTFILE of the concept space name. -Building and manipulating tests -(TEST.CREATE-NEW-TEST ) [function] -Creates an instance of the record TEST with the default values which are obtained by calling the function TEST.GET-DEFAULT-FIELD-VALUE. The new instance is then added "officially" to the world by calling TEST.ADD-TEST . Then the test editor is called on the new test to allow the user insert values to its fields. It does NOT store the test in a file, and this should be done later by calling either TEST.STORE-TEST or TEST.STORE-CHANGED-TESTS. The test, after created is not assigned to any concept, and it is recommended to assign it as soon as possible to at list one concept. -(TEST.ADD-TEST TEST-RECORD) [function] -Assigns a new ID to the test record instance by calling TEST.GET-AND-INCREASE-NEXT-TESTID and adds the test to the list of loaded tests. -( TEST.EDIT-TEST TEST) [function] -TEST should be a test or a test number. If the global flag TEST.OBTAIN-LOCk-WHEN-EDIT is non NIL the function will try to obtain write lock on the test. If it fails to obtains such a lock it will exit without editing. The user can get the name of the locking users and automatically send release requests as described in the "accessing the database" section. -The test inspector will be called and the test will be marked as changed. -(TEST.GET-TEST TEST-NUMBER) -This function is the user interface to the database management system. The user calls this function and gets the test with the TESTID TEST-NUMBER. Actually the system will search for the test in the list of the loaded tests. If it will not be found a "test fault" will occur and the system will look for the file for this test and load the test from there. If by adding the test to the list of loaded tests an "overflow" occurs (the number of tests is more then the maximum allowed), the last test on the list (the least recently used will be deleted from the list. -(TEST.GET-FIELD-VALUE FIELD DATUM) -Gets the "Actual value" of a test field. If the field value is indirect reference to other test, the field value will be retrieved from there (using TEST.GET-FIELD-VALUE thus enable chaining), otherwise it will return the field value of DATUM. -( TEST.GET-DEFAULT-FIELD-VALUE FIELD-NAME) -FIELD-NAME is a TEST field name. The function will return the global default value for this field. -The following functions can be useful when building a test for use within the actual test fields: -(TEST.TEST-SINGLE-TIME TEST-NUMBER) -There are tests which have the TIMES field greater then one. Such tests will be executed more then one time. there are also tests which have as their INPUT field a list starts with the atom SYSTEMATIC. Such tests will be applied on all the combinations of the elements of sets in their INPUT field. Such tests can run for hours only to discover that something in the test itself was not correct, and the trace file is full of garbage. To avoid such a cases it is recommended to create for such tests a "Testing test" which will perform the tested test once and will only check that the outcome is meaningful (i.e. The result is either "success" or "failure" etc). Such a test can be built easily by having as its Expression field a call to this function with the tested test as TEST-NUMBER. It may be also useful to add a WEAK or STRONG link in the tested test PRETESTS field. -(TEST.ERRORP EXPR) [function] -If an error occured during the evaluation of the evaluated expression, the returned result will be a list of two elements, the first is the atom ERROR!, and the second is the error number. This is a simple predicate that checks if an expression is of the form described above. It is useful for building the success predicate. For example, a test may have as the EVALEXPR the function ADD1, as its INPUT field some non numeric atom, and as its success predicate, the expression (LAMBDA (RES ARGS) (IF (AND (TEST.ERRORP RES)(EQP (CADR RES) 10)) THEN 'SUCCESS ELSE 'FAILURE] . This test tests whether the function ADD1 breaks with non-numeric arg error. -(TEST.ALL-COMBINATIONS SET-OF-SETS) [function] -Produces the Cartesian product of the sets in the list SET-OF-SETS . (TEST.ALL-COMBINATIONS '((a b)(1 2 3))) will return the list ((a 1)(a 2)(a 3)(b 1)(b 2)(b 3)). This function is used by the tester when it encounter an INPUT field starts with the atom SYSTEMATIC. It is useful in any case that the user wants to build tests that tries all the combinations of possible values of a function arguments, or to have all the possible settings for flags and global variables for some subsystem or library package. -(TEST.LOCAL-EVAL-FORM FORM) [function] -Evaluates the form FORM using ERRORSET, thus the avaluation will not break even if error condition occurs. If error did not occur the function will return the result of the evaluation of form. If error condition was entered, the function will return a list with the first element ERROR!, and the second element the number of the error (as described in Interlisp-D manual. -(TEST.PERFORM-TIMED-EVALUATION FORM TIMEOUT.ms) [function] -Evaluates FORM using TEST.LOCAL-EVAL-FORM (thus it will not break). If the evaluation will take time which is longer then the value of TIMEOUT.ms, the function will return the error expression (ERROR! TIMEEXPIRED). This function is used by the test driver if the TIMEOUT field of a test is non NIL, thus an evaluation that will take more time that the designated time will be considerd as returning with error condition. The function create a seperate process to perform the evaluation, and set a timer for the designated time (plus some time for overhead). The user should note that since the Interlisp-D process schedualing algorithms are non-preemptive, the function is not guarantied to halt. An infinite loop may not release the CPU and then only keyboard interrupt will work. -(TEST.GET-NEXT-AVAILABLE-TESTID ) [function] -The test ids should be unique. That's why the system maintains a file which holds the next available test id. This function access this file and returns the id. -(TEST.GET-AND-INCREASE-NEXT-TESTID ) [function] -This functions returns the next available id as the one above, but also increase this number on the file. this function is called by the function TEST.ADD-TEST which adds a test "officially" to the world. -The Random Generator -The random generator resides on the file RANDOM-GENERATOR.DCOM. The main function is -(TEST.GENERATE-RANDOM OBJECT-SPECIFICATION) [function] -This function is planned to be constantly expanded by the tests builders according to their needs. The OBJECT-SPECIFICATION can be an atom, which should be one of the objects known by the random generator. It can also be a list where the first element is an atom which is one of the known objects, and the rest of the list are modifiers according to the object type. The current list of known objects is : (INTEGER, SPECIAL-INTEGER, BOUND-INTEGER, LARGE-INTEGER, SMALL-INTEGER, BIGNUM, POSITIVE-BIGNUM, SPECIAL-BIGNUM,POSITIVE-POWEROF10-BIGNUM, WINDOW, REGION, SHORT-SIMPLE-LIST, SHORT-SIMPLE-NON-NULL-LIST, SHORT-LIST, LIST-OF-CHARACTERS, CHARACTER, LIST-OF-ITEMS and some more. -Some of the objects have modifiers, like short list which can have a maximum depth as a modifier. A very important object is LIST-OF-ITEMS which can have as its modifier another object specification, thus enable recursive use of the function. Thus you can write (TEST.GENERATE-RANDOOM '(LIST-OF-ITEMS REGION 100 200)) which will produced betwwen 100 and 200 random regions. -Database access -(TEST.GET-LOCKING-USERS TEST-LIST) [function] -TEST-LIST is a list of test numbers or the atom DATABASE. Will return the list of all the users that kas locks to tests in TEST-LIST together with the tests in TEST-LIST that they are locking. If TEST-LIST is the atom DATABASE, the function will return the names of all the users that have locks to any test. -(TEST.OBTAIN-DATABASE-WRITE-LOCK TEST-LIST) [function] -TEST-LIST is as above. The function tries to obtain locks on the list of tests in TEST-LIST. If TEST-LIST is the atom DATABASE, it will try to obtain lock on the whole data base. A lock on a test can be obtained if there is no other user locking the test. A lock to the whole data-base can be obtained if there is no user that locks any test. The function returns the list of all tests that it was able to lock. -(TEST.RELEASE-DATABASE-WRITE-LOCK TEST-LIST) [function] -As above, but releases the locksto the tests in TEST-LIST that are locked by the user. Returns all the tests that it suceeded to release. -(TEST.SEND-RELEASE-REQUESTS TEST-LIST) [function] -TEST-LIST is as above. Sends automatic messages to all the users with locks to the tests in TEST-LIST to release their locks. -(TEST.MARK-AS-CHANGED TEST-NUMBER) [function] -The number of thetests that are being modified using the programs editor are added to the global list TEST.LIST-OF-MODIFIED-TESTS. This can be done by calling this function . -(TEST.UNMARK-AS-CHANGED TEST-NUMBER) [function] -As above, but remove the test from the list. -(TEST.STORE-CHANGED-TESTS) [function] -Stores all the tests in the list of modified tests. -(TEST.STORE-TEST TEST-NUMBER) [function] -Stores the test TEST-NUMBER in the file wit h the name returned by the function TEST.TEST-NUMBER-TO-FILE-NAME, and removes it from the list of changed tests. -(TEST.TEST-NUMBER-TO-FILE-NAME TEST-NUMBER) [function] -Returns a file name on which the test TEST-NUMBER is stored. The directory is the value of the global variable TEST.TEST-DATA-BASE-DIRECTORY. The the root name for test number 45 will be TEST00045. -The Concept Space Browser -To browse a concept space you can either select the submenu "Browse Concept Space", or by calling the function -(TEST.DISPLAY-CONCEPT-SPACE-BROWSER CONCEPT-SPACE REGION/POSITION DEPTH INCLUDE-TESTS) [function] -CONCEPT-SPACE must be of type CONCEPTSPACE. REGION/POSITION can be either a region or a position for the browser window. DEPTH is the depth of the lattice that will be displayed. If INCLUDE-TESTS is non NIL, the tests will be included as part of the displayed graph. Only the first argument is neccessary. -All the operations on concepts are done in PREFIX form - first you select the operation and then the argument (like all Lisp operations). Copy selection from a node will push the list of test numbers belong to this node into the current tty stream. The operations that are available using the concept space browser are: -Copy subtree : Allow you to copy a subtree from one displayed concept space to another one. Will prompt for selection of the new parent node and the root of the subtree. -Add Concept : Prompts for the parent of the new concept and for the name of the new concept. -Delete concept : Deletes the concept selected, and all its children which have the deleted concept as they only parent (and so on recursively). -Add Link : prompts for the superconcept and the subconcept and creates a link between them. -Delete Link : prompts for the superconcept and the subconcept and deletes the linkl between them. -Add test : Adds a test to a concept. Prompts for selection of the concept and for a test number. The test number can be a list of numbers, thus you can copy select tests from any node on any browser window. -Delete test : Will ask you to select a node and will add a menu with all the tests of the node so that you can select those you want to delete. -Edit test : Will ask you for selection of a node and will pop up a menu of all the tests in the selected concept. Will apply the test editor on the selected test. -Display - Display tests on/off : will switch the mode of display. You can either display the graph with the tests as part of it or only with the concepts. -Display - Browse subtree : Will ask you to select a concept and will aply the concept space browser on the subgraph for which the selected node is the root. -Display - Change depth : Will pop up a menu of integers. You can select the depth of the graph being displayed. -Display - Update : Recomputes the graph of the concept space and redisplays it. -Execute tests : Will execute all of the tests or part of the tests of the selected concept. Will pop up a menu to set the execution modes. -Hardcopy tests ; Sends a pretty printed hardcopy of all the tests (or the selecetd tests) of the selected concept. -data base - obtain lock : Tries to obtain lock on all the tests of the selected concept. -data-base - Release lock : Releases all the locks that the user has to tests belongs to the selected concept&H ) && MODERN MODERN MODERNMODERN .–Č<;IPQY[‚fÚ91@eŃ<GŐEœ›9~S[-b2  +I*‰'jJ9#ô,cb$q$—2+u;0˘1ĐW9Ž~289Ł:Œ40ą4-)4, 8Ęoe7A Ą TƒU WÉ † œ}…ZA -€eBUHŻđzş \ No newline at end of file diff --git a/internal/test/Tools/TestExec b/internal/test/Tools/TestExec deleted file mode 100644 index 910b82ce..00000000 --- a/internal/test/Tools/TestExec +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index febfe6e2..00000000 Binary files a/internal/test/Tools/TestExec.LCOM and /dev/null differ diff --git a/internal/test/Tools/TestExec.TEdit b/internal/test/Tools/TestExec.TEdit deleted file mode 100644 index 902c3b3a..00000000 Binary files a/internal/test/Tools/TestExec.TEdit and /dev/null differ diff --git a/internal/test/Tools/TestUtils b/internal/test/Tools/TestUtils deleted file mode 100644 index c21bfe4e..00000000 --- a/internal/test/Tools/TestUtils +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index 55ef7cff..00000000 Binary files a/internal/test/Tools/TestUtils.LCOM and /dev/null differ diff --git a/internal/test/Tools/TestUtils.TEdit b/internal/test/Tools/TestUtils.TEdit deleted file mode 100644 index c2a718b3..00000000 Binary files a/internal/test/Tools/TestUtils.TEdit and /dev/null differ diff --git a/internal/test/Tools/VARBROWSER b/internal/test/Tools/VARBROWSER deleted file mode 100644 index 7ea72e1d..00000000 --- a/internal/test/Tools/VARBROWSER +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index 77a07d3f..00000000 Binary files a/internal/test/Tools/VARBROWSER.LCOM and /dev/null differ diff --git a/internal/test/Tools/sloop.lisp b/internal/test/Tools/sloop.lisp deleted file mode 100644 index b0b86f11..00000000 --- a/internal/test/Tools/sloop.lisp +++ /dev/null @@ -1 +0,0 @@ -;;; -*- 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 index 560426e9..11a8d32e 100644 --- a/internal/test/admin/ManualManual.tedit +++ b/internal/test/admin/ManualManual.tedit @@ -1,206 +1,13 @@ -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 +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 index c8608897..4a4a469a 100644 Binary files a/internal/test/admin/Running-AR-Test-Cases.TEdit 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 index e2d389a3..67569912 100644 --- a/internal/test/env/DEdit/high-level.u +++ b/internal/test/env/DEdit/high-level.u @@ -1 +1,254 @@ -;; 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 +;; 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 + + diff --git a/internal/test/env/DEdit/high-level.u.~1~ b/internal/test/env/DEdit/high-level.u.~1~ index a5abaff6..08a976a2 100644 --- a/internal/test/env/DEdit/high-level.u.~1~ +++ b/internal/test/env/DEdit/high-level.u.~1~ @@ -1 +1,253 @@ -;; 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 +;; 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 + + diff --git a/internal/test/env/DEdit/high-level.u.~2~ b/internal/test/env/DEdit/high-level.u.~2~ index e2d389a3..67569912 100644 --- a/internal/test/env/DEdit/high-level.u.~2~ +++ b/internal/test/env/DEdit/high-level.u.~2~ @@ -1 +1,254 @@ -;; 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 +;; 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 + + diff --git a/internal/test/env/DEdit/report.TEdit b/internal/test/env/DEdit/report.TEdit index 39beb0a0..116a719c 100644 Binary files a/internal/test/env/DEdit/report.TEdit 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 index a61f6a74..9b14830b 100644 --- a/internal/test/env/Debugger/24-DEBUG.UX +++ b/internal/test/env/Debugger/24-DEBUG.UX @@ -1 +1,57 @@ -;; 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 +;; 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 index 38241e17..6a8efb24 100644 --- a/internal/test/env/Debugger/hand/BreakWindow.u +++ b/internal/test/env/Debugger/hand/BreakWindow.u @@ -1,469 +1,3 @@ -;; 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 +;; 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~ index fc12e882..1fd6e93e 100644 --- a/internal/test/env/Debugger/hand/BreakWindow.u.~1~ +++ b/internal/test/env/Debugger/hand/BreakWindow.u.~1~ @@ -1,469 +1,3 @@ -;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. -;; -;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are -;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u - - -(do-test "setup user interaction window" -(unless (fboundp 'do-test-menu-setup) -(load "{Erinyes}tools>do-test-menu.dfasl" t)) -(setq dtmw (do-test-menu-setup "Debugger"))) -(do-test "bring up exec" -(do-test-menu-message dtmw 'low -(concatenate 'string -"From the background menu, bring up a new exec. - -" -"In the exec -" -"(SETQ *PACKAGE* (FIND-PACKAGE 'XCL-TEST))"))) -(do-test-group "STEPPER" -(do-test "call step" -(do-test-menu-message dtmw 'low -(concatenate 'string -"Shift select the following into the exec window. - -" -"(step (defun foo nil (print \"hello\"))) - -" -"You should be prompted by repeating the form and a colon."))) -(do-test "step space" -(do-test-menu-message dtmw 'low -(concatenate 'string -"Type a space in the exec window after the colon. " -"You should see a long progn form followed by a colon." -" - -Type another space. " -"You should see the rest of the first part of the form."))) -(do-test "step Next" -(do-test-menu-message dtmw 'low -(concatenate 'string "Type N in the exec window after the colon. " -"You should see a long lambda form."))) -(do-test "step Debugger (AR 7709)" -(do-test-menu-message dtmw 'low -(concatenate 'string "Type d in the exec window after the colon. " -"You should see a break window."))) -(do-test "step break window OK" -(do-test-menu-message dtmw 'low -(concatenate 'string "Type ok in the break window and hit return. " -"The break window should go a way and" -" you should see a colon."))) -(do-test "step Finish" -(do-test-menu-message dtmw 'low -(concatenate 'string "Type f in the exec widnow after the colon. " -" You should see the word foo three times " -"followed by a new Exec promp."))) -(do-test "step uparrow" -(do-test-menu-message dtmw 'low -(concatenate 'string -"Shift select the following into the exec window. - -" -"(step (defun foo nil (print \"hello\"))) - -" -"You should be prompted by repeating the form and a colon." -" Type an uparrow. - -" -"You should see the word abort and then an exec prompt.")))) -(do-test-group ("EVAL UB OK") -(do-test "menued commands" -(do-test-menu-message dtmw 'low -(concatenate 'string -"In the exec, enter - - IL:*DEBUGGER-MENU-ITEMS* - -" -"You should see (\"EVAL\" \"EDIT\" \"REVERT\" \"^\" \"PROCEED\" \"OK\" \"BT\" \"BT!\" \"?=\")"))) -(do-test "eval create break window" -(do-test-menu-message dtmw 'low -(concatenate 'string "Shift select the following into the exec -" -" (progn (unbreak foo) -" " (defun foo nil (print \"hello\")) -" -" (break-function 'foo))(foo) - -" -"You should then see a break window containing Breakpoint at foo"))) -(do-test "pre eval value" -(do-test-menu-message dtmw 'low -(concatenate 'string -"In the break window, type the VALUE command. - -" -"You should see \"Not yet evaluated.\""))) -(do-test "type eval" -(do-test-menu-message dtmw 'low -(concatenate 'string -"In the break window, type the EVAL command. - -" -"You should see \"hello\""))) -(do-test "menu eval" -(do-test-menu-message dtmw 'low -(concatenate 'string -"Select EVAL from the middle button menu in the break window. - -" -"You should see \"hello\""))) -(do-test "type ub" -(do-test-menu-message dtmw 'low -(concatenate 'string -"In the break window, type the UB command. - -" -"You should see (foo)"))) -(do-test "post eval value" -(do-test-menu-message dtmw 'low -(concatenate 'string -"In the break window, type the VALUE command. - -" -"You should see \"hello\""))) -(do-test "menu OK" -(do-test-menu-message dtmw 'low -(concatenate 'string "Press down the middle button of the mouse " -"in the break window, select the OK command. -" -"The break window should disappear and " -"you should see \"hello\" in the exec.")))) -(do-test-group ("proceed comands") -(do-test "create break window" -(defun foo nil -(proceed-case (break) -(use-value (x) :report -"Provide a value to use as the result" x) -(nil nil :report "Just return NIL"))) -(do-test-menu-message dtmw 'low -(concatenate 'string "In the exec, type (foo) -" -"You should then see a break window containing " -"Break"))) -(do-test "use value PROCEED command from menu" -(do-test-menu-message dtmw 'low -(concatenate 'string "Press down the middle button of the mouse " -"in the break window, " "select the PROCEED command. -" -"You should then see a menu pop up. -" -" Select \"Provide a value to use as the result\" from the menu. - -" -"You should see a request for a value. - -" -"Type a T to the request and hit return." -"The break window should go away and " -"you should see a T in the exec window."))) -(do-test "use value typed PROCEED command" -(do-test-menu-message dtmw 'low -(concatenate 'string "In the exec, type (foo) -" -"in the break window, type the PROCEED command -" -"You should then see a list. -" -" Type the number by the item from the list and hit RETURN -" -"Provide a value to use as the result. - -" -"You should see a request for a value. - -" -"Type a T to the request and hit return." -"The break window should go away and " -"you should see a T in the exec window."))) -(do-test "use value typed PR command" -(do-test-menu-message dtmw 'low -(concatenate 'string "In the exec, type (foo) -" -"in the break window, type the PR command -" -"You should then see a list. -" -" Type the number by the item from the list and hit RETURN -" -"Provide a value to use as the result. - -" -"You should see a request for a value. - -" -"Type a T to the request and hit return." -"The break window should go away and " -"you should see a T in the exec window.")))) -(do-test-group ("RETURN") -(do-test "RETURN T command" -(do-test-menu-message dtmw 'low -(concatenate 'string "In the exec type (foo). " -"In the resulting break window, type the RETURN command. - -" -"The break window should go away and " -"you should see a NIL result in the exec."))) -(do-test "RETURN command" -(do-test-menu-message dtmw 'low -(concatenate 'string "In the exec type (foo). " -"In the resulting break window, type the RETURN T command. - -" -"The break window should go away and " -"you should see a T result in the exec.")))) -(do-test-group ("?= uparrow") -(do-test "?= create break window" -(do-test-menu-message dtmw 'low -(concatenate 'string "Type (foo) to the exec -" -"You should then see a break window "))) -(do-test "type ?=" -(do-test-menu-message dtmw 'low -(concatenate 'string -"In the break window, type the ?= command. - -" -"You should see the two parameters: (break) and a Lexical Environment."))) -(do-test "menu ?=" -(do-test-menu-message dtmw 'low -(concatenate 'string "With the middle button in the break window, " -"select the ?= command. - -" -"You should see the same two parameters."))) -(do-test "BREAKDELIMITER correct default" -(do-test-menu-message dtmw 'low -(concatenate 'string "Enter - -IL:BREAKDELIMITER - -" -"You should see some representation of a " -"carriage return character such as a quoted new line."))) -(do-test "menu ^" -(do-test-menu-message dtmw 'low -(concatenate 'string "With the middle button in the break window, " -"select the ^ command. - -" -"The break window should disappear " -"and the caret should be back in the exec " -"with no value returned.")))) -(do-test-group "BREAK WINDOW" -(do-test "create break window" -(do-test-menu-message dtmw 'low -(concatenate 'string -"In an exec type control B to cause a break. - -" -"You should see a break window pop up."))) -(do-test "type BT" -(do-test-menu-message dtmw 'low -(concatenate 'string "Type the BT command. - -" -"You should see a backtrace scroll by. - -" -"(If the window turns black, just hit a space.)"))) -(do-test "type DBT" -(do-test-menu-message dtmw 'low -(concatenate 'string "Type the DBT command. - -" -"You should see a backtrace window " -"appended to the side of the break window."))) -(do-test "menu BT" -(do-test-menu-message dtmw 'low -(concatenate 'string "From the middle button in the break window," -"choose the BT command. - -" -"You should see a backtrace window " -"appended to the side of the break window."))) -(do-test "type BT!" -(do-test-menu-message dtmw 'low -(concatenate 'string "Type the BT! command. - -" -"You should see a longer backtrace scroll by."))) -(do-test "menu DBT!" -(do-test-menu-message dtmw 'low -(concatenate 'string "Type the DBT! command. - -" -"You should see the detailed backtrace in a " -"window appended to the side of the break window. "))) -(do-test "menu BT!" -(do-test-menu-message dtmw 'low -(concatenate 'string "From the middle button in the break window, " -"choose the BT! command. - -" -"You should see a more detailed backtrace window appear " -"appended to the side of the break window. - -"))) -(do-test "scroll BT!" -(do-test-menu-message dtmw 'low -(concatenate 'string -" You should be able to scroll up and down in the backtrace window."))) -(do-test "BTV command" -(do-test-menu-message dtmw 'low -(concatenate 'string "Type the BTV command. - -" -"You should see an even more detailed " -"backtrace scroll by. - -" -"Terminate scrolling by hitting CTRLe. - -"))) -(do-test "BTV! command" -(do-test-menu-message dtmw 'low -(concatenate 'string "Type the BTV! command. - -" -"You should see an even more detailed backtrace window appear " -"scroll by. Terminate scrolling by hitting CTRLe. - -")))) -(do-test-group ("@ REVERT STOP") -(do-test "@" -(do-test-menu-message dtmw 'low -(concatenate 'string "Enter an at-sign command. - -" "@ - -" -"You should see @ = il:interrupt."))) -(do-test "@ foo" -(do-test-menu-message dtmw 'low -(concatenate 'string "Enter - -" " @ foo - - " -"[Note: space between the @ and foo.] - -" -"You should see FOO not found."))) -(do-test "@ exec-read" -(do-test-menu-message dtmw 'low -(concatenate 'string "Enter - -" " @ exec-read - - " -"You should see @ = il:exec-read."))) -(do-test "@ exec-read / 1 (AR 8062)" -(do-test-menu-message dtmw 'low -(concatenate 'string "Enter - -" " @ exec-read / 1 - - " -"You should see @ = il:exec-read again."))) -(do-test "@ = exec-read (AR 8062)" -(do-test-menu-message dtmw 'low -(concatenate 'string "Enter - -" " @ = exec-read - -" -"You should see @ = il:exec-read again."))) -(do-test "@ number (AR 8062)" -(do-test-menu-message dtmw 'low -(concatenate 'string "Enter - -" " @ 3 - -" -"You should see the name of the third stack item."))) -(do-test "frame window" -(do-test-menu-message dtmw 'low -(concatenate 'string -"In the backtrace window attached to the break window " -"find IL:TTYIN and select it with the left mouse button. - -" -"You should see the frame window for ttyin pop up. "))) -(do-test "menu revert" -(do-test-menu-message dtmw 'low -(concatenate 'string "With the middle button In the break window " -"(not the frame window) , " -"select REVERT from the menu.. - -" -"You should see the break window re-initialize as " -"Breakpoint at IL:TTYIN. "))) -(do-test "STOP" -(do-test-menu-message dtmw 'low -(concatenate 'string "Enter - - STOP - -" -"The break window should disappear " -"and the carot should be back in the exec.")))) -(do-test-group ("*short-backtrace-filter*") -(do-test "*short-backtrace-filter*" -(do-test-menu-message dtmw 'low -(concatenate 'string -"In the exec enter: - - il:*short-backtrace-filter* - -" -"You should see an appropriate predicate name " -"such as xcl::interesting-frame-p.")))) -(do-test-group ("EDIT") -(do-test "EDIT search for editable fn (AR 8137)" -(do-test-menu-message dtmw 'low -(concatenate 'string "In the exec type (foo). " -"Enter EDIT in the resulting break window. - -" -"An editor window for foo should appear. " -"Close the editor window."))) -(do-test "EDIT selected fn (AR 6231)" -(do-test-menu-message dtmw 'low -(concatenate 'string -"In the break window, type the DBT command. - -" -"Select the foo frame from the BT menu window with the mouse. " -"Type EDIT in the break window. " -"An editor window should appear."))) -(do-test "EDIT OK (AR 8139)" -(do-test-menu-message dtmw 'low -(concatenate 'string -"In the editor window, change the (BREAK) to \"hi\"." -" -Close the edit window. -" -"Type OK in the break window. - - " -"\"hi\" should be returned in the exec.")))) -(do-test "AR 7957 Spurious WITH-PROFILE call in DEBUGGER" -(do-test-menu-message dtmw 'low -(concatenate 'string -"Open a new INTERLISP exec from the background menu. - -" -"In that exec type control B to cause a break. - -" -"See that *PACKAGE* is bound to # -" -"Uparrow out of the break window and close the exec."))) -(do-test "close user interaction window" (do-test-menu-cleanup dtmw) t)  -((v(A(l(P(<(X((((9(((G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) HELVETICA 5  ˛ g   ) & 4 -  0/   2*?  58<  D( # D$  E'  D,#  2*<=   b $ ?&E  .+  -  >  +  .  B-), # *& .1  / B5%A'*', + ./;''*', & .*;''*'-   19'.  1;'-  " -)  +K  D- * +:  D%,   -+  +'4  ,%/  C%/  ,2  -.7  D:,  H  ,('  -@2 ! - 0&   &#  & % , # ,  6  898  C4  %0 , $ 0(  1 1-+ & ,A#%  6- : 5/59 -H1Q°zş \ No newline at end of file +;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. ;; ;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are ;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u (do-test "setup user interaction window" (unless (fboundp 'do-test-menu-setup) (load "{Erinyes}tools>do-test-menu.dfasl" t)) (setq dtmw (do-test-menu-setup "Debugger"))) (do-test "bring up exec" (do-test-menu-message dtmw 'low (concatenate 'string "From the background menu, bring up a new exec. " "In the exec " "(SETQ *PACKAGE* (FIND-PACKAGE 'XCL-TEST))"))) (do-test-group "STEPPER" (do-test "call step" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec window. " "(step (defun foo nil (print \"hello\"))) " "You should be prompted by repeating the form and a colon."))) (do-test "step space" (do-test-menu-message dtmw 'low (concatenate 'string "Type a space in the exec window after the colon. " "You should see a long progn form followed by a colon." " Type another space. " "You should see the rest of the first part of the form."))) (do-test "step Next" (do-test-menu-message dtmw 'low (concatenate 'string "Type N in the exec window after the colon. " "You should see a long lambda form."))) (do-test "step Debugger (AR 7709)" (do-test-menu-message dtmw 'low (concatenate 'string "Type d in the exec window after the colon. " "You should see a break window."))) (do-test "step break window OK" (do-test-menu-message dtmw 'low (concatenate 'string "Type ok in the break window and hit return. " "The break window should go a way and" " you should see a colon."))) (do-test "step Finish" (do-test-menu-message dtmw 'low (concatenate 'string "Type f in the exec widnow after the colon. " " You should see the word foo three times " "followed by a new Exec promp."))) (do-test "step uparrow" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec window. " "(step (defun foo nil (print \"hello\"))) " "You should be prompted by repeating the form and a colon." " Type an uparrow. " "You should see the word abort and then an exec prompt.")))) (do-test-group ("EVAL UB OK") (do-test "menued commands" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, enter IL:*DEBUGGER-MENU-ITEMS* " "You should see (\"EVAL\" \"EDIT\" \"REVERT\" \"^\" \"PROCEED\" \"OK\" \"BT\" \"BT!\" \"?=\")"))) (do-test "eval create break window" (do-test-menu-message dtmw 'low (concatenate 'string "Shift select the following into the exec " " (progn (unbreak foo) " " (defun foo nil (print \"hello\")) " " (break-function 'foo))(foo) " "You should then see a break window containing Breakpoint at foo"))) (do-test "pre eval value" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the VALUE command. " "You should see \"Not yet evaluated.\""))) (do-test "type eval" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the EVAL command. " "You should see \"hello\""))) (do-test "menu eval" (do-test-menu-message dtmw 'low (concatenate 'string "Select EVAL from the middle button menu in the break window. " "You should see \"hello\""))) (do-test "type ub" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the UB command. " "You should see (foo)"))) (do-test "post eval value" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the VALUE command. " "You should see \"hello\""))) (do-test "menu OK" (do-test-menu-message dtmw 'low (concatenate 'string "Press down the middle button of the mouse " "in the break window, select the OK command. " "The break window should disappear and " "you should see \"hello\" in the exec.")))) (do-test-group ("proceed comands") (do-test "create break window" (defun foo nil (proceed-case (break) (use-value (x) :report "Provide a value to use as the result" x) (nil nil :report "Just return NIL"))) (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "You should then see a break window containing " "Break"))) (do-test "use value PROCEED command from menu" (do-test-menu-message dtmw 'low (concatenate 'string "Press down the middle button of the mouse " "in the break window, " "select the PROCEED command. " "You should then see a menu pop up. " " Select \"Provide a value to use as the result\" from the menu. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window."))) (do-test "use value typed PROCEED command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "in the break window, type the PROCEED command " "You should then see a list. " " Type the number by the item from the list and hit RETURN " "Provide a value to use as the result. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window."))) (do-test "use value typed PR command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, type (foo) " "in the break window, type the PR command " "You should then see a list. " " Type the number by the item from the list and hit RETURN " "Provide a value to use as the result. " "You should see a request for a value. " "Type a T to the request and hit return." "The break window should go away and " "you should see a T in the exec window.")))) (do-test-group ("RETURN") (do-test "RETURN T command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "In the resulting break window, type the RETURN command. " "The break window should go away and " "you should see a NIL result in the exec."))) (do-test "RETURN command" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "In the resulting break window, type the RETURN T command. " "The break window should go away and " "you should see a T result in the exec.")))) (do-test-group ("?= uparrow") (do-test "?= create break window" (do-test-menu-message dtmw 'low (concatenate 'string "Type (foo) to the exec " "You should then see a break window "))) (do-test "type ?=" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the ?= command. " "You should see the two parameters: (break) and a Lexical Environment."))) (do-test "menu ?=" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button in the break window, " "select the ?= command. " "You should see the same two parameters."))) (do-test "BREAKDELIMITER correct default" (do-test-menu-message dtmw 'low (concatenate 'string "Enter IL:BREAKDELIMITER " "You should see some representation of a " "carriage return character such as a quoted new line."))) (do-test "menu ^" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button in the break window, " "select the ^ command. " "The break window should disappear " "and the caret should be back in the exec " "with no value returned.")))) (do-test-group "BREAK WINDOW" (do-test "create break window" (do-test-menu-message dtmw 'low (concatenate 'string "In an exec type control B to cause a break. " "You should see a break window pop up."))) (do-test "type BT" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BT command. " "You should see a backtrace scroll by. " "(If the window turns black, just hit a space.)"))) (do-test "type DBT" (do-test-menu-message dtmw 'low (concatenate 'string "Type the DBT command. " "You should see a backtrace window " "appended to the side of the break window."))) (do-test "menu BT" (do-test-menu-message dtmw 'low (concatenate 'string "From the middle button in the break window," "choose the BT command. " "You should see a backtrace window " "appended to the side of the break window."))) (do-test "type BT!" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BT! command. " "You should see a longer backtrace scroll by."))) (do-test "menu DBT!" (do-test-menu-message dtmw 'low (concatenate 'string "Type the DBT! command. " "You should see the detailed backtrace in a " "window appended to the side of the break window. "))) (do-test "menu BT!" (do-test-menu-message dtmw 'low (concatenate 'string "From the middle button in the break window, " "choose the BT! command. " "You should see a more detailed backtrace window appear " "appended to the side of the break window. "))) (do-test "scroll BT!" (do-test-menu-message dtmw 'low (concatenate 'string " You should be able to scroll up and down in the backtrace window."))) (do-test "BTV command" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BTV command. " "You should see an even more detailed " "backtrace scroll by. " "Terminate scrolling by hitting CTRLe. "))) (do-test "BTV! command" (do-test-menu-message dtmw 'low (concatenate 'string "Type the BTV! command. " "You should see an even more detailed backtrace window appear " "scroll by. Terminate scrolling by hitting CTRLe. ")))) (do-test-group ("@ REVERT STOP") (do-test "@" (do-test-menu-message dtmw 'low (concatenate 'string "Enter an at-sign command. " "@ " "You should see @ = il:interrupt."))) (do-test "@ foo" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ foo " "[Note: space between the @ and foo.] " "You should see FOO not found."))) (do-test "@ exec-read" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ exec-read " "You should see @ = il:exec-read."))) (do-test "@ exec-read / 1 (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ exec-read / 1 " "You should see @ = il:exec-read again."))) (do-test "@ = exec-read (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ = exec-read " "You should see @ = il:exec-read again."))) (do-test "@ number (AR 8062)" (do-test-menu-message dtmw 'low (concatenate 'string "Enter " " @ 3 " "You should see the name of the third stack item."))) (do-test "frame window" (do-test-menu-message dtmw 'low (concatenate 'string "In the backtrace window attached to the break window " "find IL:TTYIN and select it with the left mouse button. " "You should see the frame window for ttyin pop up. "))) (do-test "menu revert" (do-test-menu-message dtmw 'low (concatenate 'string "With the middle button In the break window " "(not the frame window) , " "select REVERT from the menu.. " "You should see the break window re-initialize as " "Breakpoint at IL:TTYIN. "))) (do-test "STOP" (do-test-menu-message dtmw 'low (concatenate 'string "Enter STOP " "The break window should disappear " "and the carot should be back in the exec.")))) (do-test-group ("*short-backtrace-filter*") (do-test "*short-backtrace-filter*" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec enter: il:*short-backtrace-filter* " "You should see an appropriate predicate name " "such as xcl::interesting-frame-p.")))) (do-test-group ("EDIT") (do-test "EDIT search for editable fn (AR 8137)" (do-test-menu-message dtmw 'low (concatenate 'string "In the exec type (foo). " "Enter EDIT in the resulting break window. " "An editor window for foo should appear. " "Close the editor window."))) (do-test "EDIT selected fn (AR 6231)" (do-test-menu-message dtmw 'low (concatenate 'string "In the break window, type the DBT command. " "Select the foo frame from the BT menu window with the mouse. " "Type EDIT in the break window. " "An editor window should appear."))) (do-test "EDIT OK (AR 8139)" (do-test-menu-message dtmw 'low (concatenate 'string "In the editor window, change the (BREAK) to \"hi\"." " Close the edit window. " "Type OK in the break window. " "\"hi\" should be returned in the exec.")))) (do-test "AR 7957 Spurious WITH-PROFILE call in DEBUGGER" (do-test-menu-message dtmw 'low (concatenate 'string "Open a new INTERLISP exec from the background menu. " "In that exec type control B to cause a break. " "See that *PACKAGE* is bound to # " "Uparrow out of the break window and close the exec."))) (do-test "close user interaction window" (do-test-menu-cleanup dtmw) t)  ((v(A(l(P(<(X((((9(((G9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8)) HELVETICA 5  ˛ g   ) & +4 -  0/   2*?  58<  D( # D$  E'  D,#  2*<=   b $ ?&E  .+  -  >  +  .  B-), # *& .1  / B5%A'*', + ./;''*', & .*;''*'-   19'.  1;'-  " -)  +K  D- * +:  D%,   -+  +'4  ,%/  C%/  ,2  -.7  D:,  H  ,('  -@2 !  0&   +&#  & % , # ,  6  898  C4  %0 , $ 0(  1 1-+ & ,A#%  6- : 5/59 H1Q°zş \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/BreakWindow.u.~2~ b/internal/test/env/Debugger/hand/BreakWindow.u.~2~ index b8dde989..48cc3dd3 100644 --- a/internal/test/env/Debugger/hand/BreakWindow.u.~2~ +++ b/internal/test/env/Debugger/hand/BreakWindow.u.~2~ @@ -1,469 +1,3 @@ -;; 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 +;; 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~ index 38241e17..6a8efb24 100644 --- a/internal/test/env/Debugger/hand/BreakWindow.u.~3~ +++ b/internal/test/env/Debugger/hand/BreakWindow.u.~3~ @@ -1,469 +1,3 @@ -;; 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 +;; 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 index 1e959fb9..0b21b726 100644 --- a/internal/test/env/Debugger/hand/debugger.u +++ b/internal/test/env/Debugger/hand/debugger.u @@ -1,336 +1,14 @@ -;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. -;; -;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are -;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u - - -(do-test "setup user interaction window" -(unless (fboundp 'do-test-menu-setup) -(load "{Eris}tools>do-test-menu.dfasl" t)) -(setq dtmw (do-test-menu-setup "Debugger"))) -(do-test-group -("il:break" :before (progn (unbreak il:ourfn) -(il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) -(do-test "il:break" -(and (il:break il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(unbreak il:ourfn))) -(do-test "il:break of il:broken fns update of il:brokenfns" (unbreak il:ourfn) -(and (il:break il:ourfn) -(il:break il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(unbreak il:ourfn))) -(do-test "il:break of il:advisedfns updating il:brokenfns" -(and (il:defineq (il:ourfn nil nil)) -(not (il:ourfn)) -(il:advise 'il:ourfn 'il:around nil t) -(il:break il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(car (unbreak il:ourfn)))) -(do-test "AR 7618 BREAK :IN broken" -(il:defineq (foo nil (print "foo")) -(bar nil (foo) (print "bar"))) -(il:break (foo :in bar)) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string "In the exec, enter (foo). - -" -"You should see a break window.")) -(unbreak (foo :in bar))))) -(do-test-group -("xcl:break-function" :before (progn (unbreak il:ourfn) -(il:defineq (il:ourfn nil nil))) :after -(unbreak il:ourfn)) -(do-test "simple il:break-function" (unbreak) -(and (break-function 'il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(unbreak il:ourfn))) -(do-test "il:break-function :trace" -(and (break-function 'floor :trace t) -(floor 20 3) -(and (do-test-menu-message dtmw 'low -(concatenate 'string -"You should see a *Trace-Output* window -" -"with a call to floor passed a 20 and a 3 -" -"and returning a 6 and a 2.")) -(eq 'our-fn (car (untrace 'our-fn)))))) -(do-test "il:break-function :when nil (AR 8162)" (break-function 'floor :when nil) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see the result - -" "6 -2 - -" -" and you should NOT see a break window -")) -(untrace 'floor))) -(do-test "il:break-function :when t" (break-function 'floor :when t) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see a break window " -"for Breakpoint at flo0r. - -" -"Type OK to the break window." -" The break window should go away and " -"the exec should show" -" floor returning a 6 and a 2.")) -(unbreak 'floor))) -(do-test "il:break-function :trace nil" (break-function 'floor :trace nil) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see a break window " -"for Breakpoint at floor. - -" -"Type OK to the break window." -" The break window should go away and " -"the exec should show" -" floor returning a 6 and a 2.")) -(unbreak 'floor))) -(do-test "il:break-function :trace :when nil" -(and (break-function 'floor :trace t :when nil) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see the result - -" "6 -2 - -" -"You should not see a new call to floor" -" in the *Trace-Output* window -")) -(untrace 'our-fn)))) -(do-test "il:break-function :when exp (AR 8162)" -(break-function 'floor :when (when nil t)) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see the result - -" "6 -2 - -" -" and you should NOT see a break window -")) -(untrace 'floor)))) -(do-test-group ("HELPFLAG" :after (progn (setq il:helpflag t) -(setq il:helpdepth 7))) -(do-test "*test-mode* :interactive switch on" (setq save.test.mode *test-mode*) -(setq *test-mode* :interactive)) -(do-test "IL:HELPFLAG BREAK!" (setq il:helpflag 'break!) -(proceed-case -(error -"Break test. This is a test, just a test. -Select Proceed from middle button menu.") -(proceed nil :report "Select me!" t))) -(do-test "IL:HELPFLAG NIL" (setq il:helpflag nil) -(prog1 -(not (ignore-errors -(proceed-case -(error -"Break test. This is a test, just a test. -Select Proceed from middle button menu.") -(proceed nil :report "Select me!" nil)))) -(setq il:helpflag t))) -(do-test "restore *test-mode*" (setq *test-mode* save.test.mode)) -(do-test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" (il:settopval il:helpflag nil) -(and (not (il:gettopval il:helpflag)) -(il:settopval il:helpflag t) -(eq t (il:gettopval il:helpflag))))) -(do-test-group ("IL:NLSETQ" :before (setq il:helpflag nil) :after (setq il:helpflag t)) -(do-test "IL:NLSETQ error" (not (il:nlsetq (error "just an error")))) -(do-test "IL:NLSETQ signal error" (not (il:nlsetq (signal 'error)))) -(do-test "AR 7252 IL:NLSETQ SERIOUS-CONDITION" -;; nlsetq should not trap serious-conditions -(expect-errors (serious-condition) (il:nlsetq (signal 'serious-condition))))) -(do-test-group -("unbreak" :before (defun our-fn (x) (values x (not x))) -(defun super-fn nil (our-fn nil) t)) -(do-test "simple unbreak" -(and (il:break our-fn) (unbreak) (not (member 'our-fn il:brokenfns)) -(not (unbreak)))) -(do-test "unbreak of (sub-fn il:in superfn)" (unbreak super-fn) -(and (il:break (our-fn il:in super-fn)) -(unbreak (our-fn il:in super-fn)))) -(do-test "unbreak of (sub-fn in superfn)" (unbreak super-fn) -(and (il:break (our-fn in super-fn)) -(unbreak (our-fn in super-fn)))) -;; the following commented out due to ignore-errors causing -;; do-test-file to abort.: (do-test "unbreak of (sub-fn in -;; superfn)" (unbreak super-fn) (and (il:break (our-fn in -;; super-fn)) (unbreak (our-fn in super-fn)))) (do-test -;; "unbreak of '(sub-fn in superfn)" (unbreak super-fn) (and -;; (il:break (our-fn in super-fn)) (unbreak '(our-fn in -;; super-fn)))) -(do-test "unbreak of '(sub-fn il:in superfn)" (unbreak super-fn) -(and (il:break (our-fn il:in super-fn)) -(unbreak '(our-fn il:in super-fn)))) -;; (do-test "unbreak of '(sub-fn :in superfn)" (unbreak -;; super-fn) (and (il:break (our-fn :in super-fn)) (unbreak -;; '(our-fn :in super-fn)))) (do-test "unbreak0 of '(sub-fn il:in -;; superfn)" (unbreak super-fn) (and (il:break (our-fn il:in -;; super-fn)) (il:unbreak0 '(our-fn il:in super-fn)))) -) -(do-test-group ("il:rebreak" :before (defun our-fn (x) (values x (not x))) -(defun super-fn nil (our-fn nil) t)) -(do-test "simple il:rebreak" -(and (il:break our-fn) -(unbreak our-fn) -(il:rebreak our-fn)))) -(do-test-group ("untrace" :before (defun our-fn (x) (values x (not x))) (untrace)) -(do-test "simple untrace" -(and (trace our-fn) (untrace) (not (untrace)) -(not (member 'our-fn il:brokenfns)))) -(do-test "(untrace) with broken fns" -(and (il:break our-fn) -(not (untrace)) -(member 'our-fn il:brokenfns))) -(do-test "(untrace (sub-fn in super-fn))" -(and (defun our-fn (x) (values x (not x))) -(defun super-fn nil (our-fn nil) t) -(trace (our-fn il:in super-fn)) -(untrace (our-fn il:in super-fn))))) -(do-test-group ("trace" :before (defun our-fn (x) (values x (not x)))) -(do-test "trace il:brokenfns check" (trace our-fn) -(prog1 (member 'our-fn il:brokenfns) -(untrace 'our-fn))) -(do-test "il:broken prop check" (trace our-fn) -(prog1 (get 'our-fn 'il:broken) -(untrace 'our-fn))) -(do-test "simple interpreted trace" (trace our-fn) -(our-fn t) -(and (do-test-menu-message dtmw 'low -(concatenate 'string "Do you see a *Trace-Output* window -" -"with a call to our-fn passed a t -" -"and returning a t nil?")) -(eq 'our-fn (car (untrace 'our-fn))))) -(do-test "simple compiled trace" (trace floor) -(floor 20 3) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string "Do you see a *Trace-Output* window -" -"with a call to floor passed a 20 and a 3 -" -"and returning a 6 and a 2?")) -(untrace 'floor))) -(do-test "trace of subfunction" (defun super-fn nil (our-fn nil) t) -(and (trace (our-fn il:in super-fn)) (super-fn) -(do-test-menu-message dtmw 'low -(concatenate 'string "Do you see a *Trace-Output* window -" -"with a call to our-fn passed a nil -" -"and returning a nil and a t?")) -(untrace (our-fn il:in super-fn))))) -(do-test-group ("advise") -(do-test "simple il:advise il:around of defun" (defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(prog1 (our-fun) (il:unadvise our-fun))) -(do-test "simple il:advise il:around of fn" (il:defineq (our-fn nil nil)) -(il:advise 'our-fn 'il:around t) -(prog1 (our-fn) (il:unadvise our-fn))) -(do-test "il:advise redefined broken defun" (defun our-fun nil nil) -(il:break our-fun) -(defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(prog1 (our-fun) (unbreak our-fun) -(il:unadvise our-fun))) -(do-test "il:advise redefined advised defun (AR 8172)" -(defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(prog1 (our-fun) (il:unadvise our-fun))) -(do-test "il:advise re-defined advised fn" (il:defineq (our-fn nil nil)) -(il:advise 'our-fn 'il:around t) -(il:defineq (our-fn nil nil)) -(il:advise 'our-fn 'il:around t) -(prog1 (our-fn) (il:unadvise our-fn)))) -(do-test-group ("il:unadvise" :before (defun our-fun nil nil) -(il:unadvise our-fun)) -(do-test "simple il:unadvise" (il:advise 'our-fun 'il:around t) -(and (our-fun) (eq 'our-fun (first (il:unadvise our-fun))) -(not (our-fun)))) -(do-test "il:unadvise t" (il:advise 'our-fun 'il:around t) -(and (our-fun) (eq 'our-fun (first (il:unadvise t))) -(not (our-fun))))) -(do-test "close user interaction window" (do-test-menu-cleanup dtmw) t) -STOP -(do-test "Error List condition correspondence" -(dotimes (i 52) -(ignore-errors (il:seterrorn i))) -(print "Select Inspect from the menu that will be appearing.") -(let ((iw (inspect (il:|for| i il:|from| 0 il:|to| 52 -il:|collect| (ignore-errors (il:seterrorn i))) nil -(il:|create| il:position il:xcoord il:_ 10 il:ycoord il:_ 10))) -(result -(do-test-menu-message dtmw 'low -(concatenate 'string -"Does the inspect window have conditions -" -"correctly corresponding to error number + 1 -" -"in the Lyric release notes section 14.10?")))) -(il:closew iw) -result)) -,~,N,:,&,S,k,K,c,Q,4,7,,Œ,™,x,d,,’,€,P,<,L,(,C,1,n,,9,,M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10))  HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8))5˛g)&1-.<!O!;%'!$$ 0#8(. !$& -%(*(S  -(E  -!)"K  -!)".0  -)1+  -(>P!9-*'2 -- -**BM&%XFE/*N9%E@($=%!;:86;6 -A(%6:@;4 K %  S  .& %   * +$ %G3%/ 3 %9"'/ - 9*D0 9$!% G " ) J ! ' D   " # 7  "  " ) I !  ! (>  @ ; ; 5H/ "?  ' 4 )-0 (#°zş \ No newline at end of file +;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. ;; ;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are ;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u (do-test "setup user interaction window" (unless (fboundp 'do-test-menu-setup) (load "{Eris}tools>do-test-menu.dfasl" t)) (setq dtmw (do-test-menu-setup "Debugger"))) (do-test-group ("il:break" :before (progn (unbreak il:ourfn) (il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) (do-test "il:break" (and (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break of il:broken fns update of il:brokenfns" (unbreak il:ourfn) (and (il:break il:ourfn) (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break of il:advisedfns updating il:brokenfns" (and (il:defineq (il:ourfn nil nil)) (not (il:ourfn)) (il:advise 'il:ourfn 'il:around nil t) (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (car (unbreak il:ourfn)))) (do-test "AR 7618 BREAK :IN broken" (il:defineq (foo nil (print "foo")) (bar nil (foo) (print "bar"))) (il:break (foo :in bar)) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, enter (foo). " "You should see a break window.")) (unbreak (foo :in bar))))) (do-test-group ("xcl:break-function" :before (progn (unbreak il:ourfn) (il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) (do-test "simple il:break-function" (unbreak) (and (break-function 'il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break-function :trace" (and (break-function 'floor :trace t) (floor 20 3) (and (do-test-menu-message dtmw 'low (concatenate 'string "You should see a *Trace-Output* window " "with a call to floor passed a 20 and a 3 " "and returning a 6 and a 2.")) (eq 'our-fn (car (untrace 'our-fn)))))) (do-test "il:break-function :when nil (AR 8162)" (break-function 'floor :when nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " " and you should NOT see a break window ")) (untrace 'floor))) (do-test "il:break-function :when t" (break-function 'floor :when t) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see a break window " "for Breakpoint at flo0r. " "Type OK to the break window." " The break window should go away and " "the exec should show" " floor returning a 6 and a 2.")) (unbreak 'floor))) (do-test "il:break-function :trace nil" (break-function 'floor :trace nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see a break window " "for Breakpoint at floor. " "Type OK to the break window." " The break window should go away and " "the exec should show" " floor returning a 6 and a 2.")) (unbreak 'floor))) (do-test "il:break-function :trace :when nil" (and (break-function 'floor :trace t :when nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " "You should not see a new call to floor" " in the *Trace-Output* window ")) (untrace 'our-fn)))) (do-test "il:break-function :when exp (AR 8162)" (break-function 'floor :when (when nil t)) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " " and you should NOT see a break window ")) (untrace 'floor)))) (do-test-group ("HELPFLAG" :after (progn (setq il:helpflag t) (setq il:helpdepth 7))) (do-test "*test-mode* :interactive switch on" (setq save.test.mode *test-mode*) (setq *test-mode* :interactive)) (do-test "IL:HELPFLAG BREAK!" (setq il:helpflag 'break!) (proceed-case (error "Break test. This is a test, just a test. Select Proceed from middle button menu.") (proceed nil :report "Select me!" t))) (do-test "IL:HELPFLAG NIL" (setq il:helpflag nil) (prog1 (not (ignore-errors (proceed-case (error "Break test. This is a test, just a test. Select Proceed from middle button menu.") (proceed nil :report "Select me!" nil)))) (setq il:helpflag t))) (do-test "restore *test-mode*" (setq *test-mode* save.test.mode)) (do-test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" (il:settopval il:helpflag nil) (and (not (il:gettopval il:helpflag)) (il:settopval il:helpflag t) (eq t (il:gettopval il:helpflag))))) (do-test-group ("IL:NLSETQ" :before (setq il:helpflag nil) :after (setq il:helpflag t)) (do-test "IL:NLSETQ error" (not (il:nlsetq (error "just an error")))) (do-test "IL:NLSETQ signal error" (not (il:nlsetq (signal 'error)))) (do-test "AR 7252 IL:NLSETQ SERIOUS-CONDITION" ;; nlsetq should not trap serious-conditions (expect-errors (serious-condition) (il:nlsetq (signal 'serious-condition))))) (do-test-group ("unbreak" :before (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t)) (do-test "simple unbreak" (and (il:break our-fn) (unbreak) (not (member 'our-fn il:brokenfns)) (not (unbreak)))) (do-test "unbreak of (sub-fn il:in superfn)" (unbreak super-fn) (and (il:break (our-fn il:in super-fn)) (unbreak (our-fn il:in super-fn)))) (do-test "unbreak of (sub-fn in superfn)" (unbreak super-fn) (and (il:break (our-fn in super-fn)) (unbreak (our-fn in super-fn)))) ;; the following commented out due to ignore-errors causing ;; do-test-file to abort.: (do-test "unbreak of (sub-fn in ;; superfn)" (unbreak super-fn) (and (il:break (our-fn in ;; super-fn)) (unbreak (our-fn in super-fn)))) (do-test ;; "unbreak of '(sub-fn in superfn)" (unbreak super-fn) (and ;; (il:break (our-fn in super-fn)) (unbreak '(our-fn in ;; super-fn)))) (do-test "unbreak of '(sub-fn il:in superfn)" (unbreak super-fn) (and (il:break (our-fn il:in super-fn)) (unbreak '(our-fn il:in super-fn)))) ;; (do-test "unbreak of '(sub-fn :in superfn)" (unbreak ;; super-fn) (and (il:break (our-fn :in super-fn)) (unbreak ;; '(our-fn :in super-fn)))) (do-test "unbreak0 of '(sub-fn il:in ;; superfn)" (unbreak super-fn) (and (il:break (our-fn il:in ;; super-fn)) (il:unbreak0 '(our-fn il:in super-fn)))) ) (do-test-group ("il:rebreak" :before (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t)) (do-test "simple il:rebreak" (and (il:break our-fn) (unbreak our-fn) (il:rebreak our-fn)))) (do-test-group ("untrace" :before (defun our-fn (x) (values x (not x))) (untrace)) (do-test "simple untrace" (and (trace our-fn) (untrace) (not (untrace)) (not (member 'our-fn il:brokenfns)))) (do-test "(untrace) with broken fns" (and (il:break our-fn) (not (untrace)) (member 'our-fn il:brokenfns))) (do-test "(untrace (sub-fn in super-fn))" (and (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t) (trace (our-fn il:in super-fn)) (untrace (our-fn il:in super-fn))))) (do-test-group ("trace" :before (defun our-fn (x) (values x (not x)))) (do-test "trace il:brokenfns check" (trace our-fn) (prog1 (member 'our-fn il:brokenfns) (untrace 'our-fn))) (do-test "il:broken prop check" (trace our-fn) (prog1 (get 'our-fn 'il:broken) (untrace 'our-fn))) (do-test "simple interpreted trace" (trace our-fn) (our-fn t) (and (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to our-fn passed a t " "and returning a t nil?")) (eq 'our-fn (car (untrace 'our-fn))))) (do-test "simple compiled trace" (trace floor) (floor 20 3) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to floor passed a 20 and a 3 " "and returning a 6 and a 2?")) (untrace 'floor))) (do-test "trace of subfunction" (defun super-fn nil (our-fn nil) t) (and (trace (our-fn il:in super-fn)) (super-fn) (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to our-fn passed a nil " "and returning a nil and a t?")) (untrace (our-fn il:in super-fn))))) (do-test-group ("advise") (do-test "simple il:advise il:around of defun" (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (il:unadvise our-fun))) (do-test "simple il:advise il:around of fn" (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (prog1 (our-fn) (il:unadvise our-fn))) (do-test "il:advise redefined broken defun" (defun our-fun nil nil) (il:break our-fun) (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (unbreak our-fun) (il:unadvise our-fun))) (do-test "il:advise redefined advised defun (AR 8172)" (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (il:unadvise our-fun))) (do-test "il:advise re-defined advised fn" (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (prog1 (our-fn) (il:unadvise our-fn)))) (do-test-group ("il:unadvise" :before (defun our-fun nil nil) (il:unadvise our-fun)) (do-test "simple il:unadvise" (il:advise 'our-fun 'il:around t) (and (our-fun) (eq 'our-fun (first (il:unadvise our-fun))) (not (our-fun)))) (do-test "il:unadvise t" (il:advise 'our-fun 'il:around t) (and (our-fun) (eq 'our-fun (first (il:unadvise t))) (not (our-fun))))) (do-test "close user interaction window" (do-test-menu-cleanup dtmw) t) STOP (do-test "Error List condition correspondence" (dotimes (i 52) (ignore-errors (il:seterrorn i))) (print "Select Inspect from the menu that will be appearing.") (let ((iw (inspect (il:|for| i il:|from| 0 il:|to| 52 il:|collect| (ignore-errors (il:seterrorn i))) nil (il:|create| il:position il:xcoord il:_ 10 il:ycoord il:_ 10))) (result (do-test-menu-message dtmw 'low (concatenate 'string "Does the inspect window have conditions " "correctly corresponding to error number + 1 " "in the Lyric release notes section 14.10?")))) (il:closew iw) result)) ,~,N,:,&,S,k,K,c,Q,4,7,,Œ,™,x,d,,’,€,P,<,L,(,C,1,n,,9,,M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10)) + HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8))5˛g)&1-.<!O!;%'!$$ 0#8(. !$& %(*(S  (E  !)"K  !)".0  )1+  (>P!9-*'2 - **BM&%XFE/*N9%E@($=%!;:86;6 A(%6:@;4 K % + S + .& +%   +* +$ %G3%/ 3 %9"'/  9*D0 9$!% +G " ) +J ! ' +D   " # +7  "  " ) +I !  ! (>  +@ ; +; 5H/ +"?  ' 4 )-0 (#°zş \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/debugger.u.~1~ b/internal/test/env/Debugger/hand/debugger.u.~1~ index fda95a3e..e35c5ef4 100644 --- a/internal/test/env/Debugger/hand/debugger.u.~1~ +++ b/internal/test/env/Debugger/hand/debugger.u.~1~ @@ -1,336 +1,14 @@ -;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. -;; -;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are -;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u - - -(do-test "setup user interaction window" -(unless (fboundp 'do-test-menu-setup) -(load "{Erinyes}tools>do-test-menu.dfasl" t)) -(setq dtmw (do-test-menu-setup "Debugger"))) -(do-test-group -("il:break" :before (progn (unbreak il:ourfn) -(il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) -(do-test "il:break" -(and (il:break il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(unbreak il:ourfn))) -(do-test "il:break of il:broken fns update of il:brokenfns" (unbreak il:ourfn) -(and (il:break il:ourfn) -(il:break il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(unbreak il:ourfn))) -(do-test "il:break of il:advisedfns updating il:brokenfns" -(and (il:defineq (il:ourfn nil nil)) -(not (il:ourfn)) -(il:advise 'il:ourfn 'il:around nil t) -(il:break il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(car (unbreak il:ourfn)))) -(do-test "AR 7618 BREAK :IN broken" -(il:defineq (foo nil (print "foo")) -(bar nil (foo) (print "bar"))) -(il:break (foo :in bar)) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string "In the exec, enter (foo). - -" -"You should see a break window.")) -(unbreak (foo :in bar))))) -(do-test-group -("xcl:break-function" :before (progn (unbreak il:ourfn) -(il:defineq (il:ourfn nil nil))) :after -(unbreak il:ourfn)) -(do-test "simple il:break-function" (unbreak) -(and (break-function 'il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(unbreak il:ourfn))) -(do-test "il:break-function :trace" -(and (break-function 'floor :trace t) -(floor 20 3) -(and (do-test-menu-message dtmw 'low -(concatenate 'string -"You should see a *Trace-Output* window -" -"with a call to floor passed a 20 and a 3 -" -"and returning a 6 and a 2.")) -(eq 'our-fn (car (untrace 'our-fn)))))) -(do-test "il:break-function :when nil (AR 8162)" (break-function 'floor :when nil) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see the result - -" "6 -2 - -" -" and you should NOT see a break window -")) -(untrace 'floor))) -(do-test "il:break-function :when t" (break-function 'floor :when t) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see a break window " -"for Breakpoint at flo0r. - -" -"Type OK to the break window." -" The break window should go away and " -"the exec should show" -" floor returning a 6 and a 2.")) -(unbreak 'floor))) -(do-test "il:break-function :trace nil" (break-function 'floor :trace nil) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see a break window " -"for Breakpoint at floor. - -" -"Type OK to the break window." -" The break window should go away and " -"the exec should show" -" floor returning a 6 and a 2.")) -(unbreak 'floor))) -(do-test "il:break-function :trace :when nil" -(and (break-function 'floor :trace t :when nil) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see the result - -" "6 -2 - -" -"You should not see a new call to floor" -" in the *Trace-Output* window -")) -(untrace 'our-fn)))) -(do-test "il:break-function :when exp (AR 8162)" -(break-function 'floor :when (when nil t)) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see the result - -" "6 -2 - -" -" and you should NOT see a break window -")) -(untrace 'floor)))) -(do-test-group ("HELPFLAG" :after (progn (setq il:helpflag t) -(setq il:helpdepth 7))) -(do-test "*test-mode* :interactive switch on" (setq save.test.mode *test-mode*) -(setq *test-mode* :interactive)) -(do-test "IL:HELPFLAG BREAK!" (setq il:helpflag 'break!) -(proceed-case -(error -"Break test. This is a test, just a test. -Select Proceed from middle button menu.") -(proceed nil :report "Select me!" t))) -(do-test "IL:HELPFLAG NIL" (setq il:helpflag nil) -(prog1 -(not (ignore-errors -(proceed-case -(error -"Break test. This is a test, just a test. -Select Proceed from middle button menu.") -(proceed nil :report "Select me!" nil)))) -(setq il:helpflag t))) -(do-test "restore *test-mode*" (setq *test-mode* save.test.mode)) -(do-test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" (il:settopval il:helpflag nil) -(and (not (il:gettopval il:helpflag)) -(il:settopval il:helpflag t) -(eq t (il:gettopval il:helpflag))))) -(do-test-group ("IL:NLSETQ" :before (setq il:helpflag nil) :after (setq il:helpflag t)) -(do-test "IL:NLSETQ error" (not (il:nlsetq (error "just an error")))) -(do-test "IL:NLSETQ signal error" (not (il:nlsetq (signal 'error)))) -(do-test "AR 7252 IL:NLSETQ SERIOUS-CONDITION" -;; nlsetq should not trap serious-conditions -(expect-errors (serious-condition) (il:nlsetq (signal 'serious-condition))))) -(do-test-group -("unbreak" :before (defun our-fn (x) (values x (not x))) -(defun super-fn nil (our-fn nil) t)) -(do-test "simple unbreak" -(and (il:break our-fn) (unbreak) (not (member 'our-fn il:brokenfns)) -(not (unbreak)))) -(do-test "unbreak of (sub-fn il:in superfn)" (unbreak super-fn) -(and (il:break (our-fn il:in super-fn)) -(unbreak (our-fn il:in super-fn)))) -(do-test "unbreak of (sub-fn in superfn)" (unbreak super-fn) -(and (il:break (our-fn in super-fn)) -(unbreak (our-fn in super-fn)))) -;; the following commented out due to ignore-errors causing -;; do-test-file to abort.: (do-test "unbreak of (sub-fn in -;; superfn)" (unbreak super-fn) (and (il:break (our-fn in -;; super-fn)) (unbreak (our-fn in super-fn)))) (do-test -;; "unbreak of '(sub-fn in superfn)" (unbreak super-fn) (and -;; (il:break (our-fn in super-fn)) (unbreak '(our-fn in -;; super-fn)))) -(do-test "unbreak of '(sub-fn il:in superfn)" (unbreak super-fn) -(and (il:break (our-fn il:in super-fn)) -(unbreak '(our-fn il:in super-fn)))) -;; (do-test "unbreak of '(sub-fn :in superfn)" (unbreak -;; super-fn) (and (il:break (our-fn :in super-fn)) (unbreak -;; '(our-fn :in super-fn)))) (do-test "unbreak0 of '(sub-fn il:in -;; superfn)" (unbreak super-fn) (and (il:break (our-fn il:in -;; super-fn)) (il:unbreak0 '(our-fn il:in super-fn)))) -) -(do-test-group ("il:rebreak" :before (defun our-fn (x) (values x (not x))) -(defun super-fn nil (our-fn nil) t)) -(do-test "simple il:rebreak" -(and (il:break our-fn) -(unbreak our-fn) -(il:rebreak our-fn)))) -(do-test-group ("untrace" :before (defun our-fn (x) (values x (not x))) (untrace)) -(do-test "simple untrace" -(and (trace our-fn) (untrace) (not (untrace)) -(not (member 'our-fn il:brokenfns)))) -(do-test "(untrace) with broken fns" -(and (il:break our-fn) -(not (untrace)) -(member 'our-fn il:brokenfns))) -(do-test "(untrace (sub-fn in super-fn))" -(and (defun our-fn (x) (values x (not x))) -(defun super-fn nil (our-fn nil) t) -(trace (our-fn il:in super-fn)) -(untrace (our-fn il:in super-fn))))) -(do-test-group ("trace" :before (defun our-fn (x) (values x (not x)))) -(do-test "trace il:brokenfns check" (trace our-fn) -(prog1 (member 'our-fn il:brokenfns) -(untrace 'our-fn))) -(do-test "il:broken prop check" (trace our-fn) -(prog1 (get 'our-fn 'il:broken) -(untrace 'our-fn))) -(do-test "simple interpreted trace" (trace our-fn) -(our-fn t) -(and (do-test-menu-message dtmw 'low -(concatenate 'string "Do you see a *Trace-Output* window -" -"with a call to our-fn passed a t -" -"and returning a t nil?")) -(eq 'our-fn (car (untrace 'our-fn))))) -(do-test "simple compiled trace" (trace floor) -(floor 20 3) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string "Do you see a *Trace-Output* window -" -"with a call to floor passed a 20 and a 3 -" -"and returning a 6 and a 2?")) -(untrace 'floor))) -(do-test "trace of subfunction" (defun super-fn nil (our-fn nil) t) -(and (trace (our-fn il:in super-fn)) (super-fn) -(do-test-menu-message dtmw 'low -(concatenate 'string "Do you see a *Trace-Output* window -" -"with a call to our-fn passed a nil -" -"and returning a nil and a t?")) -(untrace (our-fn il:in super-fn))))) -(do-test-group ("advise") -(do-test "simple il:advise il:around of defun" (defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(prog1 (our-fun) (il:unadvise our-fun))) -(do-test "simple il:advise il:around of fn" (il:defineq (our-fn nil nil)) -(il:advise 'our-fn 'il:around t) -(prog1 (our-fn) (il:unadvise our-fn))) -(do-test "il:advise redefined broken defun" (defun our-fun nil nil) -(il:break our-fun) -(defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(prog1 (our-fun) (unbreak our-fun) -(il:unadvise our-fun))) -(do-test "il:advise redefined advised defun (AR 8172)" -(defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(prog1 (our-fun) (il:unadvise our-fun))) -(do-test "il:advise re-defined advised fn" (il:defineq (our-fn nil nil)) -(il:advise 'our-fn 'il:around t) -(il:defineq (our-fn nil nil)) -(il:advise 'our-fn 'il:around t) -(prog1 (our-fn) (il:unadvise our-fn)))) -(do-test-group ("il:unadvise" :before (defun our-fun nil nil) -(il:unadvise our-fun)) -(do-test "simple il:unadvise" (il:advise 'our-fun 'il:around t) -(and (our-fun) (eq 'our-fun (first (il:unadvise our-fun))) -(not (our-fun)))) -(do-test "il:unadvise t" (il:advise 'our-fun 'il:around t) -(and (our-fun) (eq 'our-fun (first (il:unadvise t))) -(not (our-fun))))) -(do-test "close user interaction window" (do-test-menu-cleanup dtmw) t) -STOP -(do-test "Error List condition correspondence" -(dotimes (i 52) -(ignore-errors (il:seterrorn i))) -(print "Select Inspect from the menu that will be appearing.") -(let ((iw (inspect (il:|for| i il:|from| 0 il:|to| 52 -il:|collect| (ignore-errors (il:seterrorn i))) nil -(il:|create| il:position il:xcoord il:_ 10 il:ycoord il:_ 10))) -(result -(do-test-menu-message dtmw 'low -(concatenate 'string -"Does the inspect window have conditions -" -"correctly corresponding to error number + 1 -" -"in the Lyric release notes section 14.10?")))) -(il:closew iw) -result)) -(~(N(:(&(S(k(K(c(Q(4(7((Œ(™(x(d((’(€(P(<(L(((C(1(n((9((M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10))  HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8))5˛g)&4-.<!O!;%'!$$ 0#8(. !$& -%(*(S  -(E  -!)"K  -!)".0  -)1+  -(>P!9-*'2 -- -**BM&%XFE/*N9%E@($=%!;:86;6 -A(%6:@;4 K %  S  .& %   * +$ %G3%/ 3 %9"'/ - 9*D0 9$!% G " ) J ! ' D   " # 7  "  " ) I !  ! (>  @ ; ; 5H/ "?  ' 4 )-0 (&°zş \ No newline at end of file +;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. ;; ;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are ;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u (do-test "setup user interaction window" (unless (fboundp 'do-test-menu-setup) (load "{Erinyes}tools>do-test-menu.dfasl" t)) (setq dtmw (do-test-menu-setup "Debugger"))) (do-test-group ("il:break" :before (progn (unbreak il:ourfn) (il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) (do-test "il:break" (and (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break of il:broken fns update of il:brokenfns" (unbreak il:ourfn) (and (il:break il:ourfn) (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break of il:advisedfns updating il:brokenfns" (and (il:defineq (il:ourfn nil nil)) (not (il:ourfn)) (il:advise 'il:ourfn 'il:around nil t) (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (car (unbreak il:ourfn)))) (do-test "AR 7618 BREAK :IN broken" (il:defineq (foo nil (print "foo")) (bar nil (foo) (print "bar"))) (il:break (foo :in bar)) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, enter (foo). " "You should see a break window.")) (unbreak (foo :in bar))))) (do-test-group ("xcl:break-function" :before (progn (unbreak il:ourfn) (il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) (do-test "simple il:break-function" (unbreak) (and (break-function 'il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break-function :trace" (and (break-function 'floor :trace t) (floor 20 3) (and (do-test-menu-message dtmw 'low (concatenate 'string "You should see a *Trace-Output* window " "with a call to floor passed a 20 and a 3 " "and returning a 6 and a 2.")) (eq 'our-fn (car (untrace 'our-fn)))))) (do-test "il:break-function :when nil (AR 8162)" (break-function 'floor :when nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " " and you should NOT see a break window ")) (untrace 'floor))) (do-test "il:break-function :when t" (break-function 'floor :when t) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see a break window " "for Breakpoint at flo0r. " "Type OK to the break window." " The break window should go away and " "the exec should show" " floor returning a 6 and a 2.")) (unbreak 'floor))) (do-test "il:break-function :trace nil" (break-function 'floor :trace nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see a break window " "for Breakpoint at floor. " "Type OK to the break window." " The break window should go away and " "the exec should show" " floor returning a 6 and a 2.")) (unbreak 'floor))) (do-test "il:break-function :trace :when nil" (and (break-function 'floor :trace t :when nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " "You should not see a new call to floor" " in the *Trace-Output* window ")) (untrace 'our-fn)))) (do-test "il:break-function :when exp (AR 8162)" (break-function 'floor :when (when nil t)) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " " and you should NOT see a break window ")) (untrace 'floor)))) (do-test-group ("HELPFLAG" :after (progn (setq il:helpflag t) (setq il:helpdepth 7))) (do-test "*test-mode* :interactive switch on" (setq save.test.mode *test-mode*) (setq *test-mode* :interactive)) (do-test "IL:HELPFLAG BREAK!" (setq il:helpflag 'break!) (proceed-case (error "Break test. This is a test, just a test. Select Proceed from middle button menu.") (proceed nil :report "Select me!" t))) (do-test "IL:HELPFLAG NIL" (setq il:helpflag nil) (prog1 (not (ignore-errors (proceed-case (error "Break test. This is a test, just a test. Select Proceed from middle button menu.") (proceed nil :report "Select me!" nil)))) (setq il:helpflag t))) (do-test "restore *test-mode*" (setq *test-mode* save.test.mode)) (do-test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" (il:settopval il:helpflag nil) (and (not (il:gettopval il:helpflag)) (il:settopval il:helpflag t) (eq t (il:gettopval il:helpflag))))) (do-test-group ("IL:NLSETQ" :before (setq il:helpflag nil) :after (setq il:helpflag t)) (do-test "IL:NLSETQ error" (not (il:nlsetq (error "just an error")))) (do-test "IL:NLSETQ signal error" (not (il:nlsetq (signal 'error)))) (do-test "AR 7252 IL:NLSETQ SERIOUS-CONDITION" ;; nlsetq should not trap serious-conditions (expect-errors (serious-condition) (il:nlsetq (signal 'serious-condition))))) (do-test-group ("unbreak" :before (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t)) (do-test "simple unbreak" (and (il:break our-fn) (unbreak) (not (member 'our-fn il:brokenfns)) (not (unbreak)))) (do-test "unbreak of (sub-fn il:in superfn)" (unbreak super-fn) (and (il:break (our-fn il:in super-fn)) (unbreak (our-fn il:in super-fn)))) (do-test "unbreak of (sub-fn in superfn)" (unbreak super-fn) (and (il:break (our-fn in super-fn)) (unbreak (our-fn in super-fn)))) ;; the following commented out due to ignore-errors causing ;; do-test-file to abort.: (do-test "unbreak of (sub-fn in ;; superfn)" (unbreak super-fn) (and (il:break (our-fn in ;; super-fn)) (unbreak (our-fn in super-fn)))) (do-test ;; "unbreak of '(sub-fn in superfn)" (unbreak super-fn) (and ;; (il:break (our-fn in super-fn)) (unbreak '(our-fn in ;; super-fn)))) (do-test "unbreak of '(sub-fn il:in superfn)" (unbreak super-fn) (and (il:break (our-fn il:in super-fn)) (unbreak '(our-fn il:in super-fn)))) ;; (do-test "unbreak of '(sub-fn :in superfn)" (unbreak ;; super-fn) (and (il:break (our-fn :in super-fn)) (unbreak ;; '(our-fn :in super-fn)))) (do-test "unbreak0 of '(sub-fn il:in ;; superfn)" (unbreak super-fn) (and (il:break (our-fn il:in ;; super-fn)) (il:unbreak0 '(our-fn il:in super-fn)))) ) (do-test-group ("il:rebreak" :before (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t)) (do-test "simple il:rebreak" (and (il:break our-fn) (unbreak our-fn) (il:rebreak our-fn)))) (do-test-group ("untrace" :before (defun our-fn (x) (values x (not x))) (untrace)) (do-test "simple untrace" (and (trace our-fn) (untrace) (not (untrace)) (not (member 'our-fn il:brokenfns)))) (do-test "(untrace) with broken fns" (and (il:break our-fn) (not (untrace)) (member 'our-fn il:brokenfns))) (do-test "(untrace (sub-fn in super-fn))" (and (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t) (trace (our-fn il:in super-fn)) (untrace (our-fn il:in super-fn))))) (do-test-group ("trace" :before (defun our-fn (x) (values x (not x)))) (do-test "trace il:brokenfns check" (trace our-fn) (prog1 (member 'our-fn il:brokenfns) (untrace 'our-fn))) (do-test "il:broken prop check" (trace our-fn) (prog1 (get 'our-fn 'il:broken) (untrace 'our-fn))) (do-test "simple interpreted trace" (trace our-fn) (our-fn t) (and (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to our-fn passed a t " "and returning a t nil?")) (eq 'our-fn (car (untrace 'our-fn))))) (do-test "simple compiled trace" (trace floor) (floor 20 3) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to floor passed a 20 and a 3 " "and returning a 6 and a 2?")) (untrace 'floor))) (do-test "trace of subfunction" (defun super-fn nil (our-fn nil) t) (and (trace (our-fn il:in super-fn)) (super-fn) (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to our-fn passed a nil " "and returning a nil and a t?")) (untrace (our-fn il:in super-fn))))) (do-test-group ("advise") (do-test "simple il:advise il:around of defun" (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (il:unadvise our-fun))) (do-test "simple il:advise il:around of fn" (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (prog1 (our-fn) (il:unadvise our-fn))) (do-test "il:advise redefined broken defun" (defun our-fun nil nil) (il:break our-fun) (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (unbreak our-fun) (il:unadvise our-fun))) (do-test "il:advise redefined advised defun (AR 8172)" (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (il:unadvise our-fun))) (do-test "il:advise re-defined advised fn" (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (prog1 (our-fn) (il:unadvise our-fn)))) (do-test-group ("il:unadvise" :before (defun our-fun nil nil) (il:unadvise our-fun)) (do-test "simple il:unadvise" (il:advise 'our-fun 'il:around t) (and (our-fun) (eq 'our-fun (first (il:unadvise our-fun))) (not (our-fun)))) (do-test "il:unadvise t" (il:advise 'our-fun 'il:around t) (and (our-fun) (eq 'our-fun (first (il:unadvise t))) (not (our-fun))))) (do-test "close user interaction window" (do-test-menu-cleanup dtmw) t) STOP (do-test "Error List condition correspondence" (dotimes (i 52) (ignore-errors (il:seterrorn i))) (print "Select Inspect from the menu that will be appearing.") (let ((iw (inspect (il:|for| i il:|from| 0 il:|to| 52 il:|collect| (ignore-errors (il:seterrorn i))) nil (il:|create| il:position il:xcoord il:_ 10 il:ycoord il:_ 10))) (result (do-test-menu-message dtmw 'low (concatenate 'string "Does the inspect window have conditions " "correctly corresponding to error number + 1 " "in the Lyric release notes section 14.10?")))) (il:closew iw) result)) (~(N(:(&(S(k(K(c(Q(4(7((Œ(™(x(d((’(€(P(<(L(((C(1(n((9((M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10)) + HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8))5˛g)&4-.<!O!;%'!$$ 0#8(. !$& %(*(S  (E  !)"K  !)".0  )1+  (>P!9-*'2 - **BM&%XFE/*N9%E@($=%!;:86;6 A(%6:@;4 K % + S + .& +%   +* +$ %G3%/ 3 %9"'/  9*D0 9$!% +G " ) +J ! ' +D   " # +7  "  " ) +I !  ! (>  +@ ; +; 5H/ +"?  ' 4 )-0 (&°zş \ No newline at end of file diff --git a/internal/test/env/Debugger/hand/debugger.u.~2~ b/internal/test/env/Debugger/hand/debugger.u.~2~ index 1e959fb9..0b21b726 100644 --- a/internal/test/env/Debugger/hand/debugger.u.~2~ +++ b/internal/test/env/Debugger/hand/debugger.u.~2~ @@ -1,336 +1,14 @@ -;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. -;; -;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are -;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u - - -(do-test "setup user interaction window" -(unless (fboundp 'do-test-menu-setup) -(load "{Eris}tools>do-test-menu.dfasl" t)) -(setq dtmw (do-test-menu-setup "Debugger"))) -(do-test-group -("il:break" :before (progn (unbreak il:ourfn) -(il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) -(do-test "il:break" -(and (il:break il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(unbreak il:ourfn))) -(do-test "il:break of il:broken fns update of il:brokenfns" (unbreak il:ourfn) -(and (il:break il:ourfn) -(il:break il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(unbreak il:ourfn))) -(do-test "il:break of il:advisedfns updating il:brokenfns" -(and (il:defineq (il:ourfn nil nil)) -(not (il:ourfn)) -(il:advise 'il:ourfn 'il:around nil t) -(il:break il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(car (unbreak il:ourfn)))) -(do-test "AR 7618 BREAK :IN broken" -(il:defineq (foo nil (print "foo")) -(bar nil (foo) (print "bar"))) -(il:break (foo :in bar)) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string "In the exec, enter (foo). - -" -"You should see a break window.")) -(unbreak (foo :in bar))))) -(do-test-group -("xcl:break-function" :before (progn (unbreak il:ourfn) -(il:defineq (il:ourfn nil nil))) :after -(unbreak il:ourfn)) -(do-test "simple il:break-function" (unbreak) -(and (break-function 'il:ourfn) -(il:memb 'il:ourfn il:brokenfns) -(unbreak il:ourfn))) -(do-test "il:break-function :trace" -(and (break-function 'floor :trace t) -(floor 20 3) -(and (do-test-menu-message dtmw 'low -(concatenate 'string -"You should see a *Trace-Output* window -" -"with a call to floor passed a 20 and a 3 -" -"and returning a 6 and a 2.")) -(eq 'our-fn (car (untrace 'our-fn)))))) -(do-test "il:break-function :when nil (AR 8162)" (break-function 'floor :when nil) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see the result - -" "6 -2 - -" -" and you should NOT see a break window -")) -(untrace 'floor))) -(do-test "il:break-function :when t" (break-function 'floor :when t) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see a break window " -"for Breakpoint at flo0r. - -" -"Type OK to the break window." -" The break window should go away and " -"the exec should show" -" floor returning a 6 and a 2.")) -(unbreak 'floor))) -(do-test "il:break-function :trace nil" (break-function 'floor :trace nil) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see a break window " -"for Breakpoint at floor. - -" -"Type OK to the break window." -" The break window should go away and " -"the exec should show" -" floor returning a 6 and a 2.")) -(unbreak 'floor))) -(do-test "il:break-function :trace :when nil" -(and (break-function 'floor :trace t :when nil) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see the result - -" "6 -2 - -" -"You should not see a new call to floor" -" in the *Trace-Output* window -")) -(untrace 'our-fn)))) -(do-test "il:break-function :when exp (AR 8162)" -(break-function 'floor :when (when nil t)) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string -"Enter - -(floor 20 3) - -to the exec. - -" -"You should see the result - -" "6 -2 - -" -" and you should NOT see a break window -")) -(untrace 'floor)))) -(do-test-group ("HELPFLAG" :after (progn (setq il:helpflag t) -(setq il:helpdepth 7))) -(do-test "*test-mode* :interactive switch on" (setq save.test.mode *test-mode*) -(setq *test-mode* :interactive)) -(do-test "IL:HELPFLAG BREAK!" (setq il:helpflag 'break!) -(proceed-case -(error -"Break test. This is a test, just a test. -Select Proceed from middle button menu.") -(proceed nil :report "Select me!" t))) -(do-test "IL:HELPFLAG NIL" (setq il:helpflag nil) -(prog1 -(not (ignore-errors -(proceed-case -(error -"Break test. This is a test, just a test. -Select Proceed from middle button menu.") -(proceed nil :report "Select me!" nil)))) -(setq il:helpflag t))) -(do-test "restore *test-mode*" (setq *test-mode* save.test.mode)) -(do-test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" (il:settopval il:helpflag nil) -(and (not (il:gettopval il:helpflag)) -(il:settopval il:helpflag t) -(eq t (il:gettopval il:helpflag))))) -(do-test-group ("IL:NLSETQ" :before (setq il:helpflag nil) :after (setq il:helpflag t)) -(do-test "IL:NLSETQ error" (not (il:nlsetq (error "just an error")))) -(do-test "IL:NLSETQ signal error" (not (il:nlsetq (signal 'error)))) -(do-test "AR 7252 IL:NLSETQ SERIOUS-CONDITION" -;; nlsetq should not trap serious-conditions -(expect-errors (serious-condition) (il:nlsetq (signal 'serious-condition))))) -(do-test-group -("unbreak" :before (defun our-fn (x) (values x (not x))) -(defun super-fn nil (our-fn nil) t)) -(do-test "simple unbreak" -(and (il:break our-fn) (unbreak) (not (member 'our-fn il:brokenfns)) -(not (unbreak)))) -(do-test "unbreak of (sub-fn il:in superfn)" (unbreak super-fn) -(and (il:break (our-fn il:in super-fn)) -(unbreak (our-fn il:in super-fn)))) -(do-test "unbreak of (sub-fn in superfn)" (unbreak super-fn) -(and (il:break (our-fn in super-fn)) -(unbreak (our-fn in super-fn)))) -;; the following commented out due to ignore-errors causing -;; do-test-file to abort.: (do-test "unbreak of (sub-fn in -;; superfn)" (unbreak super-fn) (and (il:break (our-fn in -;; super-fn)) (unbreak (our-fn in super-fn)))) (do-test -;; "unbreak of '(sub-fn in superfn)" (unbreak super-fn) (and -;; (il:break (our-fn in super-fn)) (unbreak '(our-fn in -;; super-fn)))) -(do-test "unbreak of '(sub-fn il:in superfn)" (unbreak super-fn) -(and (il:break (our-fn il:in super-fn)) -(unbreak '(our-fn il:in super-fn)))) -;; (do-test "unbreak of '(sub-fn :in superfn)" (unbreak -;; super-fn) (and (il:break (our-fn :in super-fn)) (unbreak -;; '(our-fn :in super-fn)))) (do-test "unbreak0 of '(sub-fn il:in -;; superfn)" (unbreak super-fn) (and (il:break (our-fn il:in -;; super-fn)) (il:unbreak0 '(our-fn il:in super-fn)))) -) -(do-test-group ("il:rebreak" :before (defun our-fn (x) (values x (not x))) -(defun super-fn nil (our-fn nil) t)) -(do-test "simple il:rebreak" -(and (il:break our-fn) -(unbreak our-fn) -(il:rebreak our-fn)))) -(do-test-group ("untrace" :before (defun our-fn (x) (values x (not x))) (untrace)) -(do-test "simple untrace" -(and (trace our-fn) (untrace) (not (untrace)) -(not (member 'our-fn il:brokenfns)))) -(do-test "(untrace) with broken fns" -(and (il:break our-fn) -(not (untrace)) -(member 'our-fn il:brokenfns))) -(do-test "(untrace (sub-fn in super-fn))" -(and (defun our-fn (x) (values x (not x))) -(defun super-fn nil (our-fn nil) t) -(trace (our-fn il:in super-fn)) -(untrace (our-fn il:in super-fn))))) -(do-test-group ("trace" :before (defun our-fn (x) (values x (not x)))) -(do-test "trace il:brokenfns check" (trace our-fn) -(prog1 (member 'our-fn il:brokenfns) -(untrace 'our-fn))) -(do-test "il:broken prop check" (trace our-fn) -(prog1 (get 'our-fn 'il:broken) -(untrace 'our-fn))) -(do-test "simple interpreted trace" (trace our-fn) -(our-fn t) -(and (do-test-menu-message dtmw 'low -(concatenate 'string "Do you see a *Trace-Output* window -" -"with a call to our-fn passed a t -" -"and returning a t nil?")) -(eq 'our-fn (car (untrace 'our-fn))))) -(do-test "simple compiled trace" (trace floor) -(floor 20 3) -(prog1 -(do-test-menu-message dtmw 'low -(concatenate 'string "Do you see a *Trace-Output* window -" -"with a call to floor passed a 20 and a 3 -" -"and returning a 6 and a 2?")) -(untrace 'floor))) -(do-test "trace of subfunction" (defun super-fn nil (our-fn nil) t) -(and (trace (our-fn il:in super-fn)) (super-fn) -(do-test-menu-message dtmw 'low -(concatenate 'string "Do you see a *Trace-Output* window -" -"with a call to our-fn passed a nil -" -"and returning a nil and a t?")) -(untrace (our-fn il:in super-fn))))) -(do-test-group ("advise") -(do-test "simple il:advise il:around of defun" (defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(prog1 (our-fun) (il:unadvise our-fun))) -(do-test "simple il:advise il:around of fn" (il:defineq (our-fn nil nil)) -(il:advise 'our-fn 'il:around t) -(prog1 (our-fn) (il:unadvise our-fn))) -(do-test "il:advise redefined broken defun" (defun our-fun nil nil) -(il:break our-fun) -(defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(prog1 (our-fun) (unbreak our-fun) -(il:unadvise our-fun))) -(do-test "il:advise redefined advised defun (AR 8172)" -(defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(defun our-fun nil nil) -(il:advise 'our-fun 'il:around t) -(prog1 (our-fun) (il:unadvise our-fun))) -(do-test "il:advise re-defined advised fn" (il:defineq (our-fn nil nil)) -(il:advise 'our-fn 'il:around t) -(il:defineq (our-fn nil nil)) -(il:advise 'our-fn 'il:around t) -(prog1 (our-fn) (il:unadvise our-fn)))) -(do-test-group ("il:unadvise" :before (defun our-fun nil nil) -(il:unadvise our-fun)) -(do-test "simple il:unadvise" (il:advise 'our-fun 'il:around t) -(and (our-fun) (eq 'our-fun (first (il:unadvise our-fun))) -(not (our-fun)))) -(do-test "il:unadvise t" (il:advise 'our-fun 'il:around t) -(and (our-fun) (eq 'our-fun (first (il:unadvise t))) -(not (our-fun))))) -(do-test "close user interaction window" (do-test-menu-cleanup dtmw) t) -STOP -(do-test "Error List condition correspondence" -(dotimes (i 52) -(ignore-errors (il:seterrorn i))) -(print "Select Inspect from the menu that will be appearing.") -(let ((iw (inspect (il:|for| i il:|from| 0 il:|to| 52 -il:|collect| (ignore-errors (il:seterrorn i))) nil -(il:|create| il:position il:xcoord il:_ 10 il:ycoord il:_ 10))) -(result -(do-test-menu-message dtmw 'low -(concatenate 'string -"Does the inspect window have conditions -" -"correctly corresponding to error number + 1 -" -"in the Lyric release notes section 14.10?")))) -(il:closew iw) -result)) -,~,N,:,&,S,k,K,c,Q,4,7,,Œ,™,x,d,,’,€,P,<,L,(,C,1,n,,9,,M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10))  HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8))5˛g)&1-.<!O!;%'!$$ 0#8(. !$& -%(*(S  -(E  -!)"K  -!)".0  -)1+  -(>P!9-*'2 -- -**BM&%XFE/*N9%E@($=%!;:86;6 -A(%6:@;4 K %  S  .& %   * +$ %G3%/ 3 %9"'/ - 9*D0 9$!% G " ) J ! ' D   " # 7  "  " ) I !  ! (>  @ ; ; 5H/ "?  ' 4 )-0 (#°zş \ No newline at end of file +;; This is a collection of tests from the Debugger.NoteFile. It tests the break package and IL error system. The individual test files for each of the functions have been appended together in this big file to share common code and gain diagnostic information by testing the functions in a particular order. ;; ;; The source for the text file listing is the NoteCards database at {Erinyes}Lisp>Lyric>Plans>Debugger.NoteFile. Changes are made only to the NoteFile. The listings are ;; Filed As: {eris}test>Debugger>Debugger.u and {eris}test>Debugger>BreakWindow.u (do-test "setup user interaction window" (unless (fboundp 'do-test-menu-setup) (load "{Eris}tools>do-test-menu.dfasl" t)) (setq dtmw (do-test-menu-setup "Debugger"))) (do-test-group ("il:break" :before (progn (unbreak il:ourfn) (il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) (do-test "il:break" (and (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break of il:broken fns update of il:brokenfns" (unbreak il:ourfn) (and (il:break il:ourfn) (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break of il:advisedfns updating il:brokenfns" (and (il:defineq (il:ourfn nil nil)) (not (il:ourfn)) (il:advise 'il:ourfn 'il:around nil t) (il:break il:ourfn) (il:memb 'il:ourfn il:brokenfns) (car (unbreak il:ourfn)))) (do-test "AR 7618 BREAK :IN broken" (il:defineq (foo nil (print "foo")) (bar nil (foo) (print "bar"))) (il:break (foo :in bar)) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "In the exec, enter (foo). " "You should see a break window.")) (unbreak (foo :in bar))))) (do-test-group ("xcl:break-function" :before (progn (unbreak il:ourfn) (il:defineq (il:ourfn nil nil))) :after (unbreak il:ourfn)) (do-test "simple il:break-function" (unbreak) (and (break-function 'il:ourfn) (il:memb 'il:ourfn il:brokenfns) (unbreak il:ourfn))) (do-test "il:break-function :trace" (and (break-function 'floor :trace t) (floor 20 3) (and (do-test-menu-message dtmw 'low (concatenate 'string "You should see a *Trace-Output* window " "with a call to floor passed a 20 and a 3 " "and returning a 6 and a 2.")) (eq 'our-fn (car (untrace 'our-fn)))))) (do-test "il:break-function :when nil (AR 8162)" (break-function 'floor :when nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " " and you should NOT see a break window ")) (untrace 'floor))) (do-test "il:break-function :when t" (break-function 'floor :when t) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see a break window " "for Breakpoint at flo0r. " "Type OK to the break window." " The break window should go away and " "the exec should show" " floor returning a 6 and a 2.")) (unbreak 'floor))) (do-test "il:break-function :trace nil" (break-function 'floor :trace nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see a break window " "for Breakpoint at floor. " "Type OK to the break window." " The break window should go away and " "the exec should show" " floor returning a 6 and a 2.")) (unbreak 'floor))) (do-test "il:break-function :trace :when nil" (and (break-function 'floor :trace t :when nil) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " "You should not see a new call to floor" " in the *Trace-Output* window ")) (untrace 'our-fn)))) (do-test "il:break-function :when exp (AR 8162)" (break-function 'floor :when (when nil t)) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Enter (floor 20 3) to the exec. " "You should see the result " "6 2 " " and you should NOT see a break window ")) (untrace 'floor)))) (do-test-group ("HELPFLAG" :after (progn (setq il:helpflag t) (setq il:helpdepth 7))) (do-test "*test-mode* :interactive switch on" (setq save.test.mode *test-mode*) (setq *test-mode* :interactive)) (do-test "IL:HELPFLAG BREAK!" (setq il:helpflag 'break!) (proceed-case (error "Break test. This is a test, just a test. Select Proceed from middle button menu.") (proceed nil :report "Select me!" t))) (do-test "IL:HELPFLAG NIL" (setq il:helpflag nil) (prog1 (not (ignore-errors (proceed-case (error "Break test. This is a test, just a test. Select Proceed from middle button menu.") (proceed nil :report "Select me!" nil)))) (setq il:helpflag t))) (do-test "restore *test-mode*" (setq *test-mode* save.test.mode)) (do-test "IL:HELPFLAG IL:SETTOPVAL (AR 7845)" (il:settopval il:helpflag nil) (and (not (il:gettopval il:helpflag)) (il:settopval il:helpflag t) (eq t (il:gettopval il:helpflag))))) (do-test-group ("IL:NLSETQ" :before (setq il:helpflag nil) :after (setq il:helpflag t)) (do-test "IL:NLSETQ error" (not (il:nlsetq (error "just an error")))) (do-test "IL:NLSETQ signal error" (not (il:nlsetq (signal 'error)))) (do-test "AR 7252 IL:NLSETQ SERIOUS-CONDITION" ;; nlsetq should not trap serious-conditions (expect-errors (serious-condition) (il:nlsetq (signal 'serious-condition))))) (do-test-group ("unbreak" :before (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t)) (do-test "simple unbreak" (and (il:break our-fn) (unbreak) (not (member 'our-fn il:brokenfns)) (not (unbreak)))) (do-test "unbreak of (sub-fn il:in superfn)" (unbreak super-fn) (and (il:break (our-fn il:in super-fn)) (unbreak (our-fn il:in super-fn)))) (do-test "unbreak of (sub-fn in superfn)" (unbreak super-fn) (and (il:break (our-fn in super-fn)) (unbreak (our-fn in super-fn)))) ;; the following commented out due to ignore-errors causing ;; do-test-file to abort.: (do-test "unbreak of (sub-fn in ;; superfn)" (unbreak super-fn) (and (il:break (our-fn in ;; super-fn)) (unbreak (our-fn in super-fn)))) (do-test ;; "unbreak of '(sub-fn in superfn)" (unbreak super-fn) (and ;; (il:break (our-fn in super-fn)) (unbreak '(our-fn in ;; super-fn)))) (do-test "unbreak of '(sub-fn il:in superfn)" (unbreak super-fn) (and (il:break (our-fn il:in super-fn)) (unbreak '(our-fn il:in super-fn)))) ;; (do-test "unbreak of '(sub-fn :in superfn)" (unbreak ;; super-fn) (and (il:break (our-fn :in super-fn)) (unbreak ;; '(our-fn :in super-fn)))) (do-test "unbreak0 of '(sub-fn il:in ;; superfn)" (unbreak super-fn) (and (il:break (our-fn il:in ;; super-fn)) (il:unbreak0 '(our-fn il:in super-fn)))) ) (do-test-group ("il:rebreak" :before (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t)) (do-test "simple il:rebreak" (and (il:break our-fn) (unbreak our-fn) (il:rebreak our-fn)))) (do-test-group ("untrace" :before (defun our-fn (x) (values x (not x))) (untrace)) (do-test "simple untrace" (and (trace our-fn) (untrace) (not (untrace)) (not (member 'our-fn il:brokenfns)))) (do-test "(untrace) with broken fns" (and (il:break our-fn) (not (untrace)) (member 'our-fn il:brokenfns))) (do-test "(untrace (sub-fn in super-fn))" (and (defun our-fn (x) (values x (not x))) (defun super-fn nil (our-fn nil) t) (trace (our-fn il:in super-fn)) (untrace (our-fn il:in super-fn))))) (do-test-group ("trace" :before (defun our-fn (x) (values x (not x)))) (do-test "trace il:brokenfns check" (trace our-fn) (prog1 (member 'our-fn il:brokenfns) (untrace 'our-fn))) (do-test "il:broken prop check" (trace our-fn) (prog1 (get 'our-fn 'il:broken) (untrace 'our-fn))) (do-test "simple interpreted trace" (trace our-fn) (our-fn t) (and (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to our-fn passed a t " "and returning a t nil?")) (eq 'our-fn (car (untrace 'our-fn))))) (do-test "simple compiled trace" (trace floor) (floor 20 3) (prog1 (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to floor passed a 20 and a 3 " "and returning a 6 and a 2?")) (untrace 'floor))) (do-test "trace of subfunction" (defun super-fn nil (our-fn nil) t) (and (trace (our-fn il:in super-fn)) (super-fn) (do-test-menu-message dtmw 'low (concatenate 'string "Do you see a *Trace-Output* window " "with a call to our-fn passed a nil " "and returning a nil and a t?")) (untrace (our-fn il:in super-fn))))) (do-test-group ("advise") (do-test "simple il:advise il:around of defun" (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (il:unadvise our-fun))) (do-test "simple il:advise il:around of fn" (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (prog1 (our-fn) (il:unadvise our-fn))) (do-test "il:advise redefined broken defun" (defun our-fun nil nil) (il:break our-fun) (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (unbreak our-fun) (il:unadvise our-fun))) (do-test "il:advise redefined advised defun (AR 8172)" (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (defun our-fun nil nil) (il:advise 'our-fun 'il:around t) (prog1 (our-fun) (il:unadvise our-fun))) (do-test "il:advise re-defined advised fn" (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (il:defineq (our-fn nil nil)) (il:advise 'our-fn 'il:around t) (prog1 (our-fn) (il:unadvise our-fn)))) (do-test-group ("il:unadvise" :before (defun our-fun nil nil) (il:unadvise our-fun)) (do-test "simple il:unadvise" (il:advise 'our-fun 'il:around t) (and (our-fun) (eq 'our-fun (first (il:unadvise our-fun))) (not (our-fun)))) (do-test "il:unadvise t" (il:advise 'our-fun 'il:around t) (and (our-fun) (eq 'our-fun (first (il:unadvise t))) (not (our-fun))))) (do-test "close user interaction window" (do-test-menu-cleanup dtmw) t) STOP (do-test "Error List condition correspondence" (dotimes (i 52) (ignore-errors (il:seterrorn i))) (print "Select Inspect from the menu that will be appearing.") (let ((iw (inspect (il:|for| i il:|from| 0 il:|to| 52 il:|collect| (ignore-errors (il:seterrorn i))) nil (il:|create| il:position il:xcoord il:_ 10 il:ycoord il:_ 10))) (result (do-test-menu-message dtmw 'low (concatenate 'string "Does the inspect window have conditions " "correctly corresponding to error number + 1 " "in the Lyric release notes section 14.10?")))) (il:closew iw) result)) ,~,N,:,&,S,k,K,c,Q,4,7,,Œ,™,x,d,,’,€,P,<,L,(,C,1,n,,9,,M?(COMMENTFONT 6 (TIMESROMAN 10) (TIMESROMAN 10) (TIMESROMAN 10)) + HELVETICAG9(DEFAULTFONT 1 (HELVETICA 8) (HELVETICA 8) (HELVETICA 8)) HELVETICAG9(defaultfont 1 (HELVETICA 8) (helvetica 8) (helvetica 8))5˛g)&1-.<!O!;%'!$$ 0#8(. !$& %(*(S  (E  !)"K  !)".0  )1+  (>P!9-*'2 - **BM&%XFE/*N9%E@($=%!;:86;6 A(%6:@;4 K % + S + .& +%   +* +$ %G3%/ 3 %9"'/  9*D0 9$!% +G " ) +J ! ' +D   " # +7  "  " ) +I !  ! (>  +@ ; +; 5H/ +"?  ' 4 )-0 (#°zş \ No newline at end of file diff --git a/internal/test/env/Debugger/logs/DebuggerOnly.log b/internal/test/env/Debugger/logs/DebuggerOnly.log index 266e9657..2addbdbc 100644 --- a/internal/test/env/Debugger/logs/DebuggerOnly.log +++ b/internal/test/env/Debugger/logs/DebuggerOnly.log @@ -1 +1,26 @@ -;;; 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 +;;; 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~ index 49e83fb0..d884b711 100644 --- a/internal/test/env/Debugger/logs/DebuggerOnly.log.~1~ +++ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~1~ @@ -1 +1,44 @@ -;;; 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 +;;; 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~ index eb898447..17edb1ce 100644 --- a/internal/test/env/Debugger/logs/DebuggerOnly.log.~2~ +++ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~2~ @@ -1 +1,38 @@ -;;; 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 +;;; 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~ index 266e9657..2addbdbc 100644 --- a/internal/test/env/Debugger/logs/DebuggerOnly.log.~3~ +++ b/internal/test/env/Debugger/logs/DebuggerOnly.log.~3~ @@ -1 +1,26 @@ -;;; 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 +;;; 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 index b121e245..9665198d 100644 --- a/internal/test/env/Debugger/logs/Report.tedit +++ b/internal/test/env/Debugger/logs/Report.tedit @@ -1,313 +1,5 @@ -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 +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 index 57896548..6ef6ca1f 100644 Binary files a/internal/test/env/Debugger/logs/debugger.log 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~ index 2a7ffb68..4ccaf9e9 100644 --- a/internal/test/env/Debugger/logs/debugger.log.~1~ +++ b/internal/test/env/Debugger/logs/debugger.log.~1~ @@ -1 +1,34 @@ -;;; 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 +;;; 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~ index 1a75ba46..1d6f1487 100644 --- a/internal/test/env/Debugger/logs/debugger.log.~2~ +++ b/internal/test/env/Debugger/logs/debugger.log.~2~ @@ -1 +1,32 @@ -;;; 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 +;;; 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~ index 2ffceea5..4fa3e0d5 100644 --- a/internal/test/env/Debugger/logs/debugger.log.~3~ +++ b/internal/test/env/Debugger/logs/debugger.log.~3~ @@ -1 +1,51 @@ -;;; 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 +;;; 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~ index f10e8566..ea84d9e5 100644 --- a/internal/test/env/Debugger/logs/debugger.log.~4~ +++ b/internal/test/env/Debugger/logs/debugger.log.~4~ @@ -1 +1,48 @@ -;;; 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 +;;; 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~ index cd72fe03..82f7c9ae 100644 --- a/internal/test/env/Debugger/logs/debugger.log.~5~ +++ b/internal/test/env/Debugger/logs/debugger.log.~5~ @@ -1 +1,32 @@ -;;; 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 +;;; 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~ index 833d2fc2..f14df1eb 100644 --- a/internal/test/env/Debugger/logs/debugger.log.~6~ +++ b/internal/test/env/Debugger/logs/debugger.log.~6~ @@ -1 +1,37 @@ -;;; 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 +;;; 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~ index 57896548..6ef6ca1f 100644 Binary files a/internal/test/env/Debugger/logs/debugger.log.~7~ 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 index 9d0df3c0..5f61f702 100644 --- a/internal/test/env/Exec/Hand/CONN.U +++ b/internal/test/env/Exec/Hand/CONN.U @@ -1 +1,84 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/DA.U b/internal/test/env/Exec/Hand/DA.U index f3f4a1f9..c1b8376f 100644 --- a/internal/test/env/Exec/Hand/DA.U +++ b/internal/test/env/Exec/Hand/DA.U @@ -1 +1,75 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/DA.U.~1~ b/internal/test/env/Exec/Hand/DA.U.~1~ index 917555fc..e9f7faa2 100644 --- a/internal/test/env/Exec/Hand/DA.U.~1~ +++ b/internal/test/env/Exec/Hand/DA.U.~1~ @@ -1 +1,75 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/DA.U.~2~ b/internal/test/env/Exec/Hand/DA.U.~2~ index f3f4a1f9..c1b8376f 100644 --- a/internal/test/env/Exec/Hand/DA.U.~2~ +++ b/internal/test/env/Exec/Hand/DA.U.~2~ @@ -1 +1,75 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/DIR.U b/internal/test/env/Exec/Hand/DIR.U index 84816ddf..14144079 100644 --- a/internal/test/env/Exec/Hand/DIR.U +++ b/internal/test/env/Exec/Hand/DIR.U @@ -1 +1,123 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/FIND-EVENT.U b/internal/test/env/Exec/Hand/FIND-EVENT.U index b641e6b9..8714a72f 100644 --- a/internal/test/env/Exec/Hand/FIND-EVENT.U +++ b/internal/test/env/Exec/Hand/FIND-EVENT.U @@ -1 +1,117 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/FIX.U b/internal/test/env/Exec/Hand/FIX.U index a64b6a31..208c6629 100644 --- a/internal/test/env/Exec/Hand/FIX.U +++ b/internal/test/env/Exec/Hand/FIX.U @@ -1 +1,94 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/HELP.U b/internal/test/env/Exec/Hand/HELP.U index dbe00e86..c5f5a7be 100644 --- a/internal/test/env/Exec/Hand/HELP.U +++ b/internal/test/env/Exec/Hand/HELP.U @@ -1 +1,103 @@ -;; 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 +;; 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 + + + diff --git a/internal/test/env/Exec/Hand/MULTIPLE-USE.U b/internal/test/env/Exec/Hand/MULTIPLE-USE.U index 224a4e0d..1aa3c9c9 100644 --- a/internal/test/env/Exec/Hand/MULTIPLE-USE.U +++ b/internal/test/env/Exec/Hand/MULTIPLE-USE.U @@ -1 +1,105 @@ -;; 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 +;; 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) + ) +) + + diff --git a/internal/test/env/Exec/Hand/NDIR.U b/internal/test/env/Exec/Hand/NDIR.U index f45d953f..26b59b24 100644 --- a/internal/test/env/Exec/Hand/NDIR.U +++ b/internal/test/env/Exec/Hand/NDIR.U @@ -1 +1,111 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/PL.U b/internal/test/env/Exec/Hand/PL.U index fc9da5b4..125b013b 100644 --- a/internal/test/env/Exec/Hand/PL.U +++ b/internal/test/env/Exec/Hand/PL.U @@ -1 +1,114 @@ -;; 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 +;; 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 diff --git a/internal/test/env/Exec/Hand/PP.U b/internal/test/env/Exec/Hand/PP.U index b94401ae..16d76644 100644 --- a/internal/test/env/Exec/Hand/PP.U +++ b/internal/test/env/Exec/Hand/PP.U @@ -1 +1,158 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/REDO.U b/internal/test/env/Exec/Hand/REDO.U index 2e5e978f..4c71ea06 100644 --- a/internal/test/env/Exec/Hand/REDO.U +++ b/internal/test/env/Exec/Hand/REDO.U @@ -1 +1,73 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/SEE-WITHOUT-COMMENT.U b/internal/test/env/Exec/Hand/SEE-WITHOUT-COMMENT.U index c1b3dc82..f0d62652 100644 --- a/internal/test/env/Exec/Hand/SEE-WITHOUT-COMMENT.U +++ b/internal/test/env/Exec/Hand/SEE-WITHOUT-COMMENT.U @@ -1 +1,106 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/SEE.U b/internal/test/env/Exec/Hand/SEE.U index 2abb5921..bd99a7d4 100644 --- a/internal/test/env/Exec/Hand/SEE.U +++ b/internal/test/env/Exec/Hand/SEE.U @@ -1 +1,107 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/TEST.REPORT b/internal/test/env/Exec/Hand/TEST.REPORT index 9be14a60..ef8647a6 100644 --- a/internal/test/env/Exec/Hand/TEST.REPORT +++ b/internal/test/env/Exec/Hand/TEST.REPORT @@ -1 +1,218 @@ -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 +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 diff --git a/internal/test/env/Exec/Hand/TY.U b/internal/test/env/Exec/Hand/TY.U index 2715feef..93f9e916 100644 --- a/internal/test/env/Exec/Hand/TY.U +++ b/internal/test/env/Exec/Hand/TY.U @@ -1 +1,108 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/TYPE.U b/internal/test/env/Exec/Hand/TYPE.U index 5b586bf5..5bf83d4d 100644 --- a/internal/test/env/Exec/Hand/TYPE.U +++ b/internal/test/env/Exec/Hand/TYPE.U @@ -1 +1,106 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/USE.U b/internal/test/env/Exec/Hand/USE.U index ec957a4e..bd2d3623 100644 --- a/internal/test/env/Exec/Hand/USE.U +++ b/internal/test/env/Exec/Hand/USE.U @@ -1 +1,92 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/do-events.u b/internal/test/env/Exec/Hand/do-events.u index 6ee3a536..3c4ac7ed 100644 --- a/internal/test/env/Exec/Hand/do-events.u +++ b/internal/test/env/Exec/Hand/do-events.u @@ -1 +1,72 @@ -;; 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 +;; 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 diff --git a/internal/test/env/Exec/Hand/exec.log b/internal/test/env/Exec/Hand/exec.log index cc0e2880..45f789a5 100644 --- a/internal/test/env/Exec/Hand/exec.log +++ b/internal/test/env/Exec/Hand/exec.log @@ -1 +1,8 @@ -;;; 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 +;;; 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 index 155c2340..244668d1 100644 --- a/internal/test/env/Exec/Hand/forget.u +++ b/internal/test/env/Exec/Hand/forget.u @@ -1 +1,87 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/log-form b/internal/test/env/Exec/Hand/log-form index fd7206f5..233a1d59 100644 Binary files a/internal/test/env/Exec/Hand/log-form 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 index 8612f8f8..7e98c7b0 100644 --- a/internal/test/env/Exec/Hand/masterscope.u +++ b/internal/test/env/Exec/Hand/masterscope.u @@ -1 +1,144 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/name.u b/internal/test/env/Exec/Hand/name.u index 62eb51d8..0c369509 100644 --- a/internal/test/env/Exec/Hand/name.u +++ b/internal/test/env/Exec/Hand/name.u @@ -1 +1,85 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/remember.u b/internal/test/env/Exec/Hand/remember.u index 15fa9ac2..f7b91ab2 100644 --- a/internal/test/env/Exec/Hand/remember.u +++ b/internal/test/env/Exec/Hand/remember.u @@ -1 +1,85 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/retry.u b/internal/test/env/Exec/Hand/retry.u index 7fb84d27..c4ac2bb9 100644 --- a/internal/test/env/Exec/Hand/retry.u +++ b/internal/test/env/Exec/Hand/retry.u @@ -1 +1,96 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/shh.u b/internal/test/env/Exec/Hand/shh.u index 7995aca9..adef6f6d 100644 --- a/internal/test/env/Exec/Hand/shh.u +++ b/internal/test/env/Exec/Hand/shh.u @@ -1 +1,97 @@ -;; 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 +;; 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 diff --git a/internal/test/env/Exec/Hand/test.proc b/internal/test/env/Exec/Hand/test.proc index ce2194c3..3c0ee248 100644 Binary files a/internal/test/env/Exec/Hand/test.proc 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 index cd655e1a..980e530a 100644 --- a/internal/test/env/Exec/Hand/time.u +++ b/internal/test/env/Exec/Hand/time.u @@ -1 +1,126 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Hand/undo.u b/internal/test/env/Exec/Hand/undo.u index 9aa23a8f..715b125f 100644 --- a/internal/test/env/Exec/Hand/undo.u +++ b/internal/test/env/Exec/Hand/undo.u @@ -1 +1,89 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Exec/Logs/Debugger.log b/internal/test/env/Exec/Logs/Debugger.log index afc26090..b4e85b46 100644 --- a/internal/test/env/Exec/Logs/Debugger.log +++ b/internal/test/env/Exec/Logs/Debugger.log @@ -1 +1,5 @@ -;;; 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 +;;; 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 index 1bc4656a..57b378a2 100644 --- a/internal/test/env/Exec/Logs/Exec.log +++ b/internal/test/env/Exec/Logs/Exec.log @@ -1 +1,5 @@ -;;; 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 +;;; 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~ index 3849d0f9..5cbf2cf0 100644 --- a/internal/test/env/Exec/Logs/Exec.log.~1~ +++ b/internal/test/env/Exec/Logs/Exec.log.~1~ @@ -1 +1,5 @@ -;;; 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 +;;; 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~ index 1a92b1bc..a291f970 100644 --- a/internal/test/env/Exec/Logs/Exec.log.~2~ +++ b/internal/test/env/Exec/Logs/Exec.log.~2~ @@ -1 +1,8 @@ -;;; 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 +;;; 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~ index 1bc4656a..57b378a2 100644 --- a/internal/test/env/Exec/Logs/Exec.log.~3~ +++ b/internal/test/env/Exec/Logs/Exec.log.~3~ @@ -1 +1,5 @@ -;;; 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 +;;; 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 index 1b4d1ee0..2ac60963 100644 --- a/internal/test/env/FilePkg/Hand-Aux/FORMATTINGFNS +++ b/internal/test/env/FilePkg/Hand-Aux/FORMATTINGFNS @@ -1 +1,1065 @@ -(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 +(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 diff --git a/internal/test/env/FilePkg/Hand/AR10062.u b/internal/test/env/FilePkg/Hand/AR10062.u index 06027a6b..7bd7c189 100644 --- a/internal/test/env/FilePkg/Hand/AR10062.u +++ b/internal/test/env/FilePkg/Hand/AR10062.u @@ -1 +1,9 @@ -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 +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 index 0f93888c..035df42c 100644 Binary files a/internal/test/env/FreeMenu/Auto/FREEMENU.TEST 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 index e033b950..10eaf5d8 100644 Binary files a/internal/test/env/Program-Support/Auto/CLISP.TEST 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~ index e033b950..10eaf5d8 100644 Binary files a/internal/test/env/Program-Support/Auto/CLISP.TEST.~2~ 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 index 67d4fc55..4c0d030f 100644 --- a/internal/test/env/Program-Support/hand/DWIM.REPORT +++ b/internal/test/env/Program-Support/hand/DWIM.REPORT @@ -1 +1,303 @@ -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 +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 diff --git a/internal/test/env/Program-Support/hand/DWIM.U b/internal/test/env/Program-Support/hand/DWIM.U index c9d317fb..54c18f28 100644 --- a/internal/test/env/Program-Support/hand/DWIM.U +++ b/internal/test/env/Program-Support/hand/DWIM.U @@ -1 +1,233 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/Program-Support/hand/dwim.log b/internal/test/env/Program-Support/hand/dwim.log index df661746..c78c2fc8 100644 --- a/internal/test/env/Program-Support/hand/dwim.log +++ b/internal/test/env/Program-Support/hand/dwim.log @@ -1 +1,5 @@ -;;; 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 +;;; 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 index 52b491fd..1c6ddd3a 100644 --- a/internal/test/env/code-editor/hand/Command-abort.u +++ b/internal/test/env/code-editor/hand/Command-abort.u @@ -1 +1,384 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-arglist.u b/internal/test/env/code-editor/hand/Command-arglist.u index da774839..194acc3d 100644 --- a/internal/test/env/code-editor/hand/Command-arglist.u +++ b/internal/test/env/code-editor/hand/Command-arglist.u @@ -1 +1,289 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-arglist.u.~1~ b/internal/test/env/code-editor/hand/Command-arglist.u.~1~ index 51507530..3bf52f97 100644 --- a/internal/test/env/code-editor/hand/Command-arglist.u.~1~ +++ b/internal/test/env/code-editor/hand/Command-arglist.u.~1~ @@ -1 +1,289 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-arglist.u.~2~ b/internal/test/env/code-editor/hand/Command-arglist.u.~2~ index da774839..194acc3d 100644 --- a/internal/test/env/code-editor/hand/Command-arglist.u.~2~ +++ b/internal/test/env/code-editor/hand/Command-arglist.u.~2~ @@ -1 +1,289 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-base.u b/internal/test/env/code-editor/hand/Command-base.u index c6cc322f..ad732b6b 100644 --- a/internal/test/env/code-editor/hand/Command-base.u +++ b/internal/test/env/code-editor/hand/Command-base.u @@ -1 +1,314 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-comment.u b/internal/test/env/code-editor/hand/Command-comment.u index 56dd3397..629dc094 100644 --- a/internal/test/env/code-editor/hand/Command-comment.u +++ b/internal/test/env/code-editor/hand/Command-comment.u @@ -1 +1,333 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-eval.u b/internal/test/env/code-editor/hand/Command-eval.u index 57fc4d59..c30cf45c 100644 --- a/internal/test/env/code-editor/hand/Command-eval.u +++ b/internal/test/env/code-editor/hand/Command-eval.u @@ -1 +1,341 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-expand.u b/internal/test/env/code-editor/hand/Command-expand.u index ca4d7262..f594203e 100644 --- a/internal/test/env/code-editor/hand/Command-expand.u +++ b/internal/test/env/code-editor/hand/Command-expand.u @@ -1 +1,316 @@ -;; 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 +;; 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 + + diff --git a/internal/test/env/code-editor/hand/Command-extract.u b/internal/test/env/code-editor/hand/Command-extract.u index 673c5c70..1d4084b9 100644 --- a/internal/test/env/code-editor/hand/Command-extract.u +++ b/internal/test/env/code-editor/hand/Command-extract.u @@ -1 +1,335 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-extract.u.~1~ b/internal/test/env/code-editor/hand/Command-extract.u.~1~ index eb9bb4cb..59046a1a 100644 --- a/internal/test/env/code-editor/hand/Command-extract.u.~1~ +++ b/internal/test/env/code-editor/hand/Command-extract.u.~1~ @@ -1 +1,336 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-extract.u.~2~ b/internal/test/env/code-editor/hand/Command-extract.u.~2~ index 673c5c70..1d4084b9 100644 --- a/internal/test/env/code-editor/hand/Command-extract.u.~2~ +++ b/internal/test/env/code-editor/hand/Command-extract.u.~2~ @@ -1 +1,335 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-find.u b/internal/test/env/code-editor/hand/Command-find.u index 270123f6..3eca1ae2 100644 --- a/internal/test/env/code-editor/hand/Command-find.u +++ b/internal/test/env/code-editor/hand/Command-find.u @@ -1 +1,324 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-find.u.~1~ b/internal/test/env/code-editor/hand/Command-find.u.~1~ index dbb2c5ff..3308900d 100644 --- a/internal/test/env/code-editor/hand/Command-find.u.~1~ +++ b/internal/test/env/code-editor/hand/Command-find.u.~1~ @@ -1 +1,324 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-find.u.~2~ b/internal/test/env/code-editor/hand/Command-find.u.~2~ index 270123f6..3eca1ae2 100644 --- a/internal/test/env/code-editor/hand/Command-find.u.~2~ +++ b/internal/test/env/code-editor/hand/Command-find.u.~2~ @@ -1 +1,324 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-high.u b/internal/test/env/code-editor/hand/Command-high.u index 536c1c17..bcdf95f2 100644 --- a/internal/test/env/code-editor/hand/Command-high.u +++ b/internal/test/env/code-editor/hand/Command-high.u @@ -1 +1,175 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-high.u.~1~ b/internal/test/env/code-editor/hand/Command-high.u.~1~ index d6074be4..7da93658 100644 --- a/internal/test/env/code-editor/hand/Command-high.u.~1~ +++ b/internal/test/env/code-editor/hand/Command-high.u.~1~ @@ -1 +1,175 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-high.u.~2~ b/internal/test/env/code-editor/hand/Command-high.u.~2~ index 536c1c17..bcdf95f2 100644 --- a/internal/test/env/code-editor/hand/Command-high.u.~2~ +++ b/internal/test/env/code-editor/hand/Command-high.u.~2~ @@ -1 +1,175 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-join.u b/internal/test/env/code-editor/hand/Command-join.u index 709ab632..5ad7394a 100644 --- a/internal/test/env/code-editor/hand/Command-join.u +++ b/internal/test/env/code-editor/hand/Command-join.u @@ -1 +1,330 @@ -; 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 +; 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 diff --git a/internal/test/env/code-editor/hand/Command-join.u.~1~ b/internal/test/env/code-editor/hand/Command-join.u.~1~ index 61d85c1b..84d09970 100644 --- a/internal/test/env/code-editor/hand/Command-join.u.~1~ +++ b/internal/test/env/code-editor/hand/Command-join.u.~1~ @@ -1 +1,330 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-join.u.~2~ b/internal/test/env/code-editor/hand/Command-join.u.~2~ index 709ab632..5ad7394a 100644 --- a/internal/test/env/code-editor/hand/Command-join.u.~2~ +++ b/internal/test/env/code-editor/hand/Command-join.u.~2~ @@ -1 +1,330 @@ -; 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 +; 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 diff --git a/internal/test/env/code-editor/hand/Command-menu.u b/internal/test/env/code-editor/hand/Command-menu.u index fda09bc4..165967f5 100644 --- a/internal/test/env/code-editor/hand/Command-menu.u +++ b/internal/test/env/code-editor/hand/Command-menu.u @@ -1 +1,315 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-menu.u.~1~ b/internal/test/env/code-editor/hand/Command-menu.u.~1~ index bcf26eb1..a8793150 100644 --- a/internal/test/env/code-editor/hand/Command-menu.u.~1~ +++ b/internal/test/env/code-editor/hand/Command-menu.u.~1~ @@ -1 +1,315 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-menu.u.~2~ b/internal/test/env/code-editor/hand/Command-menu.u.~2~ index fda09bc4..165967f5 100644 --- a/internal/test/env/code-editor/hand/Command-menu.u.~2~ +++ b/internal/test/env/code-editor/hand/Command-menu.u.~2~ @@ -1 +1,315 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-meta-o.u b/internal/test/env/code-editor/hand/Command-meta-o.u index 413a48c3..e8736c75 100644 --- a/internal/test/env/code-editor/hand/Command-meta-o.u +++ b/internal/test/env/code-editor/hand/Command-meta-o.u @@ -1 +1,365 @@ -;; 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 +;; 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 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~ index 22e7c106..9098aeea 100644 --- a/internal/test/env/code-editor/hand/Command-meta-o.u.~1~ +++ b/internal/test/env/code-editor/hand/Command-meta-o.u.~1~ @@ -1 +1,367 @@ -;; 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 +;; 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 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~ index 413a48c3..e8736c75 100644 --- a/internal/test/env/code-editor/hand/Command-meta-o.u.~2~ +++ b/internal/test/env/code-editor/hand/Command-meta-o.u.~2~ @@ -1 +1,365 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-mutate.u b/internal/test/env/code-editor/hand/Command-mutate.u index a9c3a877..34893fa6 100644 --- a/internal/test/env/code-editor/hand/Command-mutate.u +++ b/internal/test/env/code-editor/hand/Command-mutate.u @@ -1 +1,313 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-mutate.u.~1~ b/internal/test/env/code-editor/hand/Command-mutate.u.~1~ index cd7d7963..8a586fc7 100644 --- a/internal/test/env/code-editor/hand/Command-mutate.u.~1~ +++ b/internal/test/env/code-editor/hand/Command-mutate.u.~1~ @@ -1 +1,313 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-mutate.u.~2~ b/internal/test/env/code-editor/hand/Command-mutate.u.~2~ index a9c3a877..34893fa6 100644 --- a/internal/test/env/code-editor/hand/Command-mutate.u.~2~ +++ b/internal/test/env/code-editor/hand/Command-mutate.u.~2~ @@ -1 +1,313 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-paren.u b/internal/test/env/code-editor/hand/Command-paren.u index b1839035..33720b26 100644 --- a/internal/test/env/code-editor/hand/Command-paren.u +++ b/internal/test/env/code-editor/hand/Command-paren.u @@ -1 +1,342 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-paren.u.~1~ b/internal/test/env/code-editor/hand/Command-paren.u.~1~ index 6f5f873d..08c26d6d 100644 --- a/internal/test/env/code-editor/hand/Command-paren.u.~1~ +++ b/internal/test/env/code-editor/hand/Command-paren.u.~1~ @@ -1 +1,337 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-paren.u.~2~ b/internal/test/env/code-editor/hand/Command-paren.u.~2~ index b1839035..33720b26 100644 --- a/internal/test/env/code-editor/hand/Command-paren.u.~2~ +++ b/internal/test/env/code-editor/hand/Command-paren.u.~2~ @@ -1 +1,342 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-substitute.u b/internal/test/env/code-editor/hand/Command-substitute.u index feaf3c4f..444cdbc2 100644 --- a/internal/test/env/code-editor/hand/Command-substitute.u +++ b/internal/test/env/code-editor/hand/Command-substitute.u @@ -1 +1,383 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-substitute.u.~1~ b/internal/test/env/code-editor/hand/Command-substitute.u.~1~ index 00bebe90..de2c415d 100644 --- a/internal/test/env/code-editor/hand/Command-substitute.u.~1~ +++ b/internal/test/env/code-editor/hand/Command-substitute.u.~1~ @@ -1 +1,384 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-substitute.u.~2~ b/internal/test/env/code-editor/hand/Command-substitute.u.~2~ index feaf3c4f..444cdbc2 100644 --- a/internal/test/env/code-editor/hand/Command-substitute.u.~2~ +++ b/internal/test/env/code-editor/hand/Command-substitute.u.~2~ @@ -1 +1,383 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Command-undo-redo.u b/internal/test/env/code-editor/hand/Command-undo-redo.u index ab6032e2..7c6b2e0a 100644 --- a/internal/test/env/code-editor/hand/Command-undo-redo.u +++ b/internal/test/env/code-editor/hand/Command-undo-redo.u @@ -1 +1,645 @@ -;; 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 +;; 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 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~ index 580c0116..4e014e94 100644 --- a/internal/test/env/code-editor/hand/Command-undo-redo.u.~1~ +++ b/internal/test/env/code-editor/hand/Command-undo-redo.u.~1~ @@ -1 +1,645 @@ -;; 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 +;; 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 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~ index ab6032e2..7c6b2e0a 100644 --- a/internal/test/env/code-editor/hand/Command-undo-redo.u.~2~ +++ b/internal/test/env/code-editor/hand/Command-undo-redo.u.~2~ @@ -1 +1,645 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Control.u b/internal/test/env/code-editor/hand/Control.u index fb01e283..638908c1 100644 --- a/internal/test/env/code-editor/hand/Control.u +++ b/internal/test/env/code-editor/hand/Control.u @@ -1,364 +1,2 @@ -;; 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 +;; 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~ index e69b46c2..00c2e184 100644 --- a/internal/test/env/code-editor/hand/Control.u.~1~ +++ b/internal/test/env/code-editor/hand/Control.u.~1~ @@ -1 +1,362 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Control.u.~2~ b/internal/test/env/code-editor/hand/Control.u.~2~ index fb01e283..638908c1 100644 --- a/internal/test/env/code-editor/hand/Control.u.~2~ +++ b/internal/test/env/code-editor/hand/Control.u.~2~ @@ -1,364 +1,2 @@ -;; 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 +;; 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 index 31af3c38..368043df 100644 --- a/internal/test/env/code-editor/hand/Interrupt.u +++ b/internal/test/env/code-editor/hand/Interrupt.u @@ -1 +1,191 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Interrupt.u.~1~ b/internal/test/env/code-editor/hand/Interrupt.u.~1~ index a8a6aff8..a22d4f23 100644 --- a/internal/test/env/code-editor/hand/Interrupt.u.~1~ +++ b/internal/test/env/code-editor/hand/Interrupt.u.~1~ @@ -1 +1,191 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/Interrupt.u.~2~ b/internal/test/env/code-editor/hand/Interrupt.u.~2~ index 31af3c38..368043df 100644 --- a/internal/test/env/code-editor/hand/Interrupt.u.~2~ +++ b/internal/test/env/code-editor/hand/Interrupt.u.~2~ @@ -1 +1,191 @@ -;; 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 +;; 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 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 index 72e4559c..2b7f2029 100644 --- a/internal/test/env/code-editor/hand/SEdit-3-mar-88.log +++ b/internal/test/env/code-editor/hand/SEdit-3-mar-88.log @@ -1 +1,20 @@ -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 +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 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~ index 5225c468..a1073ca2 100644 --- 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~ @@ -1 +1,21 @@ -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 +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 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~ index 72e4559c..2b7f2029 100644 --- 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~ @@ -1 +1,20 @@ -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 +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 diff --git a/internal/test/env/code-editor/hand/command-package.u b/internal/test/env/code-editor/hand/command-package.u index bdefab06..d7eda921 100644 --- a/internal/test/env/code-editor/hand/command-package.u +++ b/internal/test/env/code-editor/hand/command-package.u @@ -1 +1,401 @@ -;; 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 +;; 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 + + diff --git a/internal/test/env/code-editor/hand/command-package.u.~1~ b/internal/test/env/code-editor/hand/command-package.u.~1~ index f5484454..9dad10ab 100644 --- a/internal/test/env/code-editor/hand/command-package.u.~1~ +++ b/internal/test/env/code-editor/hand/command-package.u.~1~ @@ -1 +1,400 @@ -;; 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 +;; 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 + + diff --git a/internal/test/env/code-editor/hand/command-package.u.~2~ b/internal/test/env/code-editor/hand/command-package.u.~2~ index bdefab06..d7eda921 100644 --- a/internal/test/env/code-editor/hand/command-package.u.~2~ +++ b/internal/test/env/code-editor/hand/command-package.u.~2~ @@ -1 +1,401 @@ -;; 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 +;; 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 + + diff --git a/internal/test/env/code-editor/hand/command-skip-next.u b/internal/test/env/code-editor/hand/command-skip-next.u index 76c3f066..ccb8e337 100644 --- a/internal/test/env/code-editor/hand/command-skip-next.u +++ b/internal/test/env/code-editor/hand/command-skip-next.u @@ -1 +1,268 @@ -;; 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 +;; 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 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~ index bae26759..305142aa 100644 --- a/internal/test/env/code-editor/hand/command-skip-next.u.~1~ +++ b/internal/test/env/code-editor/hand/command-skip-next.u.~1~ @@ -1 +1,273 @@ -;; 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 +;; 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 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~ index 76c3f066..ccb8e337 100644 --- a/internal/test/env/code-editor/hand/command-skip-next.u.~2~ +++ b/internal/test/env/code-editor/hand/command-skip-next.u.~2~ @@ -1 +1,268 @@ -;; 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 +;; 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 diff --git a/internal/test/env/code-editor/hand/report.tedit b/internal/test/env/code-editor/hand/report.tedit index 36181837..61d1197b 100644 Binary files a/internal/test/env/code-editor/hand/report.tedit 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 index 0c162c66..c411ad01 100644 --- a/internal/test/env/inspector/hand/allrec.test +++ b/internal/test/env/inspector/hand/allrec.test @@ -1,665 +1,2 @@ -(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 +(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 index 45bf3f07..d2225fb7 100644 Binary files a/internal/test/env/inspector/hand/inspect-allrec.tedit 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 index 9d589aa7..af661e3a 100644 Binary files a/internal/test/env/inspector/hand/inspect-code.tedit 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 index a208e5dc..b6fecabc 100644 Binary files a/internal/test/env/inspector/hand/inspect-defstruct.tedit 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~ index bce6cb95..bb7a0730 100644 Binary files a/internal/test/env/inspector/hand/inspect-defstruct.tedit.~1~ 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~ index a208e5dc..b6fecabc 100644 Binary files a/internal/test/env/inspector/hand/inspect-defstruct.tedit.~2~ 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 index dbbdafb5..2865e5de 100644 Binary files a/internal/test/env/inspector/hand/inspect-macro.tedit 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~ index 05087e2b..f8c28fff 100644 Binary files a/internal/test/env/inspector/hand/inspect-macro.tedit.~1~ 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~ index dbbdafb5..2865e5de 100644 Binary files a/internal/test/env/inspector/hand/inspect-macro.tedit.~2~ 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 index 51f1cee0..aa6048bb 100644 Binary files a/internal/test/env/inspector/hand/inspectfieldflg.tedit 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~ index 583aaa6e..b2f258ab 100644 Binary files a/internal/test/env/inspector/hand/inspectfieldflg.tedit.~1~ 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~ index 51f1cee0..aa6048bb 100644 Binary files a/internal/test/env/inspector/hand/inspectfieldflg.tedit.~2~ 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 index 492201a1..7c2bc5b1 100644 Binary files a/internal/test/env/inspector/hand/inspectw.tedit 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~ index 6f6e0f04..4a0f905f 100644 Binary files a/internal/test/env/inspector/hand/inspectw.tedit.~1~ 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~ index 492201a1..7c2bc5b1 100644 Binary files a/internal/test/env/inspector/hand/inspectw.tedit.~2~ 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 index c85a7b86..1fe137ca 100644 Binary files a/internal/test/env/inspector/hand/report.tedit 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 index eb9f52dc..8e02f1cd 100644 --- a/internal/test/env/inspector/hand/userdef.test +++ b/internal/test/env/inspector/hand/userdef.test @@ -1 +1,37 @@ -;; 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 +;; 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~ index ef59059a..a26c5522 100644 --- a/internal/test/env/inspector/hand/userdef.test.~1~ +++ b/internal/test/env/inspector/hand/userdef.test.~1~ @@ -1 +1,34 @@ -(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 +(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~ index eb9f52dc..8e02f1cd 100644 --- a/internal/test/env/inspector/hand/userdef.test.~2~ +++ b/internal/test/env/inspector/hand/userdef.test.~2~ @@ -1 +1,37 @@ -;; 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 +;; 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 index de5d1fc9..9522f982 100644 Binary files a/internal/test/env/inspector/logs/inspect-defstruct.log 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~ index 29448604..c232d458 100644 --- a/internal/test/env/inspector/logs/inspect-defstruct.log.~1~ +++ b/internal/test/env/inspector/logs/inspect-defstruct.log.~1~ @@ -1 +1,3 @@ -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 +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~ index de5d1fc9..9522f982 100644 Binary files a/internal/test/env/inspector/logs/inspect-defstruct.log.~2~ 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 index 5798f2dd..b8f78599 100644 --- a/internal/test/env/process-controls/LOGS/PSW.LOG +++ b/internal/test/env/process-controls/LOGS/PSW.LOG @@ -1 +1,6 @@ -;;; 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 +;;; 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 index 4410b592..17aef4c6 100644 --- a/internal/test/env/process-controls/hand/PSW.REPORT +++ b/internal/test/env/process-controls/hand/PSW.REPORT @@ -1 +1,141 @@ -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 +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 diff --git a/internal/test/env/process-controls/hand/PSW.U b/internal/test/env/process-controls/hand/PSW.U index 0556574d..c1303b3d 100644 --- a/internal/test/env/process-controls/hand/PSW.U +++ b/internal/test/env/process-controls/hand/PSW.U @@ -1 +1,127 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/process-controls/hand/PSW.U.~1~ b/internal/test/env/process-controls/hand/PSW.U.~1~ index 8de14025..caf88684 100644 --- a/internal/test/env/process-controls/hand/PSW.U.~1~ +++ b/internal/test/env/process-controls/hand/PSW.U.~1~ @@ -1 +1,182 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/process-controls/hand/PSW.U.~2~ b/internal/test/env/process-controls/hand/PSW.U.~2~ index be76cf56..a49581e1 100644 --- a/internal/test/env/process-controls/hand/PSW.U.~2~ +++ b/internal/test/env/process-controls/hand/PSW.U.~2~ @@ -1 +1,182 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/process-controls/hand/PSW.U.~3~ b/internal/test/env/process-controls/hand/PSW.U.~3~ index 0556574d..c1303b3d 100644 --- a/internal/test/env/process-controls/hand/PSW.U.~3~ +++ b/internal/test/env/process-controls/hand/PSW.U.~3~ @@ -1 +1,127 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U b/internal/test/env/program-analysis/hand/BROWSER-PART2.U index ff6aff2b..b62a0d26 100644 --- a/internal/test/env/program-analysis/hand/BROWSER-PART2.U +++ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U @@ -1 +1,115 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ index 488606b5..998a0d61 100644 --- a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ +++ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~1~ @@ -1 +1,137 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ index ea15ddd0..c07b1d12 100644 --- a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ +++ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~2~ @@ -1 +1,131 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ index 34b7df7b..377e9c12 100644 --- a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ +++ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~3~ @@ -1 +1,118 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ index ff6aff2b..b62a0d26 100644 --- a/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ +++ b/internal/test/env/program-analysis/hand/BROWSER-PART2.U.~4~ @@ -1 +1,115 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/BROWSER.GRAPH b/internal/test/env/program-analysis/hand/BROWSER.GRAPH index dfb6266a..edabfd5a 100644 Binary files a/internal/test/env/program-analysis/hand/BROWSER.GRAPH 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 index 75c5ea9e..f3fa065d 100644 --- a/internal/test/env/program-analysis/hand/BROWSER.REPORT +++ b/internal/test/env/program-analysis/hand/BROWSER.REPORT @@ -1 +1,39 @@ - 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 + + + + +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 diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.REPORT b/internal/test/env/program-analysis/hand/DATABASEFNS.REPORT index bf8ab470..6b1ede0c 100644 --- a/internal/test/env/program-analysis/hand/DATABASEFNS.REPORT +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.REPORT @@ -1 +1,64 @@ -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 +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 diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U b/internal/test/env/program-analysis/hand/DATABASEFNS.U index 2cde5e8d..0bb077cc 100644 --- a/internal/test/env/program-analysis/hand/DATABASEFNS.U +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.U @@ -1 +1,145 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ index c8bf69f2..9f00b4f8 100644 --- a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~1~ @@ -1 +1,190 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ index 7ce81505..4de6c1e5 100644 --- a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~2~ @@ -1 +1,187 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ index 0032b647..0cd7fc26 100644 --- a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~3~ @@ -1 +1,185 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ index 2cde5e8d..0bb077cc 100644 --- a/internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ +++ b/internal/test/env/program-analysis/hand/DATABASEFNS.U.~4~ @@ -1 +1,145 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/INSPECT.U b/internal/test/env/program-analysis/hand/INSPECT.U index bb3aeca3..47b1aefc 100644 --- a/internal/test/env/program-analysis/hand/INSPECT.U +++ b/internal/test/env/program-analysis/hand/INSPECT.U @@ -1 +1,228 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~1~ b/internal/test/env/program-analysis/hand/INSPECT.U.~1~ index 0d2e99fa..802291f7 100644 --- a/internal/test/env/program-analysis/hand/INSPECT.U.~1~ +++ b/internal/test/env/program-analysis/hand/INSPECT.U.~1~ @@ -1 +1,265 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~2~ b/internal/test/env/program-analysis/hand/INSPECT.U.~2~ index 391a9c52..ed5aaf0c 100644 --- a/internal/test/env/program-analysis/hand/INSPECT.U.~2~ +++ b/internal/test/env/program-analysis/hand/INSPECT.U.~2~ @@ -1 +1,263 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~3~ b/internal/test/env/program-analysis/hand/INSPECT.U.~3~ index f0f87dbf..83e3456f 100644 --- a/internal/test/env/program-analysis/hand/INSPECT.U.~3~ +++ b/internal/test/env/program-analysis/hand/INSPECT.U.~3~ @@ -1 +1,261 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~4~ b/internal/test/env/program-analysis/hand/INSPECT.U.~4~ index dfa09165..4013941b 100644 --- a/internal/test/env/program-analysis/hand/INSPECT.U.~4~ +++ b/internal/test/env/program-analysis/hand/INSPECT.U.~4~ @@ -1 +1,228 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/INSPECT.U.~5~ b/internal/test/env/program-analysis/hand/INSPECT.U.~5~ index bb3aeca3..47b1aefc 100644 --- a/internal/test/env/program-analysis/hand/INSPECT.U.~5~ +++ b/internal/test/env/program-analysis/hand/INSPECT.U.~5~ @@ -1 +1,228 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/MASTERSCOPE.REPORT b/internal/test/env/program-analysis/hand/MASTERSCOPE.REPORT index 8e421ea2..495939a4 100644 --- a/internal/test/env/program-analysis/hand/MASTERSCOPE.REPORT +++ b/internal/test/env/program-analysis/hand/MASTERSCOPE.REPORT @@ -1 +1,86 @@ -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 +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 diff --git a/internal/test/env/program-analysis/hand/SPY.REPORT b/internal/test/env/program-analysis/hand/SPY.REPORT index ba722e9e..fde238bb 100644 --- a/internal/test/env/program-analysis/hand/SPY.REPORT +++ b/internal/test/env/program-analysis/hand/SPY.REPORT @@ -1 +1,88 @@ -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 +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 diff --git a/internal/test/env/program-analysis/hand/SPY.U b/internal/test/env/program-analysis/hand/SPY.U index cf710276..b7a349c1 100644 --- a/internal/test/env/program-analysis/hand/SPY.U +++ b/internal/test/env/program-analysis/hand/SPY.U @@ -1 +1,195 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/SPY.U.~1~ b/internal/test/env/program-analysis/hand/SPY.U.~1~ index c7d896fc..e664e979 100644 --- a/internal/test/env/program-analysis/hand/SPY.U.~1~ +++ b/internal/test/env/program-analysis/hand/SPY.U.~1~ @@ -1 +1,264 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/SPY.U.~2~ b/internal/test/env/program-analysis/hand/SPY.U.~2~ index e7d05e18..bf4eca13 100644 --- a/internal/test/env/program-analysis/hand/SPY.U.~2~ +++ b/internal/test/env/program-analysis/hand/SPY.U.~2~ @@ -1 +1,201 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/SPY.U.~3~ b/internal/test/env/program-analysis/hand/SPY.U.~3~ index cf710276..b7a349c1 100644 --- a/internal/test/env/program-analysis/hand/SPY.U.~3~ +++ b/internal/test/env/program-analysis/hand/SPY.U.~3~ @@ -1 +1,195 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/browser-part1.u b/internal/test/env/program-analysis/hand/browser-part1.u index 09efd41e..ab1459aa 100644 Binary files a/internal/test/env/program-analysis/hand/browser-part1.u 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~ index e3a506e0..e82011d5 100644 --- a/internal/test/env/program-analysis/hand/browser-part1.u.~1~ +++ b/internal/test/env/program-analysis/hand/browser-part1.u.~1~ @@ -1 +1,176 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/browser-part1.u.~2~ b/internal/test/env/program-analysis/hand/browser-part1.u.~2~ index dc2a2d40..6598224a 100644 --- a/internal/test/env/program-analysis/hand/browser-part1.u.~2~ +++ b/internal/test/env/program-analysis/hand/browser-part1.u.~2~ @@ -1 +1,151 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/browser-part1.u.~3~ b/internal/test/env/program-analysis/hand/browser-part1.u.~3~ index 09efd41e..ab1459aa 100644 Binary files a/internal/test/env/program-analysis/hand/browser-part1.u.~3~ 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 index fba107f8..45783f48 100644 --- a/internal/test/env/program-analysis/hand/databasefns.data +++ b/internal/test/env/program-analysis/hand/databasefns.data @@ -1 +1,22 @@ -(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 +(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 diff --git a/internal/test/env/program-analysis/hand/databasefns.data.~1~ b/internal/test/env/program-analysis/hand/databasefns.data.~1~ index f906e727..3e79d87f 100644 --- a/internal/test/env/program-analysis/hand/databasefns.data.~1~ +++ b/internal/test/env/program-analysis/hand/databasefns.data.~1~ @@ -1 +1,22 @@ -(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 +(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 diff --git a/internal/test/env/program-analysis/hand/databasefns.data.~2~ b/internal/test/env/program-analysis/hand/databasefns.data.~2~ index fba107f8..45783f48 100644 --- a/internal/test/env/program-analysis/hand/databasefns.data.~2~ +++ b/internal/test/env/program-analysis/hand/databasefns.data.~2~ @@ -1 +1,22 @@ -(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 +(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 diff --git a/internal/test/env/program-analysis/hand/inspect.report b/internal/test/env/program-analysis/hand/inspect.report index 394109e9..3a054bbf 100644 --- a/internal/test/env/program-analysis/hand/inspect.report +++ b/internal/test/env/program-analysis/hand/inspect.report @@ -1 +1,367 @@ -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 +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 diff --git a/internal/test/env/program-analysis/hand/masterscope.u b/internal/test/env/program-analysis/hand/masterscope.u index 9ba52eff..e572bb2e 100644 --- a/internal/test/env/program-analysis/hand/masterscope.u +++ b/internal/test/env/program-analysis/hand/masterscope.u @@ -1 +1,220 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~1~ b/internal/test/env/program-analysis/hand/masterscope.u.~1~ index 6cea39b4..21c69286 100644 --- a/internal/test/env/program-analysis/hand/masterscope.u.~1~ +++ b/internal/test/env/program-analysis/hand/masterscope.u.~1~ @@ -1 +1,230 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~2~ b/internal/test/env/program-analysis/hand/masterscope.u.~2~ index d1eb5da9..21f4995d 100644 --- a/internal/test/env/program-analysis/hand/masterscope.u.~2~ +++ b/internal/test/env/program-analysis/hand/masterscope.u.~2~ @@ -1 +1,220 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~3~ b/internal/test/env/program-analysis/hand/masterscope.u.~3~ index d60a3fa9..79b9ec50 100644 --- a/internal/test/env/program-analysis/hand/masterscope.u.~3~ +++ b/internal/test/env/program-analysis/hand/masterscope.u.~3~ @@ -1 +1,218 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~4~ b/internal/test/env/program-analysis/hand/masterscope.u.~4~ index 5b2b1405..8430cac5 100644 --- a/internal/test/env/program-analysis/hand/masterscope.u.~4~ +++ b/internal/test/env/program-analysis/hand/masterscope.u.~4~ @@ -1 +1,216 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~5~ b/internal/test/env/program-analysis/hand/masterscope.u.~5~ index 29f2f1cf..0e1e5c1a 100644 --- a/internal/test/env/program-analysis/hand/masterscope.u.~5~ +++ b/internal/test/env/program-analysis/hand/masterscope.u.~5~ @@ -1 +1,233 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~6~ b/internal/test/env/program-analysis/hand/masterscope.u.~6~ index 4561713b..4c36136c 100644 --- a/internal/test/env/program-analysis/hand/masterscope.u.~6~ +++ b/internal/test/env/program-analysis/hand/masterscope.u.~6~ @@ -1 +1,220 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/env/program-analysis/hand/masterscope.u.~7~ b/internal/test/env/program-analysis/hand/masterscope.u.~7~ index 9ba52eff..e572bb2e 100644 --- a/internal/test/env/program-analysis/hand/masterscope.u.~7~ +++ b/internal/test/env/program-analysis/hand/masterscope.u.~7~ @@ -1 +1,220 @@ -;; 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 +;; 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 + + + + diff --git a/internal/test/i/o/Display/Auto/CURSORTEST.SOURCE b/internal/test/i/o/Display/Auto/CURSORTEST.SOURCE deleted file mode 100644 index fa4f28de..00000000 --- a/internal/test/i/o/Display/Auto/CURSORTEST.SOURCE +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index ebb2453c..00000000 --- a/internal/test/i/o/Display/Auto/CURSORTEST.TEST +++ /dev/null @@ -1 +0,0 @@ -(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 deleted file mode 100644 index 9205cc1d..00000000 Binary files a/internal/test/i/o/Display/Hand/CURSOR.PROC and /dev/null differ diff --git a/internal/test/i/o/Display/Logs/CURSOR.LOG b/internal/test/i/o/Display/Logs/CURSOR.LOG deleted file mode 100644 index 01ed8569..00000000 Binary files a/internal/test/i/o/Display/Logs/CURSOR.LOG and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/FX80DRIVER.PROC b/internal/test/i/o/Hardcopy/Hand/FX80DRIVER.PROC deleted file mode 100644 index 1e77289a..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/FX80DRIVER.PROC and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.LOG b/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.LOG deleted file mode 100644 index 69be0b2b..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.LOG and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.PROC b/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.PROC deleted file mode 100644 index 8f19c0cf..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/PRESS/INTERPRESS.PROC and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/STREAMTESTS.DFASL b/internal/test/i/o/Hardcopy/Hand/STREAMTESTS.DFASL deleted file mode 100644 index 349997fb..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/STREAMTESTS.DFASL and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/STRESSTEST/STRESSTEST.TEDIT b/internal/test/i/o/Hardcopy/Hand/STRESSTEST/STRESSTEST.TEDIT deleted file mode 100644 index c46dbeee..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/STRESSTEST/STRESSTEST.TEDIT and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/fx80driver.log b/internal/test/i/o/Hardcopy/Hand/fx80driver.log deleted file mode 100644 index ace39487..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/fx80driver.log and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/streamtests.u b/internal/test/i/o/Hardcopy/Hand/streamtests.u deleted file mode 100644 index 7a99e603..00000000 --- a/internal/test/i/o/Hardcopy/Hand/streamtests.u +++ /dev/null @@ -1 +0,0 @@ -(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/02LOOKS.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/02LOOKS.TEDIT deleted file mode 100644 index 07e6b0eb..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/02LOOKS.TEDIT and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/03FONTS.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/03FONTS.TEDIT deleted file mode 100644 index 2c71beda..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/03FONTS.TEDIT and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/04PARA.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/04PARA.TEDIT deleted file mode 100644 index 5fc43559..00000000 --- a/internal/test/i/o/Hardcopy/Hand/testfiles/04PARA.TEDIT +++ /dev/null @@ -1,27 +0,0 @@ -04PARA.TEDIT - - - Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. - Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. -E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. - -Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button - -On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. - - Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. - Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.ÄHC What are the requirements for saving a file in a crash? In a normal |OGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. - -Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. -Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. - Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.ÄHC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot wit§ÍĂő t÷Ă@ Ş¨@ÂÜČčłú_ý€đĐ˙WœRŁK{sÁŤ4WÖúCŠ/.ÍŽ „JŽ,Œ.Íí „­ ¤ŽL$̍ „ííŽLd,lŽläÍ „­ d.Ź­ „­ŒŽŽL$n„,mŽ.ÍmŒd.ŻMěmΤČĺĚ$Í $ dŽ,Ln -dŽN.Íí dě͍.,Ím$ d, ..Œ -‹$ „ííŽLŽe,lŽ ä. -Äí$Ž.Œ-Í,$l$ ¤-Œn ÍĽ)ŒŒ­ DŹŽŽîÍ -äÉ -$ DŚEŹŽŽîÍ -¤í­nŽŒNŽln.Íí Dě -DŹŽDA (self index) (* dgb%: " 2-DEC-82 22:14") (CAR (FNTH (GetValue self 'indexedVars) index)))) (PutNthValue (LAMBDA (self varIndex newValue propName) (* dgb%: "23-NOV-82 00:11") (* Store away a value for an indexed variable) (COND ((NUMBERP varIndex) (StoreNthValue self varIndex newValue propName)) (T (PutValue self varIndex newValue propName))))) (StoreNthValue (LAMBDA (self index newValue propName) (* dgb%: " 2-DEC-82 18:35") (* * Store value for nth indexed variable. Used by objects having a VarLength mixin.) (PROG ((descr (FetchNthDescr! self index))) (RETURN (ObjSetValue self index newValue descr (ObjGetProp descr propName) propName))))) (StoreNthValueOnly (LAMBDA (self index newValue propName) (* edited%: "22-Dec-84 18:29") (* * Store away value for nth indexed variable. Used by objects having a VarLength mixin. Same as StoreNthValue except ignores activeValues.) (PROG ((descr (CAR (FNTH (@ indexedVars) index)))) (RETURN (COND ((NULL descr) (* Here if no value set yet.) (PROG (varLst numVars) (SETQ varLst (GetValueOnly self 'indexedVars)) (SETQ numVars (LENGTH varLst)) (* First allocate space for any vars of lower index.) (SETQ varLst (APPEND varLst (for i from 1 to (SUB1 (IDIFFERENCE index numVars)) collect (CONS NotSetValue)))) (* Then stick the newValue on the end.) (SETQ varLst (NCONC1 varLst (COND (propName (LIST NotSetValue propName newValue)) (T (CONS newValue))))) (PutValueOnly self 'indexedVars varLst) (RETURN newValue))) (T (* Usual case.) (ObjPutProp descr propName newValue))))))) ) (* ;;; "Class property stuff") (DEFINEQ (GetClass (LAMBDA (classRec propName) (* dgb%: " 5-Dec-84 14:47") (* Maps through a class and its metaClasses in order to find the value of a property on the class itself. Returns if property is set, or NotSetValue if none found.) (_ classRec GetClassProp propName))) (GetClassOnly (LAMBDA (classRec propName) (* smL "24-Sep-85 10:36") (* Maps through a class and its supers and returns property value with no activations. Returns NotSetValue if none found. If firstFoundFlg=T then returns CONS of value and flg indicating whether prop was found past first Class in inheritance chain) (COND ((NULL propName) (*AULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8))  -8K - .‹ş    Ď č   /B Ç}őDš Đ #”fK - .‹ş    ¸   /B Ç}őDš Đ #”4ˆ}zş \ No newline at end of file diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/05PAGE.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/05PAGE.TEDIT deleted file mode 100644 index b2193b8c..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/05PAGE.TEDIT and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/06LINE.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/06LINE.TEDIT deleted file mode 100644 index fcfdb908..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/06LINE.TEDIT and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/07NS.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/07NS.TEDIT deleted file mode 100644 index fc74cbd5..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/07NS.TEDIT and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/08IMOB.TEDIT b/internal/test/i/o/Hardcopy/Hand/testfiles/08IMOB.TEDIT deleted file mode 100644 index 63947bd7..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/08IMOB.TEDIT and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/13CHANGE.SKETCH b/internal/test/i/o/Hardcopy/Hand/testfiles/13CHANGE.SKETCH deleted file mode 100644 index 93f84905..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/13CHANGE.SKETCH and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/14TEXT.SKETCH b/internal/test/i/o/Hardcopy/Hand/testfiles/14TEXT.SKETCH deleted file mode 100644 index 7b109e04..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/14TEXT.SKETCH and /dev/null differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/15REVERSE.SKETCH b/internal/test/i/o/Hardcopy/Hand/testfiles/15REVERSE.SKETCH deleted file mode 100644 index b33f1c41..00000000 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/15REVERSE.SKETCH and /dev/null differ diff --git a/internal/test/i/o/Keyboard/Hand/ASKUSER.u b/internal/test/i/o/Keyboard/Hand/ASKUSER.u deleted file mode 100644 index 3dd57366..00000000 --- a/internal/test/i/o/Keyboard/Hand/ASKUSER.u +++ /dev/null @@ -1 +0,0 @@ -;; 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 deleted file mode 100644 index e7e3d534..00000000 --- a/internal/test/i/o/Keyboard/Hand/PromptForWord.u +++ /dev/null @@ -1 +0,0 @@ -;; 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 deleted file mode 100644 index db8d7d6f..00000000 --- a/internal/test/i/o/Keyboard/Hand/ReadNumber.u +++ /dev/null @@ -1 +0,0 @@ -;; 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 deleted file mode 100644 index 49a06d13..00000000 --- a/internal/test/i/o/Keyboard/Hand/TTYIN.u +++ /dev/null @@ -1 +0,0 @@ -;; 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 deleted file mode 100644 index 4fd42815..00000000 --- a/internal/test/i/o/Keyboard/logs/askuser.log +++ /dev/null @@ -1 +0,0 @@ -;;; 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 deleted file mode 100644 index 9acb4b92..00000000 --- a/internal/test/i/o/Keyboard/logs/keyboard.log +++ /dev/null @@ -1 +0,0 @@ -;;; 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~ deleted file mode 100644 index a23498ba..00000000 --- a/internal/test/i/o/Keyboard/logs/keyboard.log.~1~ +++ /dev/null @@ -1 +0,0 @@ -;;; 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~ deleted file mode 100644 index bab1b11e..00000000 --- a/internal/test/i/o/Keyboard/logs/keyboard.log.~2~ +++ /dev/null @@ -1 +0,0 @@ -;;; 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~ deleted file mode 100644 index 9acb4b92..00000000 --- a/internal/test/i/o/Keyboard/logs/keyboard.log.~3~ +++ /dev/null @@ -1 +0,0 @@ -;;; 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/io/Display/Auto/CURSORTEST.SOURCE b/internal/test/io/Display/Auto/CURSORTEST.SOURCE new file mode 100644 index 00000000..5a13f7cf --- /dev/null +++ b/internal/test/io/Display/Auto/CURSORTEST.SOURCE @@ -0,0 +1,101 @@ +(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 diff --git a/internal/test/io/Display/Auto/CURSORTEST.TEST b/internal/test/io/Display/Auto/CURSORTEST.TEST new file mode 100644 index 00000000..ee7334ae --- /dev/null +++ b/internal/test/io/Display/Auto/CURSORTEST.TEST @@ -0,0 +1,34 @@ +(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 + + diff --git a/internal/test/io/Display/Hand/CURSOR.PROC b/internal/test/io/Display/Hand/CURSOR.PROC new file mode 100644 index 00000000..2da0d953 Binary files /dev/null and b/internal/test/io/Display/Hand/CURSOR.PROC differ diff --git a/internal/test/io/Display/Logs/CURSOR.LOG b/internal/test/io/Display/Logs/CURSOR.LOG new file mode 100644 index 00000000..d555b949 Binary files /dev/null and b/internal/test/io/Display/Logs/CURSOR.LOG differ diff --git a/internal/test/io/Hardcopy/Hand/FX80DRIVER.PROC b/internal/test/io/Hardcopy/Hand/FX80DRIVER.PROC new file mode 100644 index 00000000..dcd96974 Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/FX80DRIVER.PROC differ diff --git a/internal/test/io/Hardcopy/Hand/PRESS/INTERPRESS.LOG b/internal/test/io/Hardcopy/Hand/PRESS/INTERPRESS.LOG new file mode 100644 index 00000000..8c101b54 Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/PRESS/INTERPRESS.LOG differ diff --git a/internal/test/io/Hardcopy/Hand/PRESS/INTERPRESS.PROC b/internal/test/io/Hardcopy/Hand/PRESS/INTERPRESS.PROC new file mode 100644 index 00000000..b2f289c2 Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/PRESS/INTERPRESS.PROC differ diff --git a/internal/test/io/Hardcopy/Hand/STREAMTESTS.DFASL b/internal/test/io/Hardcopy/Hand/STREAMTESTS.DFASL new file mode 100644 index 00000000..7b3a8e04 Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/STREAMTESTS.DFASL differ diff --git a/internal/test/io/Hardcopy/Hand/STRESSTEST/STRESSTEST.TEDIT b/internal/test/io/Hardcopy/Hand/STRESSTEST/STRESSTEST.TEDIT new file mode 100644 index 00000000..f6a87f16 Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/STRESSTEST/STRESSTEST.TEDIT differ diff --git a/internal/test/io/Hardcopy/Hand/fx80driver.log b/internal/test/io/Hardcopy/Hand/fx80driver.log new file mode 100644 index 00000000..a5a14116 Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/fx80driver.log differ diff --git a/internal/test/io/Hardcopy/Hand/streamtests.u b/internal/test/io/Hardcopy/Hand/streamtests.u new file mode 100644 index 00000000..f0d39bfe --- /dev/null +++ b/internal/test/io/Hardcopy/Hand/streamtests.u @@ -0,0 +1,182 @@ +(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 diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/01UR.TEDIT b/internal/test/io/Hardcopy/Hand/testfiles/00PLAINTEXT.TEDIT similarity index 99% rename from internal/test/i/o/Hardcopy/Hand/testfiles/01UR.TEDIT rename to internal/test/io/Hardcopy/Hand/testfiles/00PLAINTEXT.TEDIT index 0d73c162..b09fd268 100644 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/01UR.TEDIT and b/internal/test/io/Hardcopy/Hand/testfiles/00PLAINTEXT.TEDIT differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/00PLAINTEXT.TEDIT b/internal/test/io/Hardcopy/Hand/testfiles/01UR.TEDIT similarity index 53% rename from internal/test/i/o/Hardcopy/Hand/testfiles/00PLAINTEXT.TEDIT rename to internal/test/io/Hardcopy/Hand/testfiles/01UR.TEDIT index d6faf8f0..92a80499 100644 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/00PLAINTEXT.TEDIT and b/internal/test/io/Hardcopy/Hand/testfiles/01UR.TEDIT differ diff --git a/internal/test/io/Hardcopy/Hand/testfiles/02LOOKS.TEDIT b/internal/test/io/Hardcopy/Hand/testfiles/02LOOKS.TEDIT new file mode 100644 index 00000000..ae5196d7 Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/testfiles/02LOOKS.TEDIT differ diff --git a/internal/test/io/Hardcopy/Hand/testfiles/03FONTS.TEDIT b/internal/test/io/Hardcopy/Hand/testfiles/03FONTS.TEDIT new file mode 100644 index 00000000..c2b7fadd Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/testfiles/03FONTS.TEDIT differ diff --git a/internal/test/io/Hardcopy/Hand/testfiles/04PARA.TEDIT b/internal/test/io/Hardcopy/Hand/testfiles/04PARA.TEDIT new file mode 100644 index 00000000..9a1b8f21 --- /dev/null +++ b/internal/test/io/Hardcopy/Hand/testfiles/04PARA.TEDIT @@ -0,0 +1,85 @@ +04PARA.TEDIT Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.ÄHC What are the requirements for saving a file in a crash? In a normal |OGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.DOC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot without TEdit PUT and QUIT? Definitions Case-sensitive Treating the upper and lower cases of the same letter as distinct symbols. E.g. if a search string contains a capital X, a lower-case x will not qualify as a match.Middle button On a 2-button mouse, pressing both buttons at once will have the same effect as pressing the middle button on a 3-button mouse. Local copy: {DSK}REQT PUBLIC: {ROSE}SPEC>TEDIT.ÄHC What are the requirements for saving a file in a crash? In a normal LOGOUT and boot wit§ÍĂő +t÷Ă@ Ş¨@ÂÜČčłú_ý€đĐ˙WœRŁK{sÁŤ4WÖúCŠ/.ÍŽ „JŽ,Œ.Íí „­ ¤ŽL$̍ „ííŽLd,lŽläÍ „­ d.Ź­ „­ŒŽŽL$n„,mŽ.ÍmŒd.ŻMěmΤČĺĚ$Í $ dŽ,Ln dŽN.Íí dě͍.,Ím$ d, ..Œ ‹$ „ííŽLŽe,lŽ ä. Äí$Ž.Œ-Í,$l$ ¤-Œn ÍĽ)ŒŒ­ DŹŽŽîÍ äÉ $ DŚEŹŽŽîÍ ¤í­nŽŒNŽln.Íí Dě DŹŽDA (self index) (* dgb%: " 2-DEC-82 22:14") + (CAR (FNTH (GetValue self 'indexedVars) + index)))) + +(PutNthValue + (LAMBDA (self varIndex newValue propName) (* dgb%: "23-NOV-82 00:11") + (* Store away a value for an indexed + variable) + (COND + ((NUMBERP varIndex) + (StoreNthValue self varIndex newValue propName)) + (T (PutValue self varIndex newValue propName))))) + +(StoreNthValue + (LAMBDA (self index newValue propName) (* dgb%: " 2-DEC-82 18:35") + + (* * Store value for nth indexed variable. + Used by objects having a VarLength mixin.) + + (PROG ((descr (FetchNthDescr! self index))) + (RETURN (ObjSetValue self index newValue descr (ObjGetProp descr propName) + propName))))) + +(StoreNthValueOnly + (LAMBDA (self index newValue propName) (* edited%: "22-Dec-84 18:29") + + (* * Store away value for nth indexed variable. + Used by objects having a VarLength mixin. + Same as StoreNthValue except ignores activeValues.) + + (PROG ((descr (CAR (FNTH (@ indexedVars) + index)))) + (RETURN (COND + ((NULL descr) (* Here if no value set yet.) + (PROG (varLst numVars) + (SETQ varLst (GetValueOnly self 'indexedVars)) + (SETQ numVars (LENGTH varLst)) (* First allocate space for any vars + of lower index.) + (SETQ varLst (APPEND varLst (for i from 1 + to (SUB1 (IDIFFERENCE index numVars)) + collect (CONS NotSetValue)))) + (* Then stick the newValue on the end.) + (SETQ varLst (NCONC1 varLst (COND + (propName (LIST NotSetValue propName + newValue)) + (T (CONS newValue))))) + (PutValueOnly self 'indexedVars varLst) + (RETURN newValue))) + (T (* Usual case.) + (ObjPutProp descr propName newValue))))))) +) + + + +(* ;;; "Class property stuff") + +(DEFINEQ + +(GetClass + (LAMBDA (classRec propName) (* dgb%: " 5-Dec-84 14:47") + + (* Maps through a class and its metaClasses in order to find the value of a + property on the class itself. Returns if property is set, or NotSetValue if + none found.) + + (_ classRec GetClassProp propName))) + +(GetClassOnly + (LAMBDA (classRec propName) (* smL "24-Sep-85 10:36") + + (* Maps through a class and its supers and returns property value with no + activations. Returns NotSetValue if none found. + If firstFoundFlg=T then returns CONS of value and flg indicating whether prop + was found past first Class in inheritance chain) + + (COND + ((NULL propName) (*AULTFONT 1 (GACHA 10) (GACHA 8) (TERMINAL 8)) + 8K  .‹ş  +  +Ď č   /B +Ç}őDš Đ #”fK  .‹ş  +  +¸   /B +Ç}őDš Đ #”4ˆ}zş \ No newline at end of file diff --git a/internal/test/io/Hardcopy/Hand/testfiles/05PAGE.TEDIT b/internal/test/io/Hardcopy/Hand/testfiles/05PAGE.TEDIT new file mode 100644 index 00000000..2e2aa616 Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/testfiles/05PAGE.TEDIT differ diff --git a/internal/test/io/Hardcopy/Hand/testfiles/06LINE.TEDIT b/internal/test/io/Hardcopy/Hand/testfiles/06LINE.TEDIT new file mode 100644 index 00000000..7dc607cd Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/testfiles/06LINE.TEDIT differ diff --git a/internal/test/io/Hardcopy/Hand/testfiles/07NS.TEDIT b/internal/test/io/Hardcopy/Hand/testfiles/07NS.TEDIT new file mode 100644 index 00000000..af10a64c Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/testfiles/07NS.TEDIT differ diff --git a/internal/test/io/Hardcopy/Hand/testfiles/08IMOB.TEDIT b/internal/test/io/Hardcopy/Hand/testfiles/08IMOB.TEDIT new file mode 100644 index 00000000..f29b6b13 Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/testfiles/08IMOB.TEDIT differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/10MIXED.SKETCH b/internal/test/io/Hardcopy/Hand/testfiles/10MIXED.SKETCH similarity index 75% rename from internal/test/i/o/Hardcopy/Hand/testfiles/10MIXED.SKETCH rename to internal/test/io/Hardcopy/Hand/testfiles/10MIXED.SKETCH index 7afc2977..3793a475 100644 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/10MIXED.SKETCH and b/internal/test/io/Hardcopy/Hand/testfiles/10MIXED.SKETCH differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/11STRAIGHT.SKETCH b/internal/test/io/Hardcopy/Hand/testfiles/11STRAIGHT.SKETCH similarity index 66% rename from internal/test/i/o/Hardcopy/Hand/testfiles/11STRAIGHT.SKETCH rename to internal/test/io/Hardcopy/Hand/testfiles/11STRAIGHT.SKETCH index fefc3673..e5b2205b 100644 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/11STRAIGHT.SKETCH and b/internal/test/io/Hardcopy/Hand/testfiles/11STRAIGHT.SKETCH differ diff --git a/internal/test/i/o/Hardcopy/Hand/testfiles/12CURVE.SKETCH b/internal/test/io/Hardcopy/Hand/testfiles/12CURVE.SKETCH similarity index 77% rename from internal/test/i/o/Hardcopy/Hand/testfiles/12CURVE.SKETCH rename to internal/test/io/Hardcopy/Hand/testfiles/12CURVE.SKETCH index a05cedd9..2a750f7c 100644 Binary files a/internal/test/i/o/Hardcopy/Hand/testfiles/12CURVE.SKETCH and b/internal/test/io/Hardcopy/Hand/testfiles/12CURVE.SKETCH differ diff --git a/internal/test/io/Hardcopy/Hand/testfiles/13CHANGE.SKETCH b/internal/test/io/Hardcopy/Hand/testfiles/13CHANGE.SKETCH new file mode 100644 index 00000000..9d0e2ee0 Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/testfiles/13CHANGE.SKETCH differ diff --git a/internal/test/io/Hardcopy/Hand/testfiles/14TEXT.SKETCH b/internal/test/io/Hardcopy/Hand/testfiles/14TEXT.SKETCH new file mode 100644 index 00000000..5442c5fd Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/testfiles/14TEXT.SKETCH differ diff --git a/internal/test/io/Hardcopy/Hand/testfiles/15REVERSE.SKETCH b/internal/test/io/Hardcopy/Hand/testfiles/15REVERSE.SKETCH new file mode 100644 index 00000000..06e157d7 Binary files /dev/null and b/internal/test/io/Hardcopy/Hand/testfiles/15REVERSE.SKETCH differ diff --git a/internal/test/io/Keyboard/Hand/ASKUSER.u b/internal/test/io/Keyboard/Hand/ASKUSER.u new file mode 100644 index 00000000..d91bc14c --- /dev/null +++ b/internal/test/io/Keyboard/Hand/ASKUSER.u @@ -0,0 +1,142 @@ +;; 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 + + diff --git a/internal/test/io/Keyboard/Hand/PromptForWord.u b/internal/test/io/Keyboard/Hand/PromptForWord.u new file mode 100644 index 00000000..b59886d1 --- /dev/null +++ b/internal/test/io/Keyboard/Hand/PromptForWord.u @@ -0,0 +1,196 @@ +;; 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 + + diff --git a/internal/test/io/Keyboard/Hand/ReadNumber.u b/internal/test/io/Keyboard/Hand/ReadNumber.u new file mode 100644 index 00000000..57622892 --- /dev/null +++ b/internal/test/io/Keyboard/Hand/ReadNumber.u @@ -0,0 +1,251 @@ +;; 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 + + diff --git a/internal/test/io/Keyboard/Hand/TTYIN.u b/internal/test/io/Keyboard/Hand/TTYIN.u new file mode 100644 index 00000000..60875d5b --- /dev/null +++ b/internal/test/io/Keyboard/Hand/TTYIN.u @@ -0,0 +1,275 @@ +;; 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 + + diff --git a/internal/test/io/Keyboard/logs/askuser.log b/internal/test/io/Keyboard/logs/askuser.log new file mode 100644 index 00000000..6c78fd19 --- /dev/null +++ b/internal/test/io/Keyboard/logs/askuser.log @@ -0,0 +1,5 @@ +;;; 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/io/Keyboard/logs/keyboard.log b/internal/test/io/Keyboard/logs/keyboard.log new file mode 100644 index 00000000..8bffe6e1 --- /dev/null +++ b/internal/test/io/Keyboard/logs/keyboard.log @@ -0,0 +1,15 @@ +;;; 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/io/Keyboard/logs/keyboard.log.~1~ b/internal/test/io/Keyboard/logs/keyboard.log.~1~ new file mode 100644 index 00000000..308b933d --- /dev/null +++ b/internal/test/io/Keyboard/logs/keyboard.log.~1~ @@ -0,0 +1,13 @@ +;;; 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/io/Keyboard/logs/keyboard.log.~2~ b/internal/test/io/Keyboard/logs/keyboard.log.~2~ new file mode 100644 index 00000000..eab193eb --- /dev/null +++ b/internal/test/io/Keyboard/logs/keyboard.log.~2~ @@ -0,0 +1,13 @@ +;;; 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/io/Keyboard/logs/keyboard.log.~3~ b/internal/test/io/Keyboard/logs/keyboard.log.~3~ new file mode 100644 index 00000000..8bffe6e1 --- /dev/null +++ b/internal/test/io/Keyboard/logs/keyboard.log.~3~ @@ -0,0 +1,15 @@ +;;; 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 index e4aa3c6b..b895ca07 100644 Binary files a/internal/test/loops/LOOPS-SETUP.TEDIT 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 index c16a488e..9e9386fe 100644 --- a/internal/test/loops/LOOPS-TESTER-2-1 +++ b/internal/test/loops/LOOPS-TESTER-2-1 @@ -1 +1,251 @@ -(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 +(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 diff --git a/internal/test/loops/LOOPS-TESTER-2-1.dfasl b/internal/test/loops/LOOPS-TESTER-2-1.dfasl index 6b80a93a..77fc6574 100644 Binary files a/internal/test/loops/LOOPS-TESTER-2-1.dfasl 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 index 55752ce2..cc5bc0aa 100644 --- a/internal/test/loops/LOOPS-TESTER-2-2 +++ b/internal/test/loops/LOOPS-TESTER-2-2 @@ -1 +1,35 @@ -(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 +(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 diff --git a/internal/test/loops/LOOPS-TESTER-2-2.dfasl b/internal/test/loops/LOOPS-TESTER-2-2.dfasl index 26f7cdde..5240ff0c 100644 Binary files a/internal/test/loops/LOOPS-TESTER-2-2.dfasl 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 index d089d9a4..35371cee 100644 --- a/internal/test/loops/LOOPS-TESTER-2-4 +++ b/internal/test/loops/LOOPS-TESTER-2-4 @@ -1 +1,184 @@ -(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 +(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 diff --git a/internal/test/loops/LOOPS-TESTER-2-4.dfasl b/internal/test/loops/LOOPS-TESTER-2-4.dfasl index 72da8b6d..912665c9 100644 Binary files a/internal/test/loops/LOOPS-TESTER-2-4.dfasl 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 index d1f19b25..97c4029b 100644 --- a/internal/test/loops/LOOPS-TESTER-BASICS +++ b/internal/test/loops/LOOPS-TESTER-BASICS @@ -1 +1,29 @@ -(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 +(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 diff --git a/internal/test/loops/LOOPS-TESTER-BASICS.dfasl b/internal/test/loops/LOOPS-TESTER-BASICS.dfasl index 6642fe55..4d70cbe0 100644 Binary files a/internal/test/loops/LOOPS-TESTER-BASICS.dfasl and b/internal/test/loops/LOOPS-TESTER-BASICS.dfasl differ diff --git a/internal/test/lyric/DO-TEST b/internal/test/lyric/DO-TEST index c5ff25d1..a7b2f3eb 100644 --- a/internal/test/lyric/DO-TEST +++ b/internal/test/lyric/DO-TEST @@ -1 +1,303 @@ -(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 +(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 diff --git a/internal/test/lyric/DO-TEST.dfasl b/internal/test/lyric/DO-TEST.dfasl index a2c890cb..50e2eb0c 100644 Binary files a/internal/test/lyric/DO-TEST.dfasl 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 index 870c2623..f90c1469 100644 Binary files a/internal/test/lyric/do-test.tedit and b/internal/test/lyric/do-test.tedit differ diff --git a/internal/test/tools/AUTOTEST b/internal/test/tools/AUTOTEST new file mode 100644 index 00000000..48b8c82d --- /dev/null +++ b/internal/test/tools/AUTOTEST @@ -0,0 +1,1693 @@ +(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 diff --git a/internal/test/tools/AUTOTEST.LCOM b/internal/test/tools/AUTOTEST.LCOM new file mode 100644 index 00000000..249539ca 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..9793decd --- /dev/null +++ b/internal/test/tools/AUTOTEST.TEDIT @@ -0,0 +1,3 @@ +AUTOMATED TEST HARNESS INTERFACES This document specifies the interfaces to the automated tester harness. The harness is composed of two parts: the top-level tester and the individual test handler. The name of the file to load for this is AUTOTEST.DCOM in the top level of the standard test directory. [We need to set up this standard test directory.] The top-level tester is set up similarly to the package FileBrowser. Items are selected in the same manner as FileBrowser, and are displayed similarly. The portions of the display are as follows (from top to bottom): 1. A prompt window for displaying messages and getting new input. 2. A command menu with the following commands: TEST Tests sequentially each of the items selected in the test files window. Testing consists of loading the file containing the test suite, calling a function which has the same name as the NAME field of the filename (this function must return NIL iff the test suite is not successful), then undoing (as best as possible) the side-effects of loading and running the test suite. The function which is called is passed one argument: the name of the directory that the test suite came from (including the host name). If this item is selected with the middle button, then first it asks for the name of the file to direct output to (selecting this item with the left button will direct output to T, the process' TTY display stream), before running the test suites. All output directed to NIL, the default output stream, will go to this file, including all error messages generated by the automated test harness and by TEST-MESSAGE (see below). It is assumed that no other activity is being performed while testing is in progress. ABORT Aborts any tests in progress. Confirmation (via clicking the left mouse button) is required. New tests can be selected, tests can be re-run, etc. after an abort. PAUSE Temporarily pauses any tests in progress. Any pause time does not count in the computation of timeouts (see below). RESUME Resumes PAUSEd testing. DIRECTORY Does a directory of files (the directory pattern is prompted for in the prompt window) and puts them in the test files window in order to have a new set of test suites to select from. PRINT Prints the results of testing the selected files. Selecting this item with the left button will print on the default printer. Selecting this item with the middle button will put up a menu asking whether to print to a printer or a file. If a printer is selected, then a menu asking for the printer to print to (gotten from DEFAULTPRINTINGHOST plus the selection "Other"; the latter will ask for the name of a new printer to print to) is put up. Otherwise, if a file is selected, then the user will be prompted for the name of a file to print to (also, if the type of output is not obvious, i.e. PRESS or INTERPRESS, then the user will be prompted for the type of output). When the Hardcopy item of the right button menu is selected for this window, then this command is performed (except that selecting the main item does the default, while selecting either the printer or the file sub-item starts the sequence of questions at the intuitive place). SUMMARIZE Similar to PRINT, except that it prints only those tests (out of the selected tests) which failed. QUIT Quits testing, closing the window and throwing away all test results, test names, etc. stored in the window. If any tests are currently in progress, then confirmation (via clicking the left mouse button) is required in order to quit (in this case an ABORT is performed before quitting). When the tester window is closed, this command is performed. 3. A status window, which has the following fields: Suite The name of the test suite currently running. ID The ID of the current test being performed by SINGLE-TEST. Start The time that the current test was started. End The time that the current test will time out at, or blank if none. 4. A summary window, which has the following fields: Files The number of files in the test files window. Selected The number of files (test suites) selected in the test files window. Completed The number of test suites completed. Successful The number of test suites which were successful. 5. The directory pattern used to select the test suite files. Unless otherwise overridden, the directory pattern by default only selects the latest version of each test suite file. Also, unless otherwise overridden, the directory pattern by default only selects .DCOM files (if a source file is more recent than the corresponding compiled file, then an error message is displayed). 6. A heading line which identifies each column in the test files window. 7. The test files window which has a line for each test suite file which matches the directory pattern. The left button on an entry selects only that entry. The middle button on an unselected entry adds that entry to the selected entries. The middle button on a selected entry removes that entry from the selected entries. The right button in the left portion of an entry will extend the current entries to include this entry and all the entries inbetween (the mouse cursor will change to a right pointing arrow when this action is enabled). This window is also scrollable (both vertically and horizontally). When each test is completed, a line is drawn through the entry. This window has the following columns: Result: The result of testing using the corresponding test file. The following can appear in this column: ? The test suite has not been completed or possibly even initiated, so no results are known. pass The test suite completed successfully. FAIL The test suite did not complete successfully. This could be because a test in the test suite returned bad results, a test in the test suite aborted, a test in the test suite timed out, etc.. Name: The NAME portion of the test suite file name. File: The full name of the test suite file (except for the host name). When the tester is loaded, a new entry is added to the background menu, labelled AutomatedTester. When this is selected, an automated tester process is started, which will prompt (in the system prompt window) for a directory pattern which is used to initialize the test files window. The individual test handler is a function which is called by the top-level function of each test suite (the function which was called by the top-level tester). This function has the following interface (all arguments must be supplied): Name: SINGLE-TEST (LAMBDA function). Arguments: IDENTIFIER The integer identifier of this test. Identifiers are assigned manually and are unique across all tests in all test suites. [We need to set up an index file for this purpose, in the standard test directory.] EXPRESSION The expression to evaluate (e.g. (PLUS 2 3)). Note that in order to get the right results, this argument would normally be quoted with QUOTE (or ') or be an expression such as (QUOTE (fn)), where fn is a separately defined function (and is therefore compiled code, instead of interpreted code). PREDICATE The (one argument) predicate to check the result (e.g. (LAMBDA (X) (EQP X 5)) or NULL). This must be NIL iff the result was not correct (non-NIL indicates that the result was correct). If more than one error can occur, then output identifying the specific error should printed (to NIL). Note that this argument would normally be quoted with QUOTE (or ') or FUNCTION in order to get the right results. TIMEOUT The maximum elapsed (wall) time (in milliseconds) that the expression EXPRESSION should take to complete (NIL implies that no timeout is to be used). With the current Interlisp-D process mechanism, this will only work if the expression (or anything it calls) does a BLOCK, so that another process can check to see whether a timeout has occurred. Also, the timing is not exact, so the actual timeout used will be no less than the value supplied. Time elapsed while the test was PAUSEd is not counted in checking for a timeout. Result: NIL iff the test was not successful (due to PREDICATE returning NIL, a NOBIND being returned, a timeout occurring, or a deep exit (such as an abort) occurring). Non-NIL indicates success. Description: This function evaluates the expression EXPRESSION and checks the result with the predicate PREDICATE, returning the result from calling PREDICATE. If NOBIND is returned from either EXPRESSION or PREDICATE, then an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. If the timeout is exceeded (and timeouts can be checked) then the evaluation of the expression is aborted and an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. If a deep exit occured in either EXPRESSION or PREDICATE (e.g. from aborting of the expression), then an error message is printed (to NIL) and a NIL is returned from SINGLE-TEST. Side Effects: A message can be printed (to NIL). Assumptions: Deep exits completely out of EXPRESSION or PREDICATE are not part of the successful behaviour of either EXPRESSION or PREDICATE (any such exits must be caught internally within EXPRESSION or PREDICATE). Note that deep exits are caught via ERRORSET, so RETFROM, RETTO, RETEVAL, RESUME, etc. are not caught. There is a function available which prints out an easily identifiable error message in a standard format to the standard ouput. Thisfunction has the following interface (all arguments must be supplied): Name: TEST-MESSAGE (LAMBDA function). Arguments: IDENTIFIER The integer identifier of this test (as given to SINGLE-TEST). TEXT The text of the error message. INFO Information specific to this instance of this error. Result: Not useful. Description: The error message along with the test identifier and the specific information is printed to NIL in a standard, easy to notice format. Side Effects: A message is printed (to NIL). Assumptions: None. Some side-effects of the automated test harness are: 1. The History List for the Programmer's Assistant is used, therefore old items are lost and a REDO, etc. immediately after testing will redo the last command that the automated test harness performed, not the last item printed in the top level typescript window. 2. The top level value and the value in the Programmer's Assistant of HELPFLAG are changed for the duration of running a test suite. 3. Extra processes are run to perform the testing. Known deficiencies with the implementation are: 1. ABORTing and PAUSEing can only be done between individual tests. 2. If a test is aborted between individual tests, but not between tests suites, then the effects of LOADing and running that test suite are not UNDOne. 3. Some errors are not caught, and some side effects are not undone if errors occur. Some possible extensions to this package are: 1. Utilities to help with testing for deliberate errors. 2. Utilities to help with automating input which would normally be manual. (LIST ((PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY CLASSIC OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT BOLD)) (270 36 72 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SIZE 10 FAMILY CLASSIC OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT BOLD)) (270 36 72 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL))) (PAGE NIL NIL (0 0 612 792) ((FOLIO NIL (PARALOOKS (QUAD CENTERED) CHARLOOKS (SUPERSCRIPT 0 SIZE 10 FAMILY CLASSIC OVERLINE OFF STRIKEOUT OFF UNDERLINE OFF SLOPE REGULAR WEIGHT BOLD)) (270 36 72 36) NIL) (TEXT NIL NIL (72 72 468 648) NIL)))))<–Ô–x¨Ô¨<xÔx<Ô<ÔTÔTCLASSIC +CLASSIC +"1ŰB/Ş{Âżmc44>2G54N/<€IĎk],Ĺ4Hí% ˆS3ŸĆŸ1@Í& J$:”-5…30D˜U.9K*Ɉzš \ No newline at end of file diff --git a/internal/test/Tools/AUTOTEST.TEDIT b/internal/test/tools/AUTOTEST.TEDIT-orig similarity index 100% rename from internal/test/Tools/AUTOTEST.TEDIT rename to internal/test/tools/AUTOTEST.TEDIT-orig diff --git a/internal/test/tools/DO-TEST b/internal/test/tools/DO-TEST new file mode 100644 index 00000000..59886fec 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..53b9abb5 --- /dev/null +++ b/internal/test/tools/DO-TEST-MENU @@ -0,0 +1,54 @@ +(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 diff --git a/internal/test/Tools/DO-TEST-MENU.dfasl b/internal/test/tools/DO-TEST-MENU.DFASL similarity index 55% rename from internal/test/Tools/DO-TEST-MENU.dfasl rename to internal/test/tools/DO-TEST-MENU.DFASL index 64794fb4..d706f623 100644 Binary files a/internal/test/Tools/DO-TEST-MENU.dfasl and b/internal/test/tools/DO-TEST-MENU.DFASL differ diff --git a/internal/test/Tools/DO-TEST.dfasl b/internal/test/tools/DO-TEST.DFASL similarity index 100% rename from internal/test/Tools/DO-TEST.dfasl rename to internal/test/tools/DO-TEST.DFASL diff --git a/internal/test/tools/FDEVTEST b/internal/test/tools/FDEVTEST new file mode 100644 index 00000000..6fb40564 --- /dev/null +++ b/internal/test/tools/FDEVTEST @@ -0,0 +1,242 @@ +(FILECREATED " 6-Sep-85 10:23:52" {DSK}FDEVTEST.;2 + + changes to: (VARS FDEVTESTCOMS)) + + +(* Lots more has to be done here but I have the basic data structures here needed to create the test code) + +(* Copyright (c) 1985 by Xerox Corporation. All rights reserved.) + +(PRETTYCOMPRINT FDEVTESTCOMS) + +(RPAQQ FDEVTESTCOMS [(RECORDS FDEV) + (MACROS .APPLY. FDEVOP) + (P (MOVD (QUOTE APPLY*) + (QUOTE SPREADAPPLY*]) +[DECLARE: EVAL@COMPILE + +(DATATYPE FDEV ((DEVICENAME POINTER) + (RESETABLE FLAG) + (RANDOMACCESSP FLAG) + (NODIRECTORIES FLAG) + (PAGEMAPPED FLAG) (* True if i/o handled by pmap routines) + (FDBINABLE FLAG) (* Copied as a microcode flag for INPUT streams formed on this + device) + (FDBOUTABLE FLAG) + (FDEXTENDABLE FLAG) + (BUFFERED FLAG) (* True implies that the device supports the BIN & BOUT uCode  + conventions, and implements the GETNEXTBUFFER method) + (* Device operations:) + (REMOTEP FLAG) (* true if device not local to machine) + (SUBDIRECTORIES FLAG) (* true if device has real subdirectories) + (NIL 6 FLAG) + (CLOSEFILE POINTER) (* (stream) => closes stream, returns it) + (DELETEFILE POINTER) (* (name) => deletes file so named, returning name, or NIL on  + failure. RECOG=OLDEST) + (DIRECTORYNAMEP POINTER) (* (host/dir) => true if directory exists on host) + (EVENTFN POINTER) (* (device event), called before/after logout, sysout,  + makesys) + (GENERATEFILES POINTER) + + (* (device pattern) => generator object for files matching pattern. Car of object is generator function, cdr is  + arbitrary state. Generator fn returns next file, or NIL when finished) + + + (GETFILEINFO POINTER) (* (stream/name attribute device) => value of attribute for  + open stream or name of closed file) + (GETFILENAME POINTER) (* (name recog device) => full file name) + (HOSTNAMEP POINTER) + + (* (hostname {device}) => T if hostname is valid. If device is given, return a FDEV for this {new} host, or T to use + existing device) + + + (OPENFILE POINTER) (* (name access recog otherinfo device) => new stream open on  + this device, or NIL if name not found) + (READPAGES POINTER) + + (* (stream firstpage# buflist) => # of bytes read, starting at firstpage#, reading into buflist, a list of buffers  + or a single buffer (the usual case)) + + + (REOPENFILE POINTER) + + (* (name access recog otherinfo device stream) like openfile, but called after logout to revalidate file, so  + optionally uses info in old stream to keep this opening like the previous) + + + (SETFILEINFO POINTER) (* (stream/name attribute newvalue device) sets attribute of  + open stream or closed file of given name) + (TRUNCATEFILE POINTER) (* (stream page offset) make stream's eof be at page,offset,  + discarding anything after it) + (WRITEPAGES POINTER) (* (stream firstpage# buflist) writes from buflist to stream  + starting at firstpage# of stream) + (BIN POINTER) (* (stream) => next byte of input) + (BOUT POINTER) (* (stream byte) output byte to stream) + (PEEKBIN POINTER) (* (stream) => next byte without advancing position in stream) + (READP POINTER) (* (stream flag) => T if there is input available from stream) + (BACKFILEPTR POINTER) (* (stream) backs up "fileptr" by one. + Stream is only required to be able to do this once, i.e.  + one-character buffer suffices) + (DEVICEINFO POINTER) (* arbitrary device-specific info stored here) + (FORCEOUTPUT POINTER) (* (stream waitForFinish) flushes out to device anything that  + is buffered awaiting transmission) + (LASTC POINTER) (* Should be possible only if RANDOMACCESSP) + (SETFILEPTR POINTER) + (GETFILEPTR POINTER) + (GETEOFPTR POINTER) + (EOFP POINTER) + (BLOCKIN POINTER) (* (stream buffer byteoffset nbytes)) + (BLOCKOUT POINTER) (* (stream buffer byteoffset nbytes)) + (RENAMEFILE POINTER) (* oldfile newfile device) + (RELEASEBUFFER POINTER) (* (stream) => Does whatever appropriate when CBUFPTR is  + released) + (GETNEXTBUFFER POINTER) + + (* (stream whatfor noerrorflg) => Disposes of current buffer and optionally reads next. whatfor is READ or WRITE. + Can cause EOF error unless noerrorflg) + + + (SETEOFPTR POINTER) (* (stream length) => truncates or lengthens stream to  + indicated length) + (FREEPAGECOUNT POINTER) (* (host/dir dev) => # of free pages on host/dir) + (MAKEDIRECTORY POINTER) (* (host/dir dev)) + (WINDOWOPS POINTER) (* window system operations - + type WSOPS) + (WINDOWDATA POINTER) (* data for window systems) + (CHECKFILENAME POINTER) (* (name dev) => name if it is well-formed file name for dev) + (HOSTALIVEP POINTER) (* (host dev) => true if host is alive, i.e., responsive; + only defined if REMOTEP is true) + (OPENP POINTER) (* (name access dev) => stream if name is open for access, or  + all open streams if name = NIL) + (OPENFILELST POINTER) (* Default place to keep list of streams open on this device) + (NIL POINTER) (* Spare) + ) + DIRECTORYNAMEP _(FUNCTION NILL) + HOSTNAMEP _(FUNCTION NILL) + READP _(FUNCTION \GENERIC.READP) + SETFILEPTR _(FUNCTION \IS.NOT.RANDACCESSP) + GETFILEPTR _(FUNCTION \ILLEGAL.DEVICEOP) + GETEOFPTR _(FUNCTION \IS.NOT.RANDACCESSP) + EOFP _(FUNCTION \ILLEGAL.DEVICEOP) + BLOCKIN _(FUNCTION \GENERIC.BINS) + BLOCKOUT _(FUNCTION \GENERIC.BOUTS) + RENAMEFILE _(FUNCTION \GENERIC.RENAMEFILE) + FORCEOUTPUT _(FUNCTION NILL)) +] +(/DECLAREDATATYPE (QUOTE FDEV) + (QUOTE (POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG + FLAG FLAG FLAG FLAG FLAG POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER POINTER POINTER POINTER POINTER + POINTER POINTER POINTER)) + (QUOTE ((FDEV 0 POINTER) + (FDEV 0 (FLAGBITS . 0)) + (FDEV 0 (FLAGBITS . 16)) + (FDEV 0 (FLAGBITS . 32)) + (FDEV 0 (FLAGBITS . 48)) + (FDEV 0 (FLAGBITS . 64)) + (FDEV 0 (FLAGBITS . 80)) + (FDEV 0 (FLAGBITS . 96)) + (FDEV 0 (FLAGBITS . 112)) + (FDEV 2 (FLAGBITS . 0)) + (FDEV 2 (FLAGBITS . 16)) + (FDEV 2 (FLAGBITS . 32)) + (FDEV 2 (FLAGBITS . 48)) + (FDEV 2 (FLAGBITS . 64)) + (FDEV 2 (FLAGBITS . 80)) + (FDEV 2 (FLAGBITS . 96)) + (FDEV 2 (FLAGBITS . 112)) + (FDEV 2 POINTER) + (FDEV 4 POINTER) + (FDEV 6 POINTER) + (FDEV 8 POINTER) + (FDEV 10 POINTER) + (FDEV 12 POINTER) + (FDEV 14 POINTER) + (FDEV 16 POINTER) + (FDEV 18 POINTER) + (FDEV 20 POINTER) + (FDEV 22 POINTER) + (FDEV 24 POINTER) + (FDEV 26 POINTER) + (FDEV 28 POINTER) + (FDEV 30 POINTER) + (FDEV 32 POINTER) + (FDEV 34 POINTER) + (FDEV 36 POINTER) + (FDEV 38 POINTER) + (FDEV 40 POINTER) + (FDEV 42 POINTER) + (FDEV 44 POINTER) + (FDEV 46 POINTER) + (FDEV 48 POINTER) + (FDEV 50 POINTER) + (FDEV 52 POINTER) + (FDEV 54 POINTER) + (FDEV 56 POINTER) + (FDEV 58 POINTER) + (FDEV 60 POINTER) + (FDEV 62 POINTER) + (FDEV 64 POINTER) + (FDEV 66 POINTER) + (FDEV 68 POINTER) + (FDEV 70 POINTER) + (FDEV 72 POINTER) + (FDEV 74 POINTER) + (FDEV 76 POINTER) + (FDEV 78 POINTER) + (FDEV 80 POINTER) + (FDEV 82 POINTER))) + (QUOTE 84)) +(DECLARE: EVAL@COMPILE +[PUTPROPS .APPLY. MACRO ((U V) + (* body for APPLY, used by RETAPPLY too) + (PROG ((DEF U)) + LP + [COND ((LITATOM DEF) + (COND ((NOT (fetch (LITATOM CCODEP) + of DEF)) + (* EXPR) + (SETQ DEF (fetch (LITATOM DEFPOINTER) + of DEF))) + ((EQ (fetch (LITATOM ARGTYPE) + of DEF) + 3) + (GO NLSTAR)) + (T (GO NORMAL] + [COND ((LISTP DEF) + (SELECTQ (CAR DEF) + [NLAMBDA (AND (NLISTP (CADR DEF)) + (CADR DEF) + (GO NLSTAR] + (FUNARG (SETQ DEF (CADR DEF)) + (GO LP)) + NIL)) + ((NULL DEF) + (RETURN (FAULTAPPLY U V] + NORMAL + (RETURN (SPREADAPPLY U V)) + NLSTAR + (* NLAMBDA*) + (RETURN (SPREADAPPLY* U V] +[PUTPROPS FDEVOP MACRO (ARGS (CONS (QUOTE SPREADAPPLY*) + (CONS (COND ((EQ (CAR (LISTP (CAR ARGS))) + (QUOTE QUOTE)) + (LIST (QUOTE fetch) + (CADAR ARGS) + (QUOTE of) + (CADR ARGS))) + (T (HELP "FDEVOP - OPNAME not quoted:" + ARGS))) + (CDDR ARGS] +) +(MOVD (QUOTE APPLY*) + (QUOTE SPREADAPPLY*)) +(PUTPROPS FDEVTEST COPYRIGHT ("Xerox Corporation" 1985)) +(DECLARE: DONTCOPY + (FILEMAP (NIL))) +STOP diff --git a/internal/test/Tools/FDEVTEST.LCOM b/internal/test/tools/FDEVTEST.LCOM similarity index 100% rename from internal/test/Tools/FDEVTEST.LCOM rename to internal/test/tools/FDEVTEST.LCOM diff --git a/internal/test/tools/FILEBANGER b/internal/test/tools/FILEBANGER new file mode 100644 index 00000000..a4097a03 --- /dev/null +++ b/internal/test/tools/FILEBANGER @@ -0,0 +1,345 @@ +(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 diff --git a/internal/test/Tools/LOCK-FILE b/internal/test/tools/LOCK-FILE similarity index 60% rename from internal/test/Tools/LOCK-FILE rename to internal/test/tools/LOCK-FILE index db7f2456..fe2901ba 100644 --- a/internal/test/Tools/LOCK-FILE +++ b/internal/test/tools/LOCK-FILE @@ -1 +1,2 @@ -((rhoades.pa 1 3) (Markovitch.pa 14 22 DATABASE 4 16))6 14 27 26 25 24 23 20 18 13 12 11 9 4 10 8 7 6 5)) \ No newline at end of file +((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 similarity index 100% rename from internal/test/Tools/NEXTID rename to internal/test/tools/NEXTID diff --git a/internal/test/tools/RANDOM-GENERATOR b/internal/test/tools/RANDOM-GENERATOR new file mode 100644 index 00000000..7ca1c99f --- /dev/null +++ b/internal/test/tools/RANDOM-GENERATOR @@ -0,0 +1,158 @@ +(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 diff --git a/internal/test/tools/RANDOM-GENERATOR.LCOM b/internal/test/tools/RANDOM-GENERATOR.LCOM new file mode 100644 index 00000000..a1e10371 Binary files /dev/null and b/internal/test/tools/RANDOM-GENERATOR.LCOM differ diff --git a/internal/test/tools/SLOOP.LISP b/internal/test/tools/SLOOP.LISP new file mode 100644 index 00000000..3791b475 --- /dev/null +++ b/internal/test/tools/SLOOP.LISP @@ -0,0 +1,946 @@ +;;; -*- Mode:LISP; Package: SLOOP; Syntax:COMMON-LISP; Base:10 -*- ;;;;;;;; +;;; ;;;;; +;;; Copyright (c) 1985,86 by William Schelter, ;;;;; +;;; All rights reserved ;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;Report bugs to atp.schelter@r20.utexas.edu +;;It comes with ABSOLUTELY NO WARRANTY but we hope it is useful. + + +;;The following code is meant to run in COMMON LISP and to provide +;;extensive iteration facilities, with very high backwards compatibility +;;with the traditional loop macro. It is meant to be publicly available! +;;Anyone is hereby given permission to copy it provided he does not make +;;ANY changes to the file unless he is William Schelter. He may change +;;the behavior after loading it by resetting the global variables such +;;as like *Use-locatives*, *automatic-declarations*,.. listed at the +;;beginning of this file. The original of this file is on +;;r20.utexas.edu: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) diff --git a/internal/test/tools/TEST-ARITHMETIC-UTILS b/internal/test/tools/TEST-ARITHMETIC-UTILS new file mode 100644 index 00000000..11d6c6f3 --- /dev/null +++ b/internal/test/tools/TEST-ARITHMETIC-UTILS @@ -0,0 +1,43 @@ +(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 diff --git a/internal/test/tools/TEST-ARITHMETIC-UTILS.LCOM b/internal/test/tools/TEST-ARITHMETIC-UTILS.LCOM new file mode 100644 index 00000000..65b681cf Binary files /dev/null and b/internal/test/tools/TEST-ARITHMETIC-UTILS.LCOM differ diff --git a/internal/test/tools/TEST-DISPLAY-UTILS b/internal/test/tools/TEST-DISPLAY-UTILS new file mode 100644 index 00000000..67942e29 --- /dev/null +++ b/internal/test/tools/TEST-DISPLAY-UTILS @@ -0,0 +1,37 @@ +(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 diff --git a/internal/test/tools/TEST-DISPLAY-UTILS.LCOM b/internal/test/tools/TEST-DISPLAY-UTILS.LCOM new file mode 100644 index 00000000..b92a8002 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..63002e35 --- /dev/null +++ b/internal/test/tools/TEST-FILING-UTILS @@ -0,0 +1,46 @@ +(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 diff --git a/internal/test/tools/TEST-FILING-UTILS.LCOM b/internal/test/tools/TEST-FILING-UTILS.LCOM new file mode 100644 index 00000000..73d5a7e1 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..68780a07 --- /dev/null +++ b/internal/test/tools/TEST-REMOTE-EVAL @@ -0,0 +1,293 @@ +(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 diff --git a/internal/test/tools/TEST-REMOTE-EVAL.LCOM b/internal/test/tools/TEST-REMOTE-EVAL.LCOM new file mode 100644 index 00000000..64db748e 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..52a31717 --- /dev/null +++ b/internal/test/tools/TESTER @@ -0,0 +1,2180 @@ +(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 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..c05bc7dd --- /dev/null +++ b/internal/test/tools/TESTER.TEDIT @@ -0,0 +1,97 @@ +THE INTERLISP-D TESTING SYSTEM The Interlisp-D testing system is an integrated system built for creating, managing and using a large set of programmed tests for testing the correctness and the performance of the Interlisp-D programming environment. The system is consisted of three parts : The test driver, the data base management system, and a graphic control tool. In addition, there are various tools for helping the test builders in the process of creating new tests. All parts of the system assumes the structure of a TEST which is a data type consists of several fields, of which the most important are the expression which has to be evaluated, and a predicate which takes the results of this evaluation and determines whether the test was a success or a failure (i.e. whether the actual result is the same as the expected result). The test driver is in principal a function which gets an object of type TEST, performs the test, and return either success or failure plus some additional information. It includes facilities for monitoring the test execution, tracing and recording the testing process to enable reproducing tests, Remote Eval protocols to enable performing tests with two machines and more. The data base management system works in two levels. In the low level, the "test cluster" level, the system manages and organizes the tests in the file system, enable retrieving tests through a cashing system, and allows concurrent access to test files using a simple locking scheme. In the high level, the system enables each user to manipulate the database using its own VIEW of the system. This view is implemented through the CONCEPT SPACE which is a directed acyclic graph that will usually reflect the logic structure of the system as seen by the user. The graphic control tool displays a concept space as a graph and allows the user to perform most of the Test system operations by selecting nodes from the graph. The tools for building and manipulating tests include test inspector (and editor), a random generator which can generate random specified Lisp objects, Indirect reference to other tests in TEST fields for shrinking the space of the tests themselves and avoiding redundant work when creating tests which share some of their fields, and more . In the next sections the different parts of the system will be described as well as the interaction between them. The TEST data type The TEST is the data type of test objects. Its structure reflects the various properties that tests have. It includes the following fields: TestID : The tests are identified by an integer. Input : This field contains an expression that, when evaluated, will generate the list of arguments on which the tested expression will be applied. There are several tools which help in creating this entry. The random generator helps in generating random objects with specified restrictions. The SYSTEMATIC operation helps in generating systematically all the combinations over finite ranges. Expression: It can contain a function name, a lambda expression or arbitrary sexpression. In the first two cases it will be applied on the input. Success Predicate: This field contains a lambda expression with two arguments - the ACTUAL input for the test, and the result of the evaluation. It returns one of the two atoms: Success or Failure. When performing tests with random input, some tricks may have to be used as demonstrated in the examples in the end. Timeout :This is a lambda expression which gets the ACTUAL input as an argument, and produces an upper limit to the estimated time of evaluation. EvalBefore and EvalAfter: expressions to be evaluated before and after the test execution. usually, before the test we may want to set the appropriate environment for the test (like loading certain files), and after the test we may want to clean up the environment (like deleting files which the test created). Pretests: Contains a list of links to other tests. These links may influence the order of an execution of a set of tests. Currently there are two types of links. A STRONG link to other test means that whenever the current test is going to be executed, the pretest must be executed first. An example for such pretest may be tests for the tests themselves. If a test generates a few thousands combinations of some arguments, it may be useful to test first if the test itself works correctly by executing a simplified test which works only on one set of arguments, and check that the test outcome is reasonable. A WEAK link to other test means that whenever a SET of tests is being executed, and both the test and pretest are in this set, the pretest will be executed before the test (thus it defines a partial order on any set of tests). This link may be used in cases where there is logical order on the execution of tests - for example, it is reasonable to test opening a file before testing writing to a file. The Test Driver The test driver accept a test as its input and returns either success or failure. It will evaluate the input and the tested expression itself on a remote machine if requested, or on the local machine otherwise. All the process of the testing is recorded on a trace file, such that as much information as possible will be available if needed. The driver evaluates the EVALBEFORE form, evaluates the input expression to generate the input for the tested expression, applies the tested expression on the generated input, applies the success predicate on the result and the generated input, and evaluates the EVALAFTER form. After some of the above stages the appropriate information is written on the trace file. The most important one is the input generated, especially in cases of random input. All the evaluation done by the driver uses the Interlisp-D ERRORSET command, thus allowing evaluation that will not break under error condition. The error type may be used by the success predicate to determine if the result is a success or a failure. Thus one test for many arithmetic functions can be to supply them with non numeric arguments and to check that the error reported will the right one. The evaluation of the tested expression is done as a separated process, such that the driver will be able to try to interrupt it in case where the time of execution is larger then the value of TIMEOUT field of the test. This interrupt will work only if the test execution process will release voluntarily the cpu (when waiting on I/O for example) since Interlisp-D uses non preemptive scheme for process scheduling. Remote evaluation will not benefit us much in this type of problems. If the remote machine is in infinite loop for example, it will not listen to interrupt attempts as well. The advantages of using remote machine are two: If a long sequence of tests are executed, and the machine "freezes", a remote test will freeze the remote machine and the local machine will be able to call for help and resume operation (as soon as the remote machine does not respond for more then some estimated limit of time, the local machine sends messages to a preset distribution list and asking for human help). A second benefit of remote evaluation is when we need to evaluate the tested expression in a different environment than the Testing system resides. We will want the testing system to work in considerably nvironment (software release), while we are testing an experimental different environment. The data base management system: the "test cluster" level. The user can retrieve a test by calling the GetTest function. The low level of the dbms is responsible for performing the appropriate operations to retrieve the requested test. If the test is not already loaded it will be loaded from its file. There is a limit on the number of the tests that are loaded, and if these number is exceeded a replacement will take place and a test will be removed. The replacement policy is LRU (least recently used) and is implemented by moving each test being referenced to the front of the list of the loaded tests. Thus the last test in the list will be the one to be removed. The limit on the number of loaded tests is dynamically modified according to the amount of the available memory. The Interlisp-D testing system is designed to work with several users uses it concurrently. There are no problems if the users were only retrieving tests from the data base. Problems may occur if two users modify the same part of the data base in the same time. For such cases a locking scheme was integrated into the system. There is a special designated file which is the "gate" for the data base. Users can obtain write LOCKS on tests. The file contains the list of users with their locked tests. The basic locking function is ObtainDatabaseWriteLock(testnumber) which checks the LOCK file, and registers the tests that are not already locked . The user has the option of automatically generated messages that will be sent to the locking users, inform them that somebody is waiting for their locked test s and request them to release them as soon as they are not needed. Thus, either automatically or manually, whenever a user edits a test, he will first obtain LOCK on tests. The locking scheme will work only if the users will follow the rules and will not try to access tests not through the testing system. The basic operation - ObtainDatabaseWriteLock is "atomic" in the sense that the LOCK file is opened for read and write throughout the execution of this procedure, and thus no other user will be able to open it. The time interval in which the file is opened is very short. Another problem that may arise from concurrent access to the data base is test numbering. As mentioned above, each test has a unique integer as an ID. Thus there is a file which contains the last ID issued, and the procedures for creating new tests will access and update this file. The "Concept Space" level. What is the "thing" which is being tested by the test? it may be a specific low level system function, a library package, or a new representation scheme for integers. It is hard to find a common class to which all these entities belong. Thus the testing system assumes that it is some CONCEPT of the Interlisp-D system that is being tested. While it is true that when a test is CREATED, its creator intent to test a specific concept, the test itself is not necessarily a test only for this concept. A test that was built for testing the READ function, may actually test also the NS communication protocols, the OPENFILE function etc. For this reason the tested concept is not considered to be a part of the test itself. There is a separated knowledge strpace" which is the way that the user views the test cluster. A concept space is an acyclic directed graph of CONCEPTS. Each node of the graph is of type CONCEPT which has four fields: The concept name, the tests that tests this concept, the subconcepts and the superconcepts. The main purpose of the concept space is to enable the user to group tests in a logical way and to perform operations on these sets of tests. The semantic of a concept node is : "the tests which tests this concept are the tests of the concept itself plus the tests that tests its subconcepts (recursively)". Such a definition allows us to build concept spaces which view the tests from different points of view. We may have a concept named "Arithmetic system" with subconcepts "Integer arithmetic", "Flote arithmetic"and "Arithmetic functions". The "Arithmetic functions" will have as subconcepts, the concepts "IPLUS", "FPLUS", "PLUS" etc. "IPLUS" is also a subconcept of "Integer arithmetic", and "FPLUS" of "Float arithmetic". Thus, if a new representation for the integers was introduced to the system, we will test the "Integer Arithmetic" concept, while in other cases we may want to test the "Arithmetic Functions". From the above example and from the more detailed example at the end, we can conclude that the organization of the test system should be very flexible, since there can be many parallel views into the same part of the system. We can also see why a tree structure would not be sufficient as a representation scheme. The Testing system supports the the co-existence of several concept spaces, and thus each user can build and use his own concept space(s) to reflect his view of the system. THE CONCEPT SPACE BROWSER Most of the operations of the Interlisp-D testing system are done through the "Concept Space Browser". The browser is a graphic tool which is applied on a concept space. It has a few types of operations. Any operation that require a concept as an argument will get it by a selection from the displayed graph. The first type of operations are operations for modifications of the concept space itself. There are commands to add new concept, to delete a concept, to ad and delete a link and to add and delete a test to a concept. Second type of operations are data base operations. The user can edit a test selected from specific concept, can hardcopy all (or part of) the tests of a selected concept, and can request to lock all (or part of) the tests of a concept. A third type are display op can be specified, a browser of a subgraph can be created, and the tests can be dre are commands to execute all (or part of) the tests of a certain concept, with different modes of execution . The browser also allows to copy subgraphs between two displayed concept spaces, and to get all the tests of a node by a copy selection so that functions that are not available in the browser can use the concept space as well. .—˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üřŔ*ŞŞŻęŞŞŞŞŞŤęŞŞŞŞŞŤţŞŞŞ>˙˙đ˙˙˙˙˙óă˙˙ř€üř1™€UUU]UUUUUUWuUUUUUU]UUTc˙˙ç?˙˙˙˙˙ăÉ˙˙ř€üř`ŰUUU]UUUUUUWuUUUUUU]UUTc˙˙ç?˙˙˙˙˙ƒœ˙˙ř€üř`Ţ*ŞŞżŞŞŞŞŞŞŽŞŞŞŞŞŞŞşŞŞŞc˙˙ç?˙˙˙˙˙óœ˙˙ř€üř`Ü6*ŞŞşęŞŞŞŞŞŻęŞŞŞŞŞŞşŞŞŞ>˙˙ç?˙˙˙˙˙óœ˙˙ř€üř`ŢfUUU]ŐUUUUUWuUUUUUUuUUTc˙˙đ?˙˙˙˙˙óœ˙˙ř€üř`ŰfUUUUŐUUUUUWuUUUUUUuUUTc˙˙˙?˙˙˙˙˙óœ˙˙ř€üř`ـ*ŞŞşęŞŞŞŞŞŽşŞŞŞŞŞŞęŞŞŞc˙˙ç?˙˙˙˙˙óœ˙˙ř€üř1˜Ŕ*ŞŞşęŞŞŞŞŞŽşŞŞŞŞŞŞęŞŞŞc˙˙ć˙˙˙˙˙óÉ˙˙ř€üř`UUU_ŐUUUUUWőUUUUUUŐUUT>˙˙đ˙˙˙˙˙˙óă˙˙ř€üřUUUUUUUUUUUUUUUUUUUUUT˙˙˙˙˙˙˙˙˙˙˙˙˙řüř*ŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞ˙˙˙˙˙˙˙˙˙˙˙˙˙řüř*ŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞŞ˙˙˙˙˙˙˙˙˙˙˙˙˙řüř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙üř€Ăŕ0ř˙˙ƒă˙˙˙˙˙ŕđ˙˙˙˙ř?Ÿ˙˙€đü|˙˙ŕŕ?˙˙üřŔĆ0qŒ˙˙9É˙˙˙˙˙Îg?˙˙˙˙óŸ˙˙€ŔĆ3˙˙Î?˙˙üřŔĆ0ńŒ˙˙9œ˙˙˙˙˙Îg?˙˙˙˙óž˙˙€ŔĆc˙˙Î~˙˙üřŔŔ01Œ˙˙ůœ˙˙˙˙˙ţ?˙˙˙˙˙žŸ˙˙€ř`˙˙ţ|˙˙˙üř€Ŕŕ0ř˙˙óœ˙˙˙˙˙üü˙˙˙˙˙<Ÿ˙˙€1Œ ~˙˙üü˙˙˙üřŔ01Œ˙˙çœ˙˙˙˙˙ů˙?˙˙˙˙ţyŸ˙˙€aŒc˙˙ůů˙˙˙üřŔ01Œ˙˙Ϝ˙˙˙˙˙ó˙?˙˙˙˙üůŸ˙˙€Ŕ 0c˙˙óů˙˙˙üř Ć01Œ˙˙Ÿœ˙˙˙˙˙çç?˙˙˙˙ůř˙˙€Œ`c˙˙çó˙˙˙üřĆ01Œ˙˙?É˙˙˙˙˙Ďç?˙˙˙˙ó˙Ÿ˙˙€ŒŔc˙˙Ďó˙˙˙üřŔĂŕ0ř˙˙ă˙˙˙˙˙Ŕp˙˙˙˙đŸ˙˙€řřţ>˙˙Ŕs˙˙˙üř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙üř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙üř˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üđ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<đ<óŔ Ŕ<ň @@<ň#‹XŘâĂ@8đÄM–X@€<ň$Lˆ"d¨#$Ŕ"D@$J™"d@€<óÇČ"@¨"$@>0@$J‘>@<ň"@¨"$@ @$J‘ @<ňH"@¨"$Ŕ "DH$ʙ"@@<ňˆ@¨"#@80#J–@@<đ@!<đ€@."—=g<đ@!1"˜‘¨‘<đ@!!‘Ÿ<đ@!!‘<đ!!1‘˜‘‘<đ.— <đ <đ 0<đ<đ<đ<đ<đ<đ<đ<đ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ý˝ ;î8p˙ěp`ß˙˙˙÷ń˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ýŢýŰíۡ~íŰ˝ďÎ~ötçœcîǞy˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ý­Ţ;î{ˇ>źýáÎ~ý˛ŰmˇóŰmś˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ýľŢýŰď¸wgß}ďŐ~ýśß ˇýۍđ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ýšŢýŰíŰ÷~ď{˝ďŐ~őśŰ}ˇîŰmˇ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<ý˝Ţ Ř.;đ˙|}ŕŰvçŒsńÇx˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ý˙˙ß˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ý˙˙ß˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ţ<đ<đ <đ <đ‡‹‡.x<đ##HLH‘1 <đ"!!HH! <đ>!!HH! <đA##HHH‘1 <đA‡ˆG.<đ <đ <đ<đ<đ<đ<đ<đ<đ<đ<đ<đé Ŕń<đ’ (‰<đČb (ń<đňcĆD‰<đţ’|‰<đž|xůŕxŸ"A>|ţ +‚‰<đ˜ˆ@„D„"c €ţ<đ”ˆx€ńŕx„>c<ţ<đ’ˆ@œ"D„"U ><đ‘ˆ@Œ>D„"U ťř<đˆ|tůAD„"I>đ<đ€ŔÄx…<đ ŕ?€$„Ĺ<đ@ XĀĽ|@<đ@&ň$œ•¨B@<đ€€$Œ¨AG<ŕ8x¸pâç€<đ`Ät„âHA"H‘D„ĉ<đƒA>O‘đ@„„ň<đ@†A H@„„<đ@A€B"H‘D„„‰<đ 0`|G ŕ8x„pâá€<đ <đú‚‡‰ň$çČđP<đ ‚EDHB&2 H<đ@ňEGˆCć3Á H€Ŕ<đ€‚H„2$HB%R $`0<đ€‚O„äHB%R €" <đƒçDHB$“áđ`<đ 8Ŕ<đ@€0<đ€€€Ŕ <đ`@ <đŘ Ŕ<đ & 0ä‚|N<đ ‚ „Ć@Ž<đ@ a€„ĆxN<đ€@@„Ş@<đ€†„ „Ş@Ž<đa‚„’|N<đâ<đ Y<đG<đĄ€`<đ ``p<đ Ŕ0XHÄ€<đA&„$"€<đB€$<đ„ `“Ä—<đČ"##˜’<đ$Î"!!”<đ >!!š<đ@`A##‘<đ€X A€<đ€†Ŕ<đá€<đ$€R`x‚#Ž<đH€LD‚$N<đ°@*D‚#<đŔ@ x‚ Ž<đ€ @@‚$N<đ'ȐOŸ#Ă (° @ůÎ<đ!˜Č$&K0<đ!˜Ď$„Ŕ<đH‘!•H$ +<đ‘!•H$# + Ŕ<đQ!’O„#Ŕŕ! <đ Ŕŕ|OŽ<đ€˜Č<đŔ"@˜Ď<đ0F •H<đ™` •H<đ€!€ŕ’OŽ<đ`F€<đˆ€č<đ0O<đ ŕ Ŕđ<đ  <đ@!â|‰ůň<˘ByňO‘đI @<đ‰$řB<BxB!!@ <đˆx A##D‰<đHA8pŔ<đD<đ$<đ <đ@ +<đ@â#ÇÎ<đ€$!<đ€’$!<đ’’$!<đR$!<đáĂÁ<đ<đ<đ<đ<đ<đ#ăĂĂώHO<đ $B$$("LP€<ń!|ůâăŔx #Ä$ JP<ń1  D@˙Č ‚â$$IS€<ń)ńâ D@˙ţ$B$$("Hр<ń%#ĆD˙ࣂ#ĂώHN€<ń# Dţ<ń!ůčâxQđ<đl<đbř|@@<đ1€ŔB@@<đ(@<OžAG<ŕó‡<<đ(0ŕP˜Č’A"H‘DH<đ˜Č’A>O‘đGÇ<đČ•OA HD<đ +P•HB"H‘DH<đ ŔHď‘|G ŕ3‡ <đ <đ€<đ€<đ@˙˙˙˙˙˙˙˙˙˙Î<đ Ŕ<đ <đŠBđńN>|‚"źN<đŠb‰ H‘@Ć"˜˘BDALPˆN<đRR‰Ş xĆT”˘B*äJPN<đ€ĹRJ‰Ş`‚@Ş˙˙˙˙ńT’˘B*™IPN<đ„`ü"F‰DB@ވ‘˘BHЈN<đ‚ţ"BđđD‚|’ˆź<ˆON<đ‚ Lj‚?<đA’$HDŔ<đ@€ˆ‘„H(ŕ<đ@€HGˆ"đ˙˙˙˙˙˙˙˙˙˙Î<đ @’$>€˙˙˙˙˙˙˙˙˙˙˙ţ<đ @ÄÁ~@<đ ř@<đŕž!|pOž!|pD„óäx„â<đ€!1ˆH!1ˆDĹ„„Ĺ<đ~!)`O!)`DĽ„„¤Â<đČ!%˙˙˙˙˙Č!%D•„„”"<đ!#ˆH!#ˆD„„ <đ!pH!p8„đ„x„â$<đ@@<đ@@/pç€<đ€@~#$‰<đ€˙˙˙˙˙˙˙˙˙˙˙ţ@!$řâ<đ@@!$€<đ@@#$‰<đ „ŕ>HO#pá€<đĹ LP€<đ€¤Ŕ<JP<đ€”# IS€<đ€ Hр<đ@`„ŕ ŸHN€<đ@€<đ <đ <đ `<đ€€<đ@đâ } ž<đ@ ‰@A ˜Ą<đ 0ˆÂ€y ” <đ Ŕ ˆ#FA ’§<đđ‰ A ‘Ł<đ đâA><đ0đ<đ@<đ€x<đ€<đ8<đ ÄO‚DB +<đ@ +‚<8!Á<đŸAxA#‹ˆâ <đ@ŔA$LI +źđ@8pA#ˆHq@<đ €€A HI‘@ +<đ xxB$LI€<đ €|#‹ˆč€<đđ‚<Ń!<ů!8<$'€<đ‚B1B!!1DŔ‘&(€<đđ„B‘)@!!)0<ž% €UUUUUUUUUUUU|đ ˆBd%@!!%˙˙˙˙˙Ď$§ŞŞŞŞŞŞŞŞŞŞŞŞźđˆB#B!!#D<$hŞŞŞŞŞŞŞŞŞŞŞŞźđ<!|qńŔ8ŕ<đ€ř@ˆB pE<đpđx`A€E<đ @@G˙˙˙˙ţ„E<đ€@ˆB E<đ`|pAŔ8ŕ<đ<đ<đŔ<đ8<đ<đ€<…áâ!|đCăǀ<đp"(Ő1@ˆ „$@A@<đ <(Ľ)xđ „'€A@ +<đ"D•Š“%@‰„$@AYŃĂĹÄCÎó…<đ"|¨#@‰đ„$@"j2$&$A"DJźđ"‚…áâHŸ!|ŠƒÄ@AB$"C…<đA2B$"@J<đA"B2$&!"DD<đAAŃĂĹÁÎ3ˆ<đ<đ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üđ<đ<đ <đ <đ €xX Ŕ<<đ @ €h  <đ@ €@ <đ@ @ <đ@ €@ <đ@@čŔ <đ<đ<˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙üőUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUUU_˙˙˙˙˙˙˙˙ýUU|˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ü Test creation tools and misc tools There are several tools that were created to help the tests builders in their task. In each field of a test the user can write (& n) when n is a test number. This tells the system that to retrieve the value for this field it should refer to the same field in test n. This was done since many tests share values for some of their fields. The test inspector is built on the top of the Interlisp-D inspector. The user can inspect and modify the various fields of a test. In addition he can call the inspector on indirect referenced tests. There are functions which keep tracks of changes done to tests, and functions which stores modified tests. The Random Generator is a very important tool for creating a test. It has many entries for different Lisp objects which he can generate randomly. These set of possible entries will grow constantly as test builders will need more types of random objects. The random generator function gets as an argument an object type and a list of modifiers. The test builder can specify in the input field of a test a call like (GenerateRandom 'LARGE-INTEGER), or (GenerateRandom 'WINDOW) or (GenerateRandom '(LIST-OF-ITEMS WINDOW 50 100)) to get a random list of length between 50 and 100 of windows. From the experiments done with the Testing system it was clear that random tests are an important part of any testing and can discover bugs that would be hard to find otherwise. Another tool is the SYSTEMATIC input generator. Many times we want to test a function if it works right with all the possible combinations of values of its arguments, or to find out whether an library package works with all possible settings for its flags. For such cases the test builder can specify in the input field that he wants a systematic test, and supply the expressions that produces the ranges of values to combine. TEST EXAMPLES: EXAMPLE 1 Ř ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙đđóüĂŕđ`€Ć0đ`€Ć0đ`řóŕ˜ßsńóŕĆ0đa™€Řٛ`ĂŕđaÁ€ŘٛĆ0đaüń€ŘٛűĆ0đa€9€ŘٛĆ0đa™€ŘٛĆ0đ`řđŕĎٛńóĂŕđđđđđđóçĎßż<üđGó6l0f1˜Bó6l0p1ŔfBó6o†><0đeBóçĚ00xBól00Âól0f1˜dÂóoĆ?|1đdGđđđđó÷矟8î;÷đŕ€áŔ@ÀđĆ Ć1ą¸î;˜ŔT  @ @€đĆ1ą˝ď{˜ŔÄ8ŇxpŕˆŽ<8ŘăÇ"p @°áŇxŕ@€đÇdž01˝ď{ćŘŔÄT&H™ ‰H‘D¨ˆ‚" @"ČFH€" @€đĆĆ01ˇmŰŘŔsäO řŔŒ|¨ńˆ"x @>ˆđD" đ@€đĆĆ1ąˇmŰxŔH" € …@Šˆˆ @ ‰D" @€đĆ Ć1ąˇmŰxŔÄ$H"$‰EDŠ ˆ‚ˆ @‘"ÉD€" @€đÇď†2l›ö8ŔÂáÄGpŕ‚ 8¨đŔ‡x @°đD đ@€đ€đ 0€đđđ€€ đ€đŇ8°áÇ°áĽˆ›đH€DÉ €‚Č"fH•"đO€0‰ň‡‚ˆ"$H•đH‰ˆ‚ˆ"$H•đ$H€DÉ ˆ‚Č"dI•"đÄG8°áŔ‡‚°!¤F•đ€ đ€Ŕđđ@đ€@>8řƒ‡"DăÇÇ@$N<8 ‚đ€ D A™"l$„@’&É"Dđ,8hŀ D A™"l$„@’&É"DâŔ8đD2D˜F@<0 Á"TÂ'ˆ@R%O<0# Dđ |ˆD@  ! •"Tř#Ä"@ůR%H(" |đ„ @ˆD@ D !“"T„>@2%H$D" @đD‘ D˜D@ D B!“"T„"@2%H"D" Dđƒƒ 8hD@>8 CÇDâÇ"|ÄO"8" 8đ€đ@đđ đçÇđăäHŸ>8p'Çđ„„(ˆ@„Mˆ!"đ„„(ˆ@„Mˆ!"đ‡†(đ@‡Ęž€!đ„>D @„Jň!đ„„|@„Jˆ!"đ„„Dˆ@„Jˆ!"đ‡ÇDˆŕ„HŸ8pÁđđ đđđqâGxqóçĎ"8řđ!H€‚D!2D€đŋ"!H€Xầ8řřŇD!2D€đ&L‚"!F"dƒ$J€ ͘H€D!ăǏ*@đđäH‚"!âA"D‚'ʀ<͘O€D! +*@€đ$H‚!H€"D‚$ +€l͘HD! &D€đ&L‚!H€"D’$J€l͘$H€D!&D€đĺ‹qă‡Db#Š€>ĚřÄGxqȟ"8řđđ0đđđpđA€đpăe‡ńaŔ DáŔ€đ™&‰Ś@™"A’ ‘"D‚ €đ‘"¤G>AŕD€€đ‘"¤H AD€@€đ‘&‰ŚH"I "L’ €đ‘p⥇1Ŕ4aÁđđđđpŕóöC‡ďßžA„N!ăă€<8p óăĆ3AFÉ!@ +"Dˆ ó0ăĆ3 AFÉA@ +"Dˆ óă1łgĂ3 AEOAăĂ +<@` ó!łf>A%H‘"AB€(\ óáóć3AĺH‘>A"@$Dˆ óĂ63 A%H‘"A@"Dˆ óđĂö6ł Aň$O"!ă€"8p đ@ đpŕđđ óöCĎߟ>~@€óăl1ł`A@ó0ăl1ł`@óă1łϟ1ł|€€ ó!łl1ž`P óáól1ł`‚ ‚óĂl1ł`‚ óđĂ÷ĎŘ3~AĐđ@đ đđóöăż>c~ÄđĆă°cc„đĆ÷°cc„đĆ÷žccP„đĆÝ°ccP„đĆÝ°cc0„đĆÝ°cc0„đĆÉż>>ÇŔđđđđóöăż<@đĆă°fŔđĆ÷°p@đĆ÷ž<@đĆÝ°@đĆÝ°@đĆÝ°f@đĆÉż|đđđđđŕ ńć3ăçç>|ýůŸ?~‚œ<CÇÇxpŕ€ó6666 ŮłfÁąŽ `‚’"(B$€D‰€ó†6663fÁąŽ `‚’"(‚$€D‰@ńć6Ǐ3fů° |‚Šž"(ƒÇ†x€Ŕ@đö6Çž|Á° `‚J‘"D‚„"P¸ @đ6666Á°fÁąŸ `‚ʑ"|‚D€>H‰@ó6666 Ů°fÁąąŒ`‚J‘"D‚$€"D‰@óăăăçďŸ0fýůŸ1Œ~ƒäHž|đƒˆ<|đ„H‘@A"@đó<đH‘@A"@đ›e˜H‘xáAD!ńÀ>8řƒ‡"DăÇÇ@$N<8óyłcB$H„ lP@„@ D A™"l$„@’&É"Dóyłc‚"ˆ„ lP@„@ D A™"l$„@’&É"Dómłc‚†@2%H$Dóg°c‚!„ Tˆ@„@ D B!“"T„"@2%H"Dóc°>AÁ>DˆAÀ>8 CÇDâÇ"|ÄO"8đ@đ đđ@đ>8řƒ‡"DăÇÇ@$N<8 đ D A™"l$„@’&É"D đ D A™"l$„@’&É"Dđ<0 Á"TÂ'ˆ@R%O<0đ  ! •"Tř#Ä"@ůR%H(đ D !“"T„>@2%H$Dđ D B!“"T„"@2%H"Dđ>8 CÇDâÇ"|ÄO"8 đ đ@đđóöCěß>qâGóă Ůł!H€ó0㙳 !H€óă1łĂł !Fó!ł>!âAóáó˜3!H€óĂ Ř3 !H€óđĂ÷ěŘ3 qă‡đđđđó÷矷ŕđĆ Ć60đĆ60ĘđÇdž60ÂđĆĆ60đĆĆ60đĆ Ć60ÂđÇď†7ŕώđđđđńÄ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ EXAMPLE 2 Űœ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕřŕůţ€`0ŕř0Ŕ€ŕpŕř0Ŕ€ŕđŕř0|yđĚošřůđ`°ŕř0ĆĚŔ ll͍°a°ŕř0ĆŕŔ ll͍€c0ŕř0ţxŔ ll͍ý€c0ŕř0ŔŔ ll͍€cřŕř0ĆĚŔ ll͍€`0ŕř0|xp gěÍřů€`0ŕřŕřŕřŕřŕřŕř@€ŕůóçďߞ~xŸDAÁŕů›63́HÂ!ŕů›68ŕ1 +PB`ŕů›7Ăx1 +žpB ŕůóć< +"HB ŕůƒ6 >HC ŕůƒ63Ě1"DB ŕůƒ7ăžř0"DńÁŕřŕř@€ŕřŕř€ŕůűóĎϏœwűřp@€@ŕřccŘÜwƒĚ` +€*ˆ€ŕřcŘŢ÷˝ƒĚ`b‰aÏpË lņŽ"aË,8pǀpŕřcăĂŢ÷˝ól`b +€*’ D" L“"TFI‘"’$L2DˆB"ŕřcăŰśíƒl`ăÄxȑ"TPDH‘*ă"|`B"xŕřccŘŰśíƒ<`‰DˆH‘"TPDH‘*ˆ‘"@B"ˆŕřccŘŰśíƒ<`b‰$D‘"ˆH“"T DI‘0$H‘2DˆB@ "ˆŕřc÷Ï™6Mű`aqĂĂxȍT DFŽȏ,8pA€xŕř ŕř€ ŕřŕřŕřŔ ŕř ŕřáĂHŽ,8pǀXhă` 8qaŔ||aÉXhŕ‡ŕř$ȑ2Dˆ"d™  ‘&‰’ f̐$J"d™€ŕřĂäHŸ"@ř"D‰ "‰€fĚä "@ˆŔ€ŕř"H"@€""D‰ "‰@6fĚ$ +"@ˆ €ŕř$ɑ"Dˆ""D™ &‰#6fĚ’$I +"@™H€ŕřáĂFŽ"8pÂDhâ qÁf|a㈊@hŕ‡ŕř@ŕř@ŕřŕřŕř @@ŕř‚@"@AŕřâÀ,8hâÁXqaŔ"XpâC€<ńaŔ,8q`ŕřƒ$@2˜# A"d ’  d‰„@A’ ‘2D‰ŕř‚'Ŕ ˆ"#ÁDyŕ DůAŕ |ůŕř‚$ ˆ"$AD‰"D€€A @ŕř’$@ ˜"$A"D‰’ "D‰D@I ‘ D‰ŕřb#€ h"#ÁDyaŔDpâ#€1Ŕ 8qŕřŕřpŕřŕřŕř@€€Ŕŕ@ŕř€Ŕ€ŕřaǍŽ,8ăŔ°áŁ‹,4ÇÇŔ,4ăŔXqáËŕřB +2D"É`Œ‚2LflŔ2L™"d€DL‘ŕřB +"0ń>‰ň ˆ‚"DćlŔ"D‘>@x€DHŒŕřB +‘" ‰ ˆ‚"DflŔ"D‘ @ˆ€DH‚ŕřBJ‘2D ‘"É`ˆ‚"LflŔ"L™"@ˆDH‘ŕř`AŠ,8đŔ°á ˆ‚"4ögŔ"4á@x`CˆŽŕř ŕř Ŕ8ŕřŕřŕřŕ€ŕř €ŕřâÀDp @ŕř$@&D @ŕřňŔ"Dx @ŕř"Dˆ @ŕř@&Lˆ @ŕřň€4x €ŕř€ŕřŕřŕř8@ŕůű !€C÷ďß €B'ńńŔ8 ŕůƒ q€ăŒ€ €ŁdˆŠ‰ "D ŕů˜q€ăŒ€ €ŁdˆŠ ‰ "Dŕůń˜Ůłá™€ €˘§ˆŠ ńဠ0ŕů€ŮłŒ ¤H‘ Ą@”.ŕů€đůóŒ€ ň¤HŸ ‘ ’"Dŕů€aƒŒ€ ¤H‘ ‰ ‘"DŕůřaűŮ€ ů'‰ńŔ‘8 ŕř  ŕř8@ŕřŕř8ŕř8€áÇȀ8!ŕŕřD$€DQˆ‘"ŕřD$ +€DQˆ‘"ŕř@‡Š€@Qŕŕř@D +€@‰@JŕřD$Dů É"ŕřD$D‰H‘"ŕř8řáÇĹ8‰HŽŕřŕř8ŕřŕřŕůű !ƒçďϟ?ˆâŕůƒ qƒ6 Ů°ČBŕů˜qƒ6 Ů° ČBŕůń˜ŮƒçϘٞ ¨Bŕů€Ůƒ6 ß0¨Bŕů€đůƒ6 Ů°˜Bŕů€aƒ6 Ů° ˜Bŕůřaűç왿 ˆăŕŕřŕřŕřŕřpŕůűqߟ1żA„N CÇŕřcqŘ1ąŒAFÉ ˘$H„ŕřc{Ř1ąŒ AFÉ@˘$H‚ŕřc{ß1ąŒ AEO@ŁÄŕřcnŘ1ąŒA%H‘"A…ÁŕřcnŘ1ąŒAĺH‘>AňDH‚ŕřcnŘ1ąŒ A%H‘"A$H‚ŕřcdߟ Aň$O"!#‡ŕř@ ŕřpŕřŕřpŕř8ŕř"Dŕř +&Lŕř*Tŕř*Tŕř2dŕř"DŕřŽ8ŕřŕřpŕřŕřŕůűqߞ ŕřcqŘ3`ŕřc{Ř8  ŕřc{ß ŕřcnŘ ŕřcnŘ ŕřcnŘ3 ŕřcdßž řŕřŕřŕřŕřp€ŕřóńóóǟ>~üςżA„N!ăă€<8p@ŕů›lŮł`ĆŘÇ0AFÉ!@ +"Dˆ@ŕůĂł`ĆŘÇ0 AFÉA@ +"Dˆ ŕřóăǙł|ĆŘ †> AEOAăĂ +<@` ŕř{ăß>`ĆŘ †0A%H‘"AB€(\ ŕř`Ř3`ĆŘφ0AĺH‘>A"@$Dˆ ŕů›lŘ3`ĆŘŘĆ0 A%H‘"A@"Dˆ ŕůńńńó÷Ϙ3~üϘĆ? Aň$O"!ă€"8p@ŕř@ @ŕřp€ŕřŕř`ŕřc€|řăŕ"x!ăŕ>D!áŔ ŕ‡xpŕŕř€‘6DQ lQ "!DH€D‰ŕřo€€‘6DQ lQ "ADH€D‰@€ŕřfđŔ€*DQăŔTQ€ADOx€Ŕ@€ŕřf€ €*x‰BȄT‰ŕ@ +A$J"P¸ @€ŕřf€‘*@ů"„Tů "AäI>H‰@€ŕřf‘*@‰„T‰ "A$H€"D‰@€ŕřfřŕ"@‰ŕD‰ŔŸ â'ˆ€"Dpŕŕř ŕřŕřŕřŕř qÇπDpăă‡ŕřŒ‰!"D‰H„ŕřď> ‰!"D‰H‚ŕřŒŮł ‰!DĂŕřŒßł ‰!DŕřŒŘ3 ‰!"D‰H‚ŕřŒŮł ‰!"D‰H‚ŕřěĎ3páÁ€8păă‡ŕř ŕřŕřŕř 8ŕř€AÄG>řAÄž>ŕř€B$H„ € „‘ ŕřyžx‚$H„ € „‘ ŕřͲ̂$H„<đ „ž<ŕřý¸ü‚$H„ „” ŕřÁŽŔ‚$H„ đ„’ ŕřͦ̂$H„ „‘ ŕřyźxAÇ>ÇÇ>ŕř@€ŕř `8ŕřŕřpŕů¸ß1żAπ|řăŕ"|đCçŔDđâ "8ůđG<8ˆ@€ŕůźŮąŒA„B€2@ˆ „d‰`"D!B"Dˆ@€ŕůźŮąŒ A„B€2@ˆ „d‰`"D!B"D¨ @ŕůśŮąŒ AƒđŔ€*x𠇀T‰ "D!ŕB"D¨ @ŕůśß1ŒA€‚€ € *@Ą„”"T‰ "D!B"D¨ @ŕůłŘ1ŒA„B€&@‘đ„>L‰ "D!‚"DP @ŕůłŘ1Œ A„B&@‰„"L‰ "D!‚"DP @ŕůąŘ AńÂřŕ"|‰‡Ŕ"Dđâ 8!đ‡<8P@€ŕř@@€ŕřpŕřŕř@ @ŕřpqň!xˆƒ‡>|‰ÁÇȄ< ŕřH Cbˆ‘"Dˆ„H‘ @É  Š" ŕřH Cbˆ‘"DPH‘ @É  Š"ŕřx B˘ˆ"DP|‰áÁ‘  ŕř€ ŕř@ @ŕřŕř€ŕř|řăŕ"|đCçŔDđâ "8ůđ|ăŕ>DpÇÇDŕř€2@ˆ „d‰`"D!" lˆ$„"dŕř€2@ˆ „d‰`"D!" lˆ$„"dŕřđŔ€*x𠇀T‰ "D!ŕŔL‰ "D!" TˆD„"Lŕř&@‰„"L‰ "D!" Tˆ$„"Lŕřřŕ"|‰‡Ŕ"Dđâ 8!đŽâ>Dp'ÇDŕřŕř€ŕřŕř8ŕřƒ€ŕř„@"ŕř„Ŕ&ŕř…@*ŕř…@*ŕř†@2ŕř„@"ŕřă€ŕřŕř8ŕřŕř8ŕůű !ƒöoŸ €B'ˆâ'‡8áÏ>Dăă‡"€áÇÂŕůƒ qƒlـ €ŁdˆŠˆC$H‘D$H dB2€B!ŕů˜qƒĚـ €ŁdˆŠ ¨C$H•D$H dB2€B!ŕůń˜ŮƒáŒŮ€ €˘§ˆŠ ¨B¤H•D„Dă‡"řáÁŕř ŕř8ŕřŕř€ŕřPp„J‚ŕř H‰"PBdHŠH„I‚ŕř D‰"PBdHŠD„I‚ŕř Dpŕ<Pâ'‡ +DřáȄŕřŕř€ŕřŕř€€ŕř>8â€Dđâ 8qŽ"xqLJŕřD@d‰ "‰„2D‰$H‘ŕřD@d‰ "‰ +„2D‰R$H‘ŕřD@T‰  ‰P +„*D‰R'ˆ‘ŕřDO•T‰§Ę.‰P +„*D‰SĹžŕřD@ +L‰@ "‰0&Dˆ˘ˆŕřD@ +L‰@"‰0&Dˆ˘Hŕř8ăç€ +Dđá@Ÿ8q"xp˘Gŕřŕř€ €ŕřŕřŕřDqȀŕřD!’$H€ŕřT!’$J€ŕřT!R$J€ŕřT!R$J€ŕř(!2$Eŕř(!2$Eŕř(qÅŕřŕřŕřŕřŕřqÇπ<|páÄBŕř‰!"@ˆB&Bŕř ‰!"@ˆB&Aŕř ‰!DÄO"đ@€ŕřB$E D†H‘"ˆ@€ŕř>x‚$E TP†H‘*ˆ @ŕřf́‡ĹxAÄH>(ĄÄOˆ@€ŕř@@€ŕř ŕřŕř€€€ ŕřŔ<|‰ŕ"|đăŕ8q>ŕř  "@ɐ"@‰"‰ŕř<ř ŕ"@ɐ"@‰"‰ŕř fŘŔ0"xŠxđĂŔ ‰P ŕř fŔ€0ž<@Š +@ " +.‰Säŕř fŔ@0 @™ @‘ "‰0ŕř fŔ 0 @™@‰"‰0ŕř <Ŕ 0 |‰ŕŸ|ˆăŕŸ8qÇŕřŕř€€€ ŕřŕřŕř 8qđˆDqȀ<|páÄBŕř ˆ@HD!’$H€"@ˆB&Bŕř ˆ@HT!’$J€"@ˆB&Aŕř `@HT!R$J€T!R$JŸ(@¸B%Aŕř ˆ@H(!2$E$@ˆB$Áŕř ˆ@H(!2$E"@ˆB$Áŕř>8p@ž(qÅ"|páÄBŕřŕřŕřŕř ŕřAÄB>DÄO"đ@€ŕřB$E D†H‘"ˆ@€ŕř>x‚$E TP†H‘*ˆ @ŕřf́‡ĹxAÄH>(ĄÄOˆ@€ŕř@@€ŕř ŕřŕř€€ŕř>Dń>D!áÏpăÇϑ88ů‡ŕřD‰ lQ$H‘‰$$!ąDAŕřD‰ lQ$HŠ ‰$$!ąDAŕřDńPTQHŠ aǏ<!QDAŕř +DĄP„T‰âO „"!R'ŕř D‘0„Tů$H ‰D"!SäŕřD‰0„T‰$H ‰$"!R$ŕřŸ8‰D‰Èpâ'ϑ<8!$ŕřŕř€€ŕřŕřŕůűóĎŰđŕřccŕřceŕřcăĂa ŕřcă ŕřcc€ŕřccaŕřc÷ĂđgÁŕřŕřŕřŕřŕřˆâŕřČBŕřČBŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ŕ EXAMPLE 3 Řł˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙đđóüŔđ`€Ŕđ`€Ŕđ`řóŕ˜ßsńóŕŔđa™€Řٛ`ŔđaÁ€Řٛ Ŕđaüń€Řٛű Ŕđa€9€Řٛŕđa™€ŘٛŔđ`řđŕĎٛńóŔđđđđđđ€óçĎßż<üđ>xqŔ8p@ó6l0f1˜D‰’  Dˆ@ó6l0p1ŔbD‰’ +D ó6o†><0đb x‰Rp óçĚ00xP‰Rŕ ól00H‰2   ól0f1˜bD‰2 @ˆ óoĆ?|1đaDqŔŸ|p@đ@đ€đđđ"|!Âđ"@Q Bđ*@Q@đ*xQŔđ*@‰ đ@ů đ@‰đ|‰đđđđó÷矟8î;÷đŕŕáÄH‘pŔđĆ Ć1ą¸î;˜ŔT "B&H›"€ " đĆ1ą˝ď{˜ŔÄ8Ňxpŕ&B&H›"qŕ‹xqc` +&`đÇdž01˝ď{ćŘŔÄT&H™ ‰*đBH•ˆ€ ‘ ‰’ * đĆĆ01ˇmŰŘŔsäO řŔ*ˆBĺH•ˆ€Ÿ ‰ * đĆĆ1ąˇmŰxŔH" € 2ˆB$ȕ"ˆ€ ‰ 2 đĆ Ć1ąˇmŰxŔÄ$H"$‰"ˆB$ȕ"ˆ€H‘ ‰ " B#đÇď†2l›ö8ŔÂáÄGpŕŔđáÄGp€ˆŽ q Ž AÁđđđđđÇÇ>8đ Dđŋ8p DâŔlđ&L‚Dˆ<0 "TđäH‚|`  >Tđ$H‚@ D  Tđ&L‚Dˆ D ‘"T`đĺ‹8pÁ>8â T đ đ@đđđ€Ŕ pđ € €đ>>qaÉx°ăŔ°áÄA8pǀ,8áō€đ3f‰’$J Č"É$Aˆ"2D‚&J€đ3fä ˆń>ń„A`""|‚$ +€đ3f + ‰ DA""@‚$ +€đ3f‰$I$‰ ‘"$Á ˆ" "D‚$ +€đł>qȎˆđŔ€áĂApÂ"8Ä +€đđđđđƒ‡áŔ@€ Ŕ>xp€đ„H€ @‚€€  Dˆ€đ„É€2`ŽDpŕ€đ€đ8đđóöC‡ďßžˆâóăĆ3ČBó0ăĆ3 ČBóă1łgĂ3 ¨Bó!łf>¨Bóáóć3˜BóĂ63 ˜BóđĂö6ł ˆăŕđđđđ óöCĎߟ>~B‚ â#Ÿ|řăŕ|‰çÇDřâ‚óăl1ł`BE"!$B€‰˛D BBó0ăl1ł`‚E"A$B€‰˛D BAóă1łϟ1ł|‚EA$BđŔ€ůSÁD Bó!łl1ž`‚H‘A$B€ ‡Č”‰R>D Bóáól1ł`‚O‘A$B€’‰RD BAóĂl1ł`‚H‘A$B€‘‰RD BAóđĂ÷ĎŘ3~C㈞ áÂřŕ€‘‰á8 ăă‚đ@ @đ 0đđŕ óöăż>c~‚œ<@‡‡đĆă°cc‚’"(ADH‘đĆ÷°cc‚’"(DH‘đĆ÷žcc‚Šž"(Gˆ đĆÝ°cc‚J‘"D‚% ‚đĆÝ°cc‚ʑ"|ƒäˆ‘đĆÝ°cc‚J‘"D‚$H‘đĆÉż>>ƒäHž|ýůŸ?~‚œ<CÇÇxpŕ€ó6666 ŮłfÁąŽ `‚’"(B$€D‰€ó†6663fÁąŽ `‚’"(‚$€D‰@ńć6Ǐ3fů° |‚Šž"(ƒÇ†x€Ŕ@đö6Çž|Á° `‚J‘"D‚„"P¸ @đ6666Á°fÁąŸ `‚ʑ"|‚D€>H‰@ó6666 Ů°fÁąąŒ`‚J‘"D‚$€"D‰@óăăăçďŸ0fýůŸ1Œ~ƒäHžD‘ "D€@@đ@‰ "T&D!I"D‰ "D€@@đ@ˆáŔDâŸ"8!ˆ"8‰óŔŸ8ř@€đ€đđđđ>|pÄH€|äG"đ ˆ$M€"@H„"đ ˆ$M€"@H„"đ <ˆ„J€"xĹH>đ ˆDJŸ"@ůK„"đ ˆ$J€"@Ȅ"đ ˆ$J€"@Ȅ"đ>pȀ@óäG"đ đđđđ8<8!áÀđ` +"DQ$@đůçŔ +"D|Q$@đc6Ŕ +<@fQâđc6(\f‰Bŕ€đc6$Dfů"$@đc6"Df‰$@đać"8f‰Àđđđđ@€đƒˆœ!äG"!'‚"!áŔ€đ„H’!H„"!$E$Q €đěŢđH’(AH„"A$E(Q €đ,٘žAĹH>A¤E8Qâ€đŒŮ˜ˆ‘AK„"A§ˆ$‰Bŕ€đě٘H‘AȄ"Ad‘$ů" €đl٘H‘AȄ"Ad‘"‰ €đÇ٘ƒ‡>!óäG" â$Ž"‰Ŕ€đ€ €đ@€đđ@đ>|p$ODůŕŽ"@ř„Hž8ˆÇÇđ ˆ&HŠ"HH"@ „L‘D$„đ ˆ&HŠ"PH"@ L‘D $‚đ <ˆ%HŠ pń "@ J‘@ŕdžđ ˆ%O Hĺ"@ Jž"@„đ ˆ$Č"Hˆ"@ I>DD‚đ ˆ$Č"DH"@ I"Dˆ$‚đ>pÄHDůŕOŽ| ƒˆ"8ˆ'Çđ €đ@đđ0đ1Ŕđđ7Ŕđ3đ3đ3đ3đ3đđđđ€đ‰ŕŽ< CǂDˆÇŔ>Dqň!đ(É" ˘$F"DŘ$ dˆB!đ(É"@˘$J"DŘ$ dˆB €đ(Š"@˘$BD¨'€DpB!đ đ€đđ @đ!äG"‰Á>xă㈐> đ!H„"‰’"ˆ’ DH đAH„"‰’"ˆ” DHđAĹH>‰R"ˆx㇠đ  đ @đđ€đŽpCŔ‘<qç€>8‰áđˆ˘ ™"(‰"@ D‰đ ˆ˘ ™"(‰B@ D‰€€đ €ŁŔ•"(ĂÄ@<0‰€€đ €•8qđđđ€đđ @đqÇπ đ‰! đ ‰!(đ ‰!đ ‰!đ ‰!đ ‰!đpáÁ€> đ  đ @đđ€đÇ>đ !„đ<ř!„đ fŘ!đ fŔ! „đ fŔ!„đ fŔ!„đ <ŔÇđđ€đđ`€đ`xđ$ODůŕŽ"@ř@đ"Dˆ&HŠ"HH"@ @đo€"Dˆ&HŠ"PH"@ đlŔ Dđ%HŠ pń "@ đlŔ D %O Hĺ"@ đlŔ"D$Č"Hˆ"@ đlŔ"Dˆ$Č"DH"@ đlŔxˆÄHDůŕOŽ| @đ@đ€đđđŔ>8áÇđŔ D„Bđ8ٙĆ3Ŕ D„Bđ ٘f6@Ćađ‡€>8áÇđ€đ đđ ŕđAÄG>p đB$H„ ˆ đ‚$H„ ˜ đ‚$H„<¨ đ‚$H„ ¨ đ‚$H„ Č đ‚$H„ ˆ đAÇ>p đ@€ đ `ŕđđđxůň'ˆ€8ˆăçŔ"8qńÂđĆD€B$L€D‰„"D‰$Bđ÷ǟD€B$L€D‰„"D‰$AđĆlـxđB'Š€D‰‡€ "@áƒđĆoـP€B% +€D‰„"@@đĆl€H€B$‰€D‰„"D‰$AđĆlـD€B$I€D‰„"D‰$Ađvg™€DřAÄH€8pŕ‡Ŕ8qńÂđđ đđđŔ!ăçȞ" â#Ÿ| âOđŔ!‘2!$B@PBHđ<Ď<A‘2A$B@PBHđfŮfAăÁž*A$BxPBOđ~Ü~AB”*A$B@ˆBJđ`Ç`A"’&A$B@řBIđfÓfA‘&A$B@ˆBHđ<Ţ<!á" áÂ@ˆă㈟đ @đ0đđ óqžc~CçÇ8ůç‚>đB'‡qÇπ@păŕ8ůň#€óyłc@„„D’E ˆŁ$H›‰!@!€!d@óyłc€„„D’E ˆŁ$H› ‰!@!€!d@ómłc€‡†@ńSDž<đ˘¤H• ‰!@ Ŕ€ž!âŁómžc€„\R„ |Ą¤H• ‰!@ ‡Č>! €óg°c€„„D2„ ‘ňdH• ‰!@!€!¤@óg°c€„„D2H„ ‰dH• ‰!@!€!¤@óc°>@‡Ç8ůäH„>‰'‡páÁ€|pŕ€8!ň#€đ@ đ đđđ8řâ'ŔDůáÇÂppâ$H€đ‘" B$"D$H!$M€đ‘" B$"T$ +H!$M€(đ‘ AG€"Tńâ'‚x!¤J€đ ADž"TB$>D!r¤J€đ" AD"("$D!dJ€đ" @„"($D!dJ€đ8 ŕ‡Ŕ(ůÄŽxpâ#ˆ€>đđđđ @€đ @đ" @đ& đ* đ* đ2 đ" đ @đ @đ @€đđóöCěß>qńÄOŽóă Ůł @†Čó0㙳 @†Čóă1łĂł @…O ó!ł> @…Hóáó˜3 @…HóĂ Ř3 @…HóđĂ÷ěŘ3 pAÄOŽđđđđó÷矷ŕđĆ Ć60đĆ60ĹđÇdž60ÉđĆĆ60 đĆĆ60€đĆ Ć60ÁđÇď†7ŕÁđđđđńÄ˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙ EXAMPLE 4 Ůw˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€ř€ř€ůţ€`đ€ř0Ŕ€á˜€ř0Ŕ€ă€ř0|yđĚošřůđc€ř0ĆĚŔ ll͍°cđ€ř0ĆŕŔ ll͍€c€ř0ţxŔ ll͍ý€c€ř0ŔŔ ll͍€c€ř0ĆĚŔ ll͍€c€ř0|xp gěÍřů€ađ€ř€ř€ř€ř€ř€ř€ůóçďߞ~x#ˆ€ů›63Ě!€ů›68ŕ3!€ů›7Ăx2Ą€ůóć<Ą€ůƒ6 a€ůƒ63Ě2a€ůƒ7ăžř2#€€ř€ř€ř€ř€€ůűóĎϏœwűřů@ €8p€řccŘÜwƒĚ` +€*!@@€€řcŘŢ÷˝ƒĚ`b!aÀ8đŇ<8â#68đáŔˆ€€řcăĂŢ÷˝ól`b +€*!D@"D@&HD$D*@" ˆ€€řcăŰśíƒl`!C>0@|Â#*<@"ˆ€€řccŘŰśíƒ<`!@€ @@!@„*D@"…"€řccŘŰśíƒ<`b!D@ "DH$‘DDD‘*DH" …"€řc÷Ï™6Mű`a!C€80Ä 8ŕƒƒ*<0!Ŕ‚€ř€€ř€ €ř€ř€ř >8‰ńǏ„>|€ř@ @ DČB$H +@€řáĆË,8đáŇxâĂH›Xđŕ‡ DČB$H +@€ř%L‚2@"&H€" $ȕ"dA€D@Ŕ€ D¨B@€ř%H‚"D@"$A" H• D@ € D˜B$ˆ@€ř%L‚"DH"$H€" ɕ"DIH€ D˜B$H@€řáĹK"<0!ÄG ňF•D0ŕ‡ 8ˆAÄO‘|€ř@€ř€€ř€ř€řp€ř€€řâ%‡8°€ř‚&HˆDČ€ř‚$HDˆ€ř‚$HDˆ€ř‚dH‰DˆŔ€ř¤G8ˆ@€ř@€ř€€ř€ř€ř  €€ř  A €€ř‹ xpăÀ,8ńaŀ,8âŔˆ€X°âŔ€řL“ ‰@2DA’&@2D ˆ€"dÉ €řȑ řÁ"|Aä"| ˆ€>@ €řH‘ €!€"@A"@ … @€řH“$‰$@ +"DI$ "D …"@€řȍpŕÀ +"81Ä"8⠂@€â€ř€ř €ř€ř €ř(8!Ŕp€ř(@@ €€ř(đŕC€xáÄK €ř@ D@" ‚$L“€ř@ GŔ" ‚$H‘€ř@ D" ‚$H‘€ř@ D@"$‚$ȓ€ř@ C€ĂH€ř€ř €ř€ř8@€ůű !€C÷ďß €B'ńńŔ8 €ůƒ q€ăŒ€ €ŁdˆŠ‰ "D €ů˜q€ăŒ€ €ŁdˆŠ ‰ "D€ůń˜Ůłá™€ €˘§ˆŠ ńဠ0€ů€ŮłŒ ¤H‘ Ą@”.€ů€đůóŒ€ ň¤HŸ ‘ ’"D€ů€aƒŒ€ ¤H‘ ‰ ‘"D€ůřaűŮ€ ů'‰ńŔ‘8 €ř  €ř8@€ř€řŔ€řLjăŕ>8řç8 CäHŽ"@ă‚€ř€ř€ř€ř €ř CLjqÇπ|ůńÄOž>8qáǏŽ<€ř ˘$H‰!"@!&B D‰„B"€řß|@˘$H + ‰!"@!&B D‰„B"€řłf@˘$H + ‰!x!â%B<0ŕ„B<€řżfALj ‰!@!%B @‡‚(€ř°fAň ‰!"@!$ D‰ „$€řłfA ‰!"@!$ D‰„"€řٞf!„páÁ€|!ÄB>8qÄ"€ř  €ř €ř€řŔ€řxpŕ@€řD‰@€řD‰@€řx€Ŕ@€ř"P¸ @€ř>H‰@€ř"D‰@€ř"Dpŕ@€ř@€řŔ€ř€ř€ůű !ƒçďϟ?ˆâ€ůƒ qƒ6 Ů°ČB€ů˜qƒ6 Ů° ČB€ůń˜ŮƒçϘٞ ¨B€ů€Ůƒ6 ß0¨B€ů€đůƒ6 Ů°˜B€ů€aƒ6 Ů° ˜B€ůřaűç왿 ˆăŕ€ř€ř€ř€ř€ůűqߟ1żˆâ€řcqŘ1ąŒČB€řc{Ř1ąŒ ČB€řc{ß1ąŒ ¨B€řcnŘ1ąŒ¨B€řcnŘ1ąŒ˜B€řcnŘ1ąŒ ˜B€řcdߟ ˆăŕ€ř€ř€ř€ř€ůűqߞ €řcqŘ3`€řc{Ř8  €řc{ß €řcnŘ €řcnŘ €řcnŘ3 €řcdßž ř€ř€ř€ř€řp€€řóńóóǟ>~üςżA„N!ăă€<8p@€ů›lŮł`ĆŘÇ0AFÉ!@ +"Dˆ@€ůĂł`ĆŘÇ0 AFÉA@ +"Dˆ €řóăǙł|ĆŘ †> AEOAăĂ +<@` €ř{ăß>`ĆŘ †0A%H‘"AB€(\ €ř`Ř3`ĆŘφ0AĺH‘>A"@$Dˆ €ů›lŘ3`ĆŘŘĆ0 A%H‘"A@"Dˆ €ůńńńó÷Ϙ3~üϘĆ? Aň$O"!ă€"8p@€ř@ @€řp€€ř€ř`@ @€řc€8đ„GůńÇŔ8đƒ‚<ńńÁ€ř Dˆ„E"‰!€ř DˆE"‰ €€ř8€ƒˆž"‰ńÁ€ř€€ř @€ř€ř€ř‡Â€ř€B€ř€€ř€€ř€ř€ř‚€řâ€ř€ř€ř€ř€ř qÇπDpă㇀řŒ‰!"D‰H„€řď> ‰!"D‰H‚€řŒŮł ‰!DĂ€řŒßł ‰!D€řŒŘ3 ‰!"D‰H‚€řŒŮł ‰!"D‰H‚€řěĎ3páÁ€8pă㇀ř €ř€ř€ř 8€ř€AÄG>řAÄž>€ř€B$H„ € „‘ €řyžx‚$H„ € „‘ €řͲ̂$H„<đ „ž<€řý¸ü‚$H„ „” €řÁŽŔ‚$H„ đ„’ €řͦ̂$H„ „‘ €řyźxAÇ>ÇÇ>€ř@€€ř `8€ř€ř€€ů¸ß1ż â#Ÿ"řáŔ"8ůđD #ˆ€ůźŮąŒ!$B6( B "D!Š"DP!€ůźŮąŒ ADB6( B "D!Š"DP!€ůśŮąŒ @ÁC*( B"D!ŕ + |PĄ€ůśß1Œ@ €‚*D B"D! ‘ DˆĄ€ůłŘ1ŒA„B*| B "D!Ÿ"Dřa€ůłŘ1Œ A„B*D B "D!‘"Dˆa€ůąŘ ŕƒ‚"D áŔ8!đDˆ#„€ř €ř€€ř€ř€€ř"8ůđp#ˆ€ř"D! 0ˆ!€ř"D!Pˆ!€ř"D!ीř"D!„ Ą€ř"D!@a€ř"D!€a€ř8!đ|ř#„€ř€ř€€ř€ř€ř>8ř„8‰ÁÄB8ˆŕ€ř D D"DŮ †EDÉ€ř D D"DŮ †EDÉ€ř<0 D DŠŕ…ED¨Ŕ€ř  $ DŠ…H„D¨ €ř D ä"DŠ„Ď„D™€ř D B$"DŠ„Č„D™€ř>8 B'π8‰áÄH„8ˆŕ€ř€ř€ř€ř@€ř8ˆăçŔpqŔŸ<8‰"| €řD‰„H‰ "‰°" €řD‰„H‰ "‰°"€řD‰‡€x‰ +ž"‰P>€řD‰„D‰ +"‰P"€řD‰„D‰ +"‰P"€řD‰„D‰ +"‰P"€ř8pŕ‡ŔxqóŔŸ<8qÇ" €ř €ř @€ř€ř€řqđ„xřâ$€ř ADD$€ř ADD$€ř ADxń$€ř B$Pr$”€ř CäH$’€ř B$D$‘€řpB'ÇDřáÇȑ€ř€ř€ř€ř€€řńńÄH<pâ'8ůŕȞDńóŔ€€ř‰$H +"‰dH"D‘d‰ €€ř ‰$H +"‰dH"Dd‰ €€ř ńâH +<¤O0ń‚T‰â €€ř ĄäH(§Š"T‰ €€ř ‘$H$‰¤ "D>L‰ €€ř ‰$H"‰¤"D"L‰ €€ř‰ńϑ"pâ$Ÿ8ůŕȐ"DńóŔ€€ř€€ř€€ř€ř€€ř"8ůđ8Ä€ř"D!€"D„€ř"D! €"L„€ř"D!ŕ +€"TP„€ř"D! +€TP„€ř"D! €d0„€ř"D!€"D0„€ř8!đ8Ç€ř€ř€€ř€ř€ €ř"8ůđx€B >8p#ˆ€ř"D!„"D€˘ ‘ Dˆ!€ř"D!„"D€Ą@‘ Dˆ!€ř"D!ŕ„D€Ą@ž<0`Ą€ř"D!„x€ Ą€ř"D!„"@đ€ Dˆa€ř"D!„"@€ Dˆa€ř8!đ@ů€>8p#„€ř€ř€ €ř€ř€ůű !ƒöoŸ|qă|ř€ůƒ qƒlـ@‰„H€€ů˜qƒĚـ@‰„H€€ůń˜ŮƒáŒŮ€x‰P„đ€ů€ŮƒŸ@‰P„ +"€€ů€đůƒĚ€@‰0„I>€€ů€aƒl€@‰0„H"€€ůřaűöl€@qƒˆŸ"ř€ř€ř€ř€ř€ůűóĎŰđ€řcc€€řce€řcăĂa€řc　řcc€€řcca€€řc÷ĂđgÇ€ř€ř€ř€ř€řˆâ€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙˙€' T& ' T'H T&H & MODERN +MODERNMODERN +Úánw˘Wr2’;“7ůYĹ“Łz;ŘgđX&Ž4h덋ÚďÜâl& BMOBJ.GETFN2#U˙ÇkP´Ź >ž BMOBJ.GETFN2MODERN + `š BMOBJ.GETFN2MODERN + eţ BMOBJ.GETFN2MODERN + Wî BMOBJ.GETFN2MODERN +Bzş \ No newline at end of file diff --git a/internal/test/tools/TESTERLOADER b/internal/test/tools/TESTERLOADER new file mode 100644 index 00000000..e638edc1 --- /dev/null +++ b/internal/test/tools/TESTERLOADER @@ -0,0 +1,47 @@ +(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 diff --git a/internal/test/tools/TESTERLOADER.LCOM b/internal/test/tools/TESTERLOADER.LCOM new file mode 100644 index 00000000..34e2ea09 --- /dev/null +++ b/internal/test/tools/TESTERLOADER.LCOM @@ -0,0 +1,27 @@ +(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 diff --git a/internal/test/tools/TESTERVARS b/internal/test/tools/TESTERVARS new file mode 100644 index 00000000..a94a8b61 --- /dev/null +++ b/internal/test/tools/TESTERVARS @@ -0,0 +1,347 @@ +(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 diff --git a/internal/test/tools/TESTERVARS.DFASL b/internal/test/tools/TESTERVARS.DFASL new file mode 100644 index 00000000..8327e710 Binary files /dev/null and b/internal/test/tools/TESTERVARS.DFASL differ diff --git a/internal/test/tools/TESTEXEC b/internal/test/tools/TESTEXEC new file mode 100644 index 00000000..501b1c47 --- /dev/null +++ b/internal/test/tools/TESTEXEC @@ -0,0 +1,147 @@ +(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 diff --git a/internal/test/tools/TESTEXEC.LCOM b/internal/test/tools/TESTEXEC.LCOM new file mode 100644 index 00000000..c3ab2984 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..9446e4b8 Binary files /dev/null and b/internal/test/tools/TESTEXEC.TEDIT differ diff --git a/internal/test/tools/TESTUSERS.TEDIT b/internal/test/tools/TESTUSERS.TEDIT new file mode 100644 index 00000000..922ef3a4 --- /dev/null +++ b/internal/test/tools/TESTUSERS.TEDIT @@ -0,0 +1,3 @@ +THE INTERLISP-D TESTING SYSTEM - USER GUIDE This document should be used as a guide for users of the testing system, and it assumes that the reading of "The InterlispD Testing System" document. LOADING THE TESTING SYSTEM The testing system resides on the directory {Eris}tools>. To load the testing system, LOAD the file TESTERLOADER. This file contains the correct loading sequence for the testing system files. FILES: TESTER.DCOM - Contains the main part of the tester program. TESTERVARS - Contains most of the tester global variables. TEST-REMOTE-EVAL.DCOM -Contains the functions for executing remote eval. RANDOM-GENERATOR.DCOM - Contains functions and variables for random generation. VARBROWSER.DCOM - A user package for manipulating the programs global variables. THERMOMETER.DCOM - A user package for displaying the progress of a program in execution. INTERLISPD-SYSTEM.CONCEPTSPACE - The file contains the global concept space of the system. EXECUTING TESTS Usually execution of tests will be done through the Concept Space Browser. The basic function which is called by the browser is: (TEST.PERFORM-TEST TEST TIMES LOCATION TRACE-FILE TRACE-MODE) [ function] Only the first argument is necessary. TEST must be of type TEST. TIMES is the number of times that the test will be performed and is defaulted to the value of the field TIMES of TEST. If this value is NIL it will be executed once. LOCATION can be either the atom "Local" or the atom "Remote" and is defaulted to the value of the global variable TEST.DEFAULT-LOCATION. TRACE-FILE is the name of the file on which the test execution process should be traced. The default name is the value of the global variable TEST.TRACE-FILE-NAME. TRACE-MODE can be the atom "On" or the atom "Off". It is defaulted to the value of the global vcariable TEST.DEFAULT-TRACE-MODE. When TRACE-MODE is "On" every testing step will be recorded on the trace file as soon as possible. The tracing will be done in a "careful" way - as soon as a new information is available (The input was generated, the result from the tested expression evaluation is returned, etc. ) , the trace file will be opened the information will be written and the file will be cvlosed. If the trace mode is Off, the function will check at the end of each iteration of the function to see if the outcome was a failure and only in such a case it will write it down on the trace file. There are two ways in which the PERFORM-TEST function can iterate. One way is if the TIMES argument is greater then one (or the times field of the test is greater then one). The other way is when the input expression is a list starts with the atom SYSTEMATIC. In such a case each of the elemnets of the CDR of the list will be evaluated. The tester expect them to produce sets (lists) which are the ranges of the arguments. It will then collect all the possible combinations of the elements in these finite ranges and perform the test on each of these combinations. The function returns the name of the trace file. (TEST.HARDCOPY-TRACE-FILE TRACE-FILE OUTPUT-FILE FAILURES-ONLY) The default for TRACE-FILE is the value of TEST.TRACE-FILE-NAME. The default for OUTPUT-FILE is the value of TEST.DEFAULT-HARDCOPY-DEVICE (usually {LPT}). The trace file is written in a way that is hard for reading. This function prints the trace file in a "pretty" way. if FAILURES-ONLY is non-NIL only the trace of tests that failed will be printed out. Manipulating Concept Spaces Concept spaces are stored in files, each concept space in its own file. usually the name of the file can be XXX.CONCEPTSPACE where XXX is the name of the concept space. This name can be retrieved by calling (TEST.CANONICAL-CONCEPT-SPACE-FILE-NAME CONCEPT-SPACE-NAME) Returns XXX.CONCEPTSPACE where XXX is the value of CONCEPT-SPACE-NAME. A concept space is of type CONCEPTSPACE which is record with the fields CONCEPTSPACENAME ROOTCONCEPT and CONCEPTLIST. ROOTCONCEPT is the name of the root concept. CONCEPT list is a list of concepts. A concept is an instance of the record CONCEPT which has the fields CONCEPTNAME, TESTS, SUBCONCEPTS and SUPERCONCEPTS. SUBCONCEPTS and SUPERCONCEPT are NAMES of concepts. TESTS is a list of tests ids. Usually the initial concept space will be created by the function (TEST.CREATE-NEW-CONCEPT-SPACE CONCEPT-SPACE-NAME ROOT-CONCEPT-NAME) which returns an instance of CONCEPTSPACE with one concept. The rest of the concept space will be most conveniently built using the Concept Space Browser. The system maintains a global list of the concept spaces that are "known" to the system. It is convenient to work with concept spaces that appear in that list since this will enable the user to perform certain operations on the concept space using the background menu. The global list is stored in the global variable TEST.CONCEPT-SPACES. This variable can be manipulated directly or by calling the function (TEST.ADD-CONCEPT-SPACE-TO-CONCEPT-SPACES CONCEPTSPACE) If a concept space with the same name is already in the list, it will be removed and the new one will be added. The function (TEST.GET-CONCEPT-SPACE NAME) Returns the concept space with name NAME (if there is one in TEST.CONCEPT-SPACES). Concept spaces that are on the TEST.CONCEPT-SPACES can be stored by calling the function (TEST.STORE-CONCEPT-SPACE CONCEPTSPACENAME) The function will prompt for a file name, suggesting the canonical name. If the concept space was loaded before through the TEST.LOAD-CONCEPT-SPACE function then the candidate file name will be the same as the one that it was loaded from (but with higher version). The user can also choose the subitem "Store Concept Space" from the background menu. (TEST.LOAD-CONCEPT-SPACE CONCEPT-SPACE-FILE-NAME) Loads the concept space from the specified file, adds it to TEST.CONCEPT-SPACES and keeps the file name in the property CONCEPTFILE of the concept space name. Building and manipulating tests (TEST.CREATE-NEW-TEST ) [function] Creates an instance of the record TEST with the default values which are obtained by calling the function TEST.GET-DEFAULT-FIELD-VALUE. The new instance is then added "officially" to the world by calling TEST.ADD-TEST . Then the test editor is called on the new test to allow the user insert values to its fields. It does NOT store the test in a file, and this should be done later by calling either TEST.STORE-TEST or TEST.STORE-CHANGED-TESTS. The test, after created is not assigned to any concept, and it is recommended to assign it as soon as possible to at list one concept. (TEST.ADD-TEST TEST-RECORD) [function] Assigns a new ID to the test record instance by calling TEST.GET-AND-INCREASE-NEXT-TESTID and adds the test to the list of loaded tests. ( TEST.EDIT-TEST TEST) [function] TEST should be a test or a test number. If the global flag TEST.OBTAIN-LOCk-WHEN-EDIT is non NIL the function will try to obtain write lock on the test. If it fails to obtains such a lock it will exit without editing. The user can get the name of the locking users and automatically send release requests as described in the "accessing the database" section. The test inspector will be called and the test will be marked as changed. (TEST.GET-TEST TEST-NUMBER) This function is the user interface to the database management system. The user calls this function and gets the test with the TESTID TEST-NUMBER. Actually the system will search for the test in the list of the loaded tests. If it will not be found a "test fault" will occur and the system will look for the file for this test and load the test from there. If by adding the test to the list of loaded tests an "overflow" occurs (the number of tests is more then the maximum allowed), the last test on the list (the least recently used will be deleted from the list. (TEST.GET-FIELD-VALUE FIELD DATUM) Gets the "Actual value" of a test field. If the field value is indirect reference to other test, the field value will be retrieved from there (using TEST.GET-FIELD-VALUE thus enable chaining), otherwise it will return the field value of DATUM. ( TEST.GET-DEFAULT-FIELD-VALUE FIELD-NAME) FIELD-NAME is a TEST field name. The function will return the global default value for this field. The following functions can be useful when building a test for use within the actual test fields: (TEST.TEST-SINGLE-TIME TEST-NUMBER) There are tests which have the TIMES field greater then one. Such tests will be executed more then one time. there are also tests which have as their INPUT field a list starts with the atom SYSTEMATIC. Such tests will be applied on all the combinations of the elements of sets in their INPUT field. Such tests can run for hours only to discover that something in the test itself was not correct, and the trace file is full of garbage. To avoid such a cases it is recommended to create for such tests a "Testing test" which will perform the tested test once and will only check that the outcome is meaningful (i.e. The result is either "success" or "failure" etc). Such a test can be built easily by having as its Expression field a call to this function with the tested test as TEST-NUMBER. It may be also useful to add a WEAK or STRONG link in the tested test PRETESTS field. (TEST.ERRORP EXPR) [function] If an error occured during the evaluation of the evaluated expression, the returned result will be a list of two elements, the first is the atom ERROR!, and the second is the error number. This is a simple predicate that checks if an expression is of the form described above. It is useful for building the success predicate. For example, a test may have as the EVALEXPR the function ADD1, as its INPUT field some non numeric atom, and as its success predicate, the expression (LAMBDA (RES ARGS) (IF (AND (TEST.ERRORP RES)(EQP (CADR RES) 10)) THEN 'SUCCESS ELSE 'FAILURE] . This test tests whether the function ADD1 breaks with non-numeric arg error. (TEST.ALL-COMBINATIONS SET-OF-SETS) [function] Produces the Cartesian product of the sets in the list SET-OF-SETS . (TEST.ALL-COMBINATIONS '((a b)(1 2 3))) will return the list ((a 1)(a 2)(a 3)(b 1)(b 2)(b 3)). This function is used by the tester when it encounter an INPUT field starts with the atom SYSTEMATIC. It is useful in any case that the user wants to build tests that tries all the combinations of possible values of a function arguments, or to have all the possible settings for flags and global variables for some subsystem or library package. (TEST.LOCAL-EVAL-FORM FORM) [function] Evaluates the form FORM using ERRORSET, thus the avaluation will not break even if error condition occurs. If error did not occur the function will return the result of the evaluation of form. If error condition was entered, the function will return a list with the first element ERROR!, and the second element the number of the error (as described in Interlisp-D manual. (TEST.PERFORM-TIMED-EVALUATION FORM TIMEOUT.ms) [function] Evaluates FORM using TEST.LOCAL-EVAL-FORM (thus it will not break). If the evaluation will take time which is longer then the value of TIMEOUT.ms, the function will return the error expression (ERROR! TIMEEXPIRED). This function is used by the test driver if the TIMEOUT field of a test is non NIL, thus an evaluation that will take more time that the designated time will be considerd as returning with error condition. The function create a seperate process to perform the evaluation, and set a timer for the designated time (plus some time for overhead). The user should note that since the Interlisp-D process schedualing algorithms are non-preemptive, the function is not guarantied to halt. An infinite loop may not release the CPU and then only keyboard interrupt will work. (TEST.GET-NEXT-AVAILABLE-TESTID ) [function] The test ids should be unique. That's why the system maintains a file which holds the next available test id. This function access this file and returns the id. (TEST.GET-AND-INCREASE-NEXT-TESTID ) [function] This functions returns the next available id as the one above, but also increase this number on the file. this function is called by the function TEST.ADD-TEST which adds a test "officially" to the world. The Random Generator The random generator resides on the file RANDOM-GENERATOR.DCOM. The main function is (TEST.GENERATE-RANDOM OBJECT-SPECIFICATION) [function] This function is planned to be constantly expanded by the tests builders according to their needs. The OBJECT-SPECIFICATION can be an atom, which should be one of the objects known by the random generator. It can also be a list where the first element is an atom which is one of the known objects, and the rest of the list are modifiers according to the object type. The current list of known objects is : (INTEGER, SPECIAL-INTEGER, BOUND-INTEGER, LARGE-INTEGER, SMALL-INTEGER, BIGNUM, POSITIVE-BIGNUM, SPECIAL-BIGNUM,POSITIVE-POWEROF10-BIGNUM, WINDOW, REGION, SHORT-SIMPLE-LIST, SHORT-SIMPLE-NON-NULL-LIST, SHORT-LIST, LIST-OF-CHARACTERS, CHARACTER, LIST-OF-ITEMS and some more. Some of the objects have modifiers, like short list which can have a maximum depth as a modifier. A very important object is LIST-OF-ITEMS which can have as its modifier another object specification, thus enable recursive use of the function. Thus you can write (TEST.GENERATE-RANDOOM '(LIST-OF-ITEMS REGION 100 200)) which will produced betwwen 100 and 200 random regions. Database access (TEST.GET-LOCKING-USERS TEST-LIST) [function] TEST-LIST is a list of test numbers or the atom DATABASE. Will return the list of all the users that kas locks to tests in TEST-LIST together with the tests in TEST-LIST that they are locking. If TEST-LIST is the atom DATABASE, the function will return the names of all the users that have locks to any test. (TEST.OBTAIN-DATABASE-WRITE-LOCK TEST-LIST) [function] TEST-LIST is as above. The function tries to obtain locks on the list of tests in TEST-LIST. If TEST-LIST is the atom DATABASE, it will try to obtain lock on the whole data base. A lock on a test can be obtained if there is no other user locking the test. A lock to the whole data-base can be obtained if there is no user that locks any test. The function returns the list of all tests that it was able to lock. (TEST.RELEASE-DATABASE-WRITE-LOCK TEST-LIST) [function] As above, but releases the locksto the tests in TEST-LIST that are locked by the user. Returns all the tests that it suceeded to release. (TEST.SEND-RELEASE-REQUESTS TEST-LIST) [function] TEST-LIST is as above. Sends automatic messages to all the users with locks to the tests in TEST-LIST to release their locks. (TEST.MARK-AS-CHANGED TEST-NUMBER) [function] The number of thetests that are being modified using the programs editor are added to the global list TEST.LIST-OF-MODIFIED-TESTS. This can be done by calling this function . (TEST.UNMARK-AS-CHANGED TEST-NUMBER) [function] As above, but remove the test from the list. (TEST.STORE-CHANGED-TESTS) [function] Stores all the tests in the list of modified tests. (TEST.STORE-TEST TEST-NUMBER) [function] Stores the test TEST-NUMBER in the file wit h the name returned by the function TEST.TEST-NUMBER-TO-FILE-NAME, and removes it from the list of changed tests. (TEST.TEST-NUMBER-TO-FILE-NAME TEST-NUMBER) [function] Returns a file name on which the test TEST-NUMBER is stored. The directory is the value of the global variable TEST.TEST-DATA-BASE-DIRECTORY. The the root name for test number 45 will be TEST00045. The Concept Space Browser To browse a concept space you can either select the submenu "Browse Concept Space", or by calling the function (TEST.DISPLAY-CONCEPT-SPACE-BROWSER CONCEPT-SPACE REGION/POSITION DEPTH INCLUDE-TESTS) [function] CONCEPT-SPACE must be of type CONCEPTSPACE. REGION/POSITION can be either a region or a position for the browser window. DEPTH is the depth of the lattice that will be displayed. If INCLUDE-TESTS is non NIL, the tests will be included as part of the displayed graph. Only the first argument is neccessary. All the operations on concepts are done in PREFIX form - first you select the operation and then the argument (like all Lisp operations). Copy selection from a node will push the list of test numbers belong to this node into the current tty stream. The operations that are available using the concept space browser are: Copy subtree : Allow you to copy a subtree from one displayed concept space to another one. Will prompt for selection of the new parent node and the root of the subtree. Add Concept : Prompts for the parent of the new concept and for the name of the new concept. Delete concept : Deletes the concept selected, and all its children which have the deleted concept as they only parent (and so on recursively). Add Link : prompts for the superconcept and the subconcept and creates a link between them. Delete Link : prompts for the superconcept and the subconcept and deletes the linkl between them. Add test : Adds a test to a concept. Prompts for selection of the concept and for a test number. The test number can be a list of numbers, thus you can copy select tests from any node on any browser window. Delete test : Will ask you to select a node and will add a menu with all the tests of the node so that you can select those you want to delete. Edit test : Will ask you for selection of a node and will pop up a menu of all the tests in the selected concept. Will apply the test editor on the selected test. Display - Display tests on/off : will switch the mode of display. You can either display the graph with the tests as part of it or only with the concepts. Display - Browse subtree : Will ask you to select a concept and will aply the concept space browser on the subgraph for which the selected node is the root. Display - Change depth : Will pop up a menu of integers. You can select the depth of the graph being displayed. Display - Update : Recomputes the graph of the concept space and redisplays it. Execute tests : Will execute all of the tests or part of the tests of the selected concept. Will pop up a menu to set the execution modes. Hardcopy tests ; Sends a pretty printed hardcopy of all the tests (or the selecetd tests) of the selected concept. data base - obtain lock : Tries to obtain lock on all the tests of the selected concept. data-base - Release lock : Releases all the locks that the user has to tests belongs to the selected concept&H ) && MODERN MODERN +MODERNMODERN +.–Č<;IPQY[‚fÚ91@eŃ<GŐEœ›9~S[-b2  +I*‰'jJ9#ô,cb$q$—2+u;0˘1ĐW9Ž~289Ł:Œ40ą4-)4, 8Ęoe7A Ą TƒU WÉ † œ}…ZA €eBUHŻđzş \ No newline at end of file diff --git a/internal/test/tools/TESTUTILS b/internal/test/tools/TESTUTILS new file mode 100644 index 00000000..1c8f63bd --- /dev/null +++ b/internal/test/tools/TESTUTILS @@ -0,0 +1,37 @@ +(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 diff --git a/internal/test/tools/TESTUTILS.LCOM b/internal/test/tools/TESTUTILS.LCOM new file mode 100644 index 00000000..dd06e041 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..ce714942 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..58df7a99 --- /dev/null +++ b/internal/test/tools/VARBROWSER @@ -0,0 +1,362 @@ +(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 diff --git a/internal/test/tools/VARBROWSER.LCOM b/internal/test/tools/VARBROWSER.LCOM new file mode 100644 index 00000000..f0ab91e8 Binary files /dev/null and b/internal/test/tools/VARBROWSER.LCOM differ