ba-aux.lsp 1.47 KB
Newer Older
1 2 3 4 5 6 7 8 9 10
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon May 30 06:45:08 2005
;;;; Contains: Aux. files for beyond-ansi tests

(in-package :ba-test)

(defun function-name-p (x)
  (or (symbolp x)
      (and (consp x)
sds's avatar
sds committed
11 12 13 14
           (eql (car x) 'setf)
           (consp (cdr x))
           (symbolp (cadr x))
           (null (cddr x)))))
15 16 17 18

(defun symbol-or-function-p (x)
  (or (symbolp x)
      (and (consp x)
sds's avatar
sds committed
19 20 21 22
           (eql (car x) 'function)
           (consp (cdr x))
           (null (cddr x))
           (function-name-p (cadr x)))))
23

24 25 26
(defun symbol-or-list-p (x)
  (or (symbolp x) (listp x)))

27 28 29 30 31 32 33 34 35 36 37 38
(defun function-designator-p (x)
  (or (functionp x)
      (and (symbolp x) (not (macro-function x)) (not (special-operator-p x)))))

(defun type-specifier-p (x)
  (typep x '(or symbol list class)))

(defun causes-error-p (pred formf &key (vals *mini-universe*) (var 'x))
  (when (symbolp pred)
    (assert (fboundp pred))
    (setf pred (symbol-function pred)))
  (loop for x in vals
sds's avatar
sds committed
39 40 41 42 43 44
        for inner-form = (if (functionp formf)
                             (funcall formf x)
                           (subst `',x var formf))
        for form = `(signals-error ,inner-form error)
        unless (or (funcall pred x) (eval form))
        collect x))
45 46 47 48 49 50 51 52 53 54 55 56

(defmacro def-all-error-test (name pred form &rest other-args)
  `(deftest ,name
     (causes-error-p ,pred ,form ,@other-args)
     nil))

(defmacro def-error-test (name form)
  `(deftest ,name
     (signals-error ,form error)
     t))