Commit 5560882a authored by pfdietz's avatar pfdietz

More reader tests

parent d9824270
;-*- 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)
......@@ -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")
......@@ -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 ")
......
......@@ -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")))
......
......@@ -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)
;-*- 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))
......@@ -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))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment