;-*- 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)