diff --git a/ansi-tests/get-macro-character.lsp b/ansi-tests/get-macro-character.lsp new file mode 100644 index 0000000000000000000000000000000000000000..d1467ea63e32f0ca35a4e54137788f1b30458772 --- /dev/null +++ b/ansi-tests/get-macro-character.lsp @@ -0,0 +1,122 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Jan 2 15:54:27 2005 +;;;; Contains: Tests of GET-MACRO-CHARACTER + +(in-package :cl-test) + +(def-syntax-test get-macro-character.1 + (loop for c across "()';\"`,#" + collect + (let ((vals (multiple-value-list (get-macro-character c)))) + (list + (=t (length vals) 2) + (or (notnot (functionp (car vals))) + (and (symbolp (car vals)) + (notnot (fboundp (car vals))))) + (notnot (cadr vals))))) + ((t t nil) (t t nil) (t t nil) (t t nil) + (t t nil) (t t nil) (t t nil) (t t t))) + +(def-syntax-test get-macro-character.2 + (loop for c across (concatenate + 'string + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "1234567890!@$%^&*_-+={[}]<>?/~") + for (fn non-term-p) = (multiple-value-list + (get-macro-character c)) + unless (or (null fn) non-term-p) + collect (list c fn non-term-p)) + nil) + +(def-syntax-test get-macro-character.3 + (loop for rt in (list nil *readtable* (copy-readtable)) + collect + (loop for c across "()';\"`,#" + collect + (let ((vals (multiple-value-list (get-macro-character c rt)))) + (list + (=t (length vals) 2) + (or (notnot (functionp (car vals))) + (and (symbolp (car vals)) + (notnot (fboundp (car vals))))) + (notnot (cadr vals)))))) + (((t t nil) (t t nil) (t t nil) (t t nil) + (t t nil) (t t nil) (t t nil) (t t t)) + ((t t nil) (t t nil) (t t nil) (t t nil) + (t t nil) (t t nil) (t t nil) (t t t)) + ((t t nil) (t t nil) (t t nil) (t t nil) + (t t nil) (t t nil) (t t nil) (t t t)))) + +(def-syntax-test get-macro-character.4 + (loop for rt in (list nil *readtable* (copy-readtable)) + nconc + (loop for c across (concatenate + 'string + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "1234567890!@$%^&*_-+={[}]<>?/~") + for (fn non-term-p) = (multiple-value-list + (get-macro-character c rt)) + unless (or (null fn) non-term-p) + collect (list rt c fn non-term-p))) + nil) + +;;; Copying a readtable preserves the reader macros + +(def-syntax-test get-macro-character.5 + (let ((rt (copy-readtable))) + (loop for c across +standard-chars+ + for (fn1 ntp1) = (multiple-value-list (get-macro-character c)) + for (fn2 ntp2) = (multiple-value-list (get-macro-character c rt)) + unless (and (or (not (symbolp fn1)) + (not (symbolp fn2)) + (eql fn1 fn2)) + (if ntp1 ntp2 (not ntp2))) + collect (list c fn1 ntp1 fn2 ntp2))) + nil) + +(def-syntax-test get-macro-character.6 + (let ((rt (copy-readtable))) + (loop for i below (min 65536 char-code-limit) + for c = (code-char i) + for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) + '(nil nil)) + for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) + '(nil nil)) + unless (and (or (not (symbolp fn1)) + (not (symbolp fn2)) + (eql fn1 fn2)) + (if ntp1 ntp2 (not ntp2))) + collect (list c fn1 ntp1 fn2 ntp2))) + nil) + +(def-syntax-test get-macro-character.7 + (let ((rt (copy-readtable))) + (loop for i = (random (min char-code-limit (ash 1 24))) + for c = (code-char i) + for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) + '(nil nil)) + for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) + '(nil nil)) + repeat 10000 + unless (and (or (not (symbolp fn1)) + (not (symbolp fn2)) + (eql fn1 fn2)) + (if ntp1 ntp2 (not ntp2))) + collect (list c fn1 ntp1 fn2 ntp2))) + nil) + + +;;; Error tests + +(deftest get-macro-character.error.1 + (signals-error (get-macro-character) program-error) + t) + +(deftest get-macro-character.error.2 + (signals-error (get-macro-character #\; (copy-readtable) nil) program-error) + t) + + diff --git a/ansi-tests/load-reader.lsp b/ansi-tests/load-reader.lsp index cd1b44ca9d0f88fcbae32ba0c9fe24df71ba69be..238c133621168dd5ee7e9999a04a5fd35c91cad1 100644 --- a/ansi-tests/load-reader.lsp +++ b/ansi-tests/load-reader.lsp @@ -14,5 +14,7 @@ (load "read-from-string.lsp") (load "readtable-case.lsp") (load "readtablep.lsp") +(load "get-macro-character.lsp") +(load "set-macro-character.lsp") (load "syntax.lsp") diff --git a/ansi-tests/read-from-string.lsp b/ansi-tests/read-from-string.lsp index 73f1dfb1d831ce19efe3ae2632072a701b9297fb..bbf3b5e4424328947f651bea7f0f53bfd97dad50 100644 --- a/ansi-tests/read-from-string.lsp +++ b/ansi-tests/read-from-string.lsp @@ -68,7 +68,7 @@ (assert (equal vals '(7123 4)))))) nil) -(deftest read-from-string.7 +(deftest read-from-string.8 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123") @@ -77,7 +77,7 @@ (assert (equal vals '(foo 2)))))) nil) -(deftest read-from-string.8 +(deftest read-from-string.9 (let ((*package* (find-package :cl-test))) (do-special-strings (s "123 ") @@ -86,7 +86,7 @@ (assert (equal vals '(123 3)))))) nil) -(deftest read-from-string.9 +(deftest read-from-string.10 (let ((*package* (find-package :cl-test))) (do-special-strings (s (concatenate 'string "( )" (string #\Newline))) @@ -97,7 +97,7 @@ ;;; Multiple keywords -(deftest read-from-string.10 +(deftest read-from-string.11 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123 ") @@ -106,7 +106,7 @@ (assert (equal vals '(123 5)))))) nil) -(deftest read-from-string.11 +(deftest read-from-string.12 (let ((*package* (find-package :cl-test))) (do-special-strings (s "7123 ") @@ -115,7 +115,7 @@ (assert (equal vals '(7123 4)))))) nil) -(deftest read-from-string.12 +(deftest read-from-string.13 (let ((*package* (find-package :cl-test))) (do-special-strings (s (concatenate 'string "( )" (string #\Newline))) @@ -127,7 +127,7 @@ ;;; Allow other keys -(deftest read-from-string.13 +(deftest read-from-string.14 (with-standard-io-syntax (let ((*package* (find-package :cl-test))) (do-special-strings @@ -137,7 +137,7 @@ (assert (equal vals '(|ABC| 4)) (vals) "VALS is ~A" vals))))) nil) -(deftest read-from-string.14 +(deftest read-from-string.15 (let ((*package* (find-package :cl-test))) (do-special-strings (s "123 ") @@ -146,7 +146,7 @@ (assert (equal vals '(123 4)) (vals) "VALS is ~A" vals)))) nil) -(deftest read-from-string.15 +(deftest read-from-string.16 (let ((*package* (find-package :cl-test))) (do-special-strings (s "123 ") @@ -158,7 +158,7 @@ ;;; default for :end -(deftest read-from-string.16 +(deftest read-from-string.17 (let ((*package* (find-package :cl-test))) (do-special-strings (s "XYZ ") diff --git a/ansi-tests/reader-test.lsp b/ansi-tests/reader-test.lsp index f928f172c8e8ac11f73cc45a1979ae055da6b034..191eb8d6102bb796dd7ed8ba01cd0e2ac18335d4 100644 --- a/ansi-tests/reader-test.lsp +++ b/ansi-tests/reader-test.lsp @@ -5,51 +5,6 @@ (in-package :cl-test) -(deftest readtable-valid (not (readtablep *readtable*)) nil) -(deftest readtablep.1 - (and (not (readtablep nil)) - (not (readtablep 'a)) - (not (readtablep 0)) - (not (readtablep 1/2)) - (not (readtablep 1.2)) - (not (readtablep 1.2s2)) - (not (readtablep 1.2f3)) - (not (readtablep 1.2e2)) - (not (readtablep 1.2d2)) - (not (readtablep (list 'a))) - (not (readtablep "abcde")) - (not (readtablep t)) - (not (readtablep '*readtable*)) - (not (readtablep (make-array '(10)))) - (not (readtablep (make-array '(10) :element-type 'fixnum))) - (not (readtablep (make-array '(10) :element-type 'float))) - (not (readtablep (make-array '(10) :element-type 'double-float))) - (not (readtablep (make-array '(10) :element-type 'string))) - (not (readtablep (make-array '(10) :element-type 'character))) - (not (readtablep (make-array '(10) :element-type 'bit))) - (not (readtablep (make-array '(10) :element-type 'boolean))) - (not (not (readtablep (copy-readtable)))) - (not (readtablep #'car)) - ) - t) - -(deftest readtablep.2 - (loop for x in *universe* - unless (if (typep x 'readtable) (readtablep x) - (not (readtablep x))) - collect x) - nil) - -(deftest readtablep.error.1 - (signals-error (readtablep) program-error) - t) - -(deftest readtablep.error.2 - (signals-error (readtablep nil nil) program-error) - t) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (deftest read-symbol.1 (let ((*package* (find-package "CL-TEST"))) (ignore-errors (read-from-string "a"))) diff --git a/ansi-tests/readtablep.lsp b/ansi-tests/readtablep.lsp index bef51bb429e90971906a1eaa28b17698039e03d6..0acce958ea18f9559cb129a45e4b14382642fe2f 100644 --- a/ansi-tests/readtablep.lsp +++ b/ansi-tests/readtablep.lsp @@ -6,17 +6,44 @@ (in-package :cl-test) (deftest readtablep.1 - (notnot-mv (readtablep *readtable*)) + (and (not (readtablep nil)) + (not (readtablep 'a)) + (not (readtablep 0)) + (not (readtablep 1/2)) + (not (readtablep 1.2)) + (not (readtablep 1.2s2)) + (not (readtablep 1.2f3)) + (not (readtablep 1.2e2)) + (not (readtablep 1.2d2)) + (not (readtablep (list 'a))) + (not (readtablep "abcde")) + (not (readtablep t)) + (not (readtablep '*readtable*)) + (not (readtablep (make-array '(10)))) + (not (readtablep (make-array '(10) :element-type 'fixnum))) + (not (readtablep (make-array '(10) :element-type 'float))) + (not (readtablep (make-array '(10) :element-type 'double-float))) + (not (readtablep (make-array '(10) :element-type 'string))) + (not (readtablep (make-array '(10) :element-type 'character))) + (not (readtablep (make-array '(10) :element-type 'bit))) + (not (readtablep (make-array '(10) :element-type 'boolean))) + (not (not (readtablep (copy-readtable)))) + (not (readtablep #'car)) + ) t) (deftest readtablep.2 (loop for x in *universe* - unless (if (readtablep x) (typep x 'readtable) - (not (typep x 'readtable))) + unless (if (typep x 'readtable) (readtablep x) + (not (readtablep x))) collect x) nil) (deftest readtablep.3 + (notnot-mv (readtablep *readtable*)) + t) + +(deftest readtablep.4 (notnot-mv (readtablep (copy-readtable))) t) @@ -33,6 +60,3 @@ (deftest readtablep.error.3 (signals-error (readtablep *readtable* nil t t t t) program-error) t) - - - diff --git a/ansi-tests/set-macro-character.lsp b/ansi-tests/set-macro-character.lsp new file mode 100644 index 0000000000000000000000000000000000000000..0d7c33d304f34c317a1f34e9aee6f377109ec96c --- /dev/null +++ b/ansi-tests/set-macro-character.lsp @@ -0,0 +1,65 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Mon Jan 3 10:37:16 2005 +;;;; Contains: Tests of SET-MACRO-CHARACTER + +(in-package :cl-test) + +(def-syntax-test set-macro-character.1 + (let ((*readtable* (copy-readtable)) + (*package* (find-package :cl-test))) + (let ((v1 (read-from-string "?!"))) + (assert (eql v1 '?!)) + (flet ((%f (stream char) + (declare (ignore stream)) + (assert (eql char #\?)) + 17)) + (let ((fn #'%f)) + (assert (equal (multiple-value-list + (set-macro-character #\? fn nil)) + '(t))) + (values + (multiple-value-list (read-from-string "?!")) + (multiple-value-list (read-from-string "!?"))))))) + (17 1) + (! 1)) + +(def-syntax-test set-macro-character.2 + (let ((rt (copy-readtable)) + (*package* (find-package :cl-test))) + (let ((v1 (read-from-string "?!"))) + (assert (eql v1 '?!)) + (flet ((%f (stream char) + (declare (ignore stream)) + (assert (eql char #\?)) + 17)) + (let ((fn #'%f)) + (assert (equal (multiple-value-list + (set-macro-character #\? fn t rt)) + '(t))) + (let ((*readtable* rt)) + (values + (multiple-value-list (read-from-string "?!")) + (multiple-value-list (read-from-string "!?")))))))) + (17 1) + (!? 2)) + +(defun set-macro-character.3-test-fn (stream char) + (declare (ignore stream)) + (assert (eql char #\?)) + :foo) + +(def-syntax-test set-macro-character.3 + (let ((*readtable* (copy-readtable)) + (*package* (find-package :cl-test))) + (let ((v1 (read-from-string "?!")) + (fn 'set-macro-character.3-test-fn)) + (assert (eql v1 '?!)) + (assert (equal (multiple-value-list + (set-macro-character #\? fn nil)) + '(t))) + (values + (multiple-value-list (read-from-string "?!")) + (multiple-value-list (read-from-string "!?"))))) + (:foo 1) + (! 1)) diff --git a/ansi-tests/syntax.lsp b/ansi-tests/syntax.lsp index 37bd9580d08c295ba7baf62db29a7cffd240ca03..2f26c26574261aa7669d2f1f1e3dfac5e9512205 100644 --- a/ansi-tests/syntax.lsp +++ b/ansi-tests/syntax.lsp @@ -369,35 +369,35 @@ (def-syntax-bit-vector-test syntax.sharp-asterisk.5 "#2*1" 1 1) -(def-syntax-bit-vector-test syntax.sharp-asterisk.5 +(def-syntax-bit-vector-test syntax.sharp-asterisk.6 "#2*0" 0 0) -(def-syntax-bit-vector-test syntax.sharp-asterisk.6 +(def-syntax-bit-vector-test syntax.sharp-asterisk.7 "#5*010" 0 1 0 0 0) -(def-syntax-bit-vector-test syntax.sharp-asterisk.7 +(def-syntax-bit-vector-test syntax.sharp-asterisk.8 "#7*0101" 0 1 0 1 1 1 1) -(def-syntax-bit-vector-test syntax.sharp-asterisk.8 +(def-syntax-bit-vector-test syntax.sharp-asterisk.9 "#10*01010" 0 1 0 1 0 0 0 0 0 0) -(def-syntax-test syntax.sharp-asterisk.9 +(def-syntax-test syntax.sharp-asterisk.10 (let ((*read-base* 3)) (read-from-string "#10*01")) #*0111111111 6) -(def-syntax-test syntax.sharp-asterisk.10 +(def-syntax-test syntax.sharp-asterisk.11 (let ((*read-suppress* t)) (values (read-from-string "#1* "))) nil) -(def-syntax-test syntax.sharp-asterisk.11 +(def-syntax-test syntax.sharp-asterisk.12 (let ((*read-suppress* t)) (values (read-from-string "#1*00"))) nil) -(def-syntax-test syntax.sharp-asterisk.12 +(def-syntax-test syntax.sharp-asterisk.13 (let ((*read-suppress* t)) (values (read-from-string "#*012"))) nil) @@ -489,11 +489,11 @@ (read-from-string "#B-0/10") 0 7) -(def-syntax-test syntax.sharp-b.8 +(def-syntax-test syntax.sharp-b.9 (read-from-string "#b0/111") 0 7) -(def-syntax-test syntax.sharp-b.9 +(def-syntax-test syntax.sharp-b.10 (let ((*read-eval* nil)) (read-from-string "#b-10/11")) -2/3 8) @@ -609,7 +609,7 @@ (def-syntax-test syntax.sharp-r.1 (loop for i = (random (ash 1 (+ 2 (random 32)))) for base = (+ 2 (random 35)) - for s = (let ((*print-base* base)) (write-to-string i)) + for s = (write-to-string i :radix nil :base base :readably nil) for c = (random-from-seq "rR") for s2 = (format nil "#~d~c~a" base c s) for s3 = (rcase (1 (string-upcase s2))