assert.lsp 9.28 KB
Newer Older
1 2 3
;;;; -*- Mode: Lisp; Syntax: Common-Lisp; indent-tabs-mode: nil; Package: SYSTEM -*-
;;;; vim: set filetype=lisp tabstop=8 shiftwidth=2 expandtab:

4
;;;;
jjgarcia's avatar
jjgarcia committed
5 6
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
7
;;;;  Copyright (c) 2001, Juan Jose Garcia Ripoll.
jjgarcia's avatar
jjgarcia committed
8 9 10 11 12 13 14 15 16 17
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Library General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 2 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../Copyright' for full details.

(in-package "SYSTEM")

18 19 20 21
(defun read-evaluated-form ()
  (format *query-io* "~&Type a form to be evaluated:~%")
  (list (eval (read *query-io*))))

22
(defun wrong-type-argument (object type &optional place function)
23
  #-ecl-min
24
  (declare (c::policy-debug-ihs-frame))
25 26
  (tagbody again
     (restart-case
Daniel Kochmański's avatar
Daniel Kochmański committed
27 28
         (error 'simple-type-error
                :format-control
29 30 31
                "In ~:[an anonymous function~;~:*function ~A~], ~
                 ~:[found object~;~:*the value of ~A is~]~%~8t~S~%~
                 which is not of expected type ~A"
Daniel Kochmański's avatar
Daniel Kochmański committed
32 33 34 35
                :format-arguments (list function place object type)
                :datum object
                :expected-type type
                )
36
       (use-value (value)
Daniel Kochmański's avatar
Daniel Kochmański committed
37 38 39 40 41 42
         :report (lambda (stream)
                   (format stream "Supply a new value of type ~A." type))
         :interactive read-evaluated-form
         (setf object value)
         (unless (typep object type)
           (go again)))))
43 44
  object)

45
(defmacro check-type (place type &optional type-string)
46 47 48 49 50 51
  "Args: (check-type place typespec [string-form])
Signals a continuable error, if the value of PLACE is not of the specified
type.  Before continuing, receives a new value of PLACE from the user and
checks the type again.  Repeats this process until the value of PLACE becomes
of the specified type.  STRING-FORM, if given, is evaluated only once and the
value is used to indicate the expected type in the error message."
52 53 54 55
  (let ((aux (gensym)))
    `(let ((,aux ,place))
       (declare (:read-only ,aux))
       (unless (typep ,aux ',type)
Daniel Kochmański's avatar
Daniel Kochmański committed
56
         (setf ,place (do-check-type ,aux ',type ',type-string ',place)))
57 58 59 60 61 62
       nil)))

(defun do-check-type (value type type-string place)
  (tagbody again
     (unless (typep value type)
       (restart-case
Daniel Kochmański's avatar
Daniel Kochmański committed
63 64 65 66 67 68 69 70 71 72 73
           (error 'simple-type-error
                  :datum value
                  :expected-type type
                  :format-control "The value of ~S is ~S, which is not ~:[of type ~S~;~:*~A~]."
                  :format-arguments (list place value type-string type))
         (store-value (new-value)
           :report (lambda (stream)
                     (format stream "Supply a new value of ~S" place))
           :interactive read-evaluated-form
           (setf value new-value)
           (go again)))))
74
  value)
75

76
(defmacro assert (test-form &optional places &rest arguments)
77 78 79 80 81
  "Args: (assert form [({place}*) [string {arg}*]])
Evaluates FORM and signals a continuable error if the value is NIL.  Before
continuing, receives new values of PLACEs from user.  Repeats this process
until FORM returns a non-NIL value.  Returns NIL.  STRING is the format string
for the error message and ARGs are arguments to the format string."
82 83 84 85 86 87 88 89 90 91
  (let ((repl
         (if places
             `(setf (values ,@places)
                    (assert-failure ',test-form ',places (list ,@places)
                                    ,@arguments))
             `(assert-failure ',test-form
                              ,@(and arguments
                                     (list* nil nil arguments))))))
  `(while (not ,test-form)
     ,repl)))
jjgarcia's avatar
jjgarcia committed
92

93
(defun accumulate-cases (cases list-is-atom-p)
94
  (declare (si::c-local))
95 96 97 98 99
  (do ((c cases (cdr c))
       (l '()))
      ((null c) (nreverse l))
    (let ((keys (caar c)))
      (cond ((atom keys) (unless (null keys) (push keys l)))
Daniel Kochmański's avatar
Daniel Kochmański committed
100 101
            (list-is-atom-p (push keys l))
            (t (setq l (append keys l)))))))
102

103
(defun ecase-error (value values)
104
  (error 'CASE-FAILURE :name 'ECASE
Daniel Kochmański's avatar
Daniel Kochmański committed
105 106 107
         :datum value
         :expected-type (cons 'MEMBER values)
         :possibilities values))
jjgarcia's avatar
jjgarcia committed
108 109

(defmacro ecase (keyform &rest clauses)
110 111 112 113 114
  "Syntax: (ecase keyform {({key | ({key}*)} {form}*)}*)
Evaluates KEYFORM and tries to find the KEY that is EQL to the value of
KEYFORM.  If found, then evaluates FORMs that follow the KEY (or the key list
that contains the KEY) and returns all values of the last FORM.  If not,
signals an error."
115
  (setq clauses (remove-otherwise-from-clauses clauses))
116 117 118
  (let ((key (gensym)))
    `(let ((,key ,keyform))
       (case ,key ,@clauses
Daniel Kochmański's avatar
Daniel Kochmański committed
119
         (t (si::ecase-error ,key ',(accumulate-cases clauses nil)))))))
120 121 122

(defun ccase-error (keyform key values)
  (restart-case (error 'CASE-FAILURE
Daniel Kochmański's avatar
Daniel Kochmański committed
123 124 125 126
                       :name 'CCASE
                       :datum key
                       :expected-type (cons 'MEMBER values)
                       :possibilities values)
127 128
    (store-value (value)
      :REPORT (lambda (stream)
Daniel Kochmański's avatar
Daniel Kochmański committed
129
                (format stream "Supply a new value of ~S" keyform))
130 131 132 133 134 135
      :INTERACTIVE read-evaluated-form
      (return-from ccase-error value))))

(defun remove-otherwise-from-clauses (clauses)
  (declare (si::c-local))
  (mapcar #'(lambda (clause)
Daniel Kochmański's avatar
Daniel Kochmański committed
136 137 138 139 140
              (let ((options (first clause)))
                (if (member options '(t otherwise))
                    (cons (list options) (rest clause))
                    clause)))
          clauses))
141 142

(defmacro ccase (keyplace &rest clauses)
143 144 145 146 147 148 149
  "Syntax: (ccase place {({key | ({key}*)} {form}*)}*)
Searches a KEY that is EQL to the value of PLACE.  If found, then evaluates
FORMs in order that follow the KEY (or the key list that contains the KEY) and
returns all values of the last FORM.  If no such KEY is found, signals a
continuable error.  Before continuing, receives a new value of PLACE from
user and searches a KEY again.  Repeats this process until the value of PLACE
becomes EQL to one of the KEYs."
150
  (let* ((key (gensym))
Daniel Kochmański's avatar
Daniel Kochmański committed
151 152
         (repeat (gensym))
         (block (gensym)))
153 154 155
    (setq clauses (remove-otherwise-from-clauses clauses))
    `(block ,block
       (tagbody ,repeat
Daniel Kochmański's avatar
Daniel Kochmański committed
156 157 158 159 160 161 162
         (let ((,key ,keyplace))
           (return-from ,block
             (case ,key ,@clauses
               (t (setf ,keyplace
                        (si::ccase-error ',keyplace ,key
                                         ',(accumulate-cases clauses nil)))
                  (go ,repeat)))))))))
jjgarcia's avatar
jjgarcia committed
163 164

(defmacro typecase (keyform &rest clauses)
165 166 167 168 169
  "Syntax: (typecase keyform {(type {form}*)}*)
Evaluates KEYFORM and searches a TYPE to which the value of KEYFORM belongs.
If found, then evaluates FORMs that follow the TYPE and returns all values of
the last FORM.  If not, simply returns NIL.  The symbols T and OTHERWISE may
be used as a TYPE to specify the default case."
jjgarcia's avatar
jjgarcia committed
170 171 172 173 174 175 176 177 178 179 180
  (do ((l (reverse clauses) (cdr l))
       (form nil) (key (gensym)))
      ((endp l) `(let ((,key ,keyform)) ,form))
      (if (or (eq (caar l) 't) (eq (caar l) 'otherwise))
          (setq form `(progn ,@(cdar l)))
          (setq form
                `(if (typep ,key (quote ,(caar l)))
                     (progn ,@(cdar l))
                     ,form))))
  )

181
(defun etypecase-error (value types)
182
  (error 'CASE-FAILURE :name 'ETYPECASE
Daniel Kochmański's avatar
Daniel Kochmański committed
183 184 185
         :datum value
         :expected-type (cons 'OR types)
         :possibilities types))
186

jjgarcia's avatar
jjgarcia committed
187
(defmacro etypecase (keyform &rest clauses &aux (key (gensym)))
188 189 190 191
  "Syntax: (etypecase keyform {(type {form}*)}*)
Evaluates KEYFORM and searches a TYPE to which the value of KEYFORM belongs.
If found, then evaluates FORMs that follow the TYPE and returns all values of
the last FORM.  If not, signals an error."
192
   (setq clauses (remove-otherwise-from-clauses clauses))
Daniel Kochmański's avatar
Daniel Kochmański committed
193
   (do ((l (reverse clauses) (cdr l))   ; Beppe
194
        (form `(etypecase-error ,key ',(accumulate-cases clauses t))))
jjgarcia's avatar
jjgarcia committed
195 196 197 198 199 200 201
       ((endp l) `(let ((,key ,keyform)) ,form))
       (setq form `(if (typep ,key ',(caar l))
                       (progn ,@(cdar l))
                       ,form))
       )
   )

202 203
(defun ctypecase-error (keyplace value types)
  (restart-case (error 'CASE-FAILURE
Daniel Kochmański's avatar
Daniel Kochmański committed
204 205 206 207
                       :name 'CTYPECASE
                       :datum value
                       :expected-type (cons 'OR types)
                       :possibilities types)
208 209
    (store-value (value)
      :REPORT (lambda (stream)
Daniel Kochmański's avatar
Daniel Kochmański committed
210
                (format stream "Supply a new value of ~S." keyplace))
211 212 213
      :INTERACTIVE read-evaluated-form
      (return-from ctypecase-error value))))

jjgarcia's avatar
jjgarcia committed
214
(defmacro ctypecase (keyplace &rest clauses &aux (key (gensym)))
215 216 217 218 219 220
  "Syntax: (ctypecase place {(type {form}*)}*)
Searches a TYPE to which the value of PLACE belongs.  If found, then evaluates
FORMs that follow the TYPE and returns all values of the last FORM.  If no
such TYPE is found, signals a continuable error.  Before continuing, receives
a new value of PLACE from the user and searches an appropriate TYPE again.
Repeats this process until the value of PLACE becomes of one of the TYPEs."
221 222 223 224
  (setq clauses (remove-otherwise-from-clauses clauses))
  `(loop
    (let ((,key ,keyplace))
      ,@(mapcar #'(lambda (l)
Daniel Kochmański's avatar
Daniel Kochmański committed
225 226 227
                    `(when (typep ,key ',(car l))
                      (return (progn ,@(cdr l)))))
                clauses)
228
      (setf ,keyplace (ctypecase-error ',keyplace ,key
Daniel Kochmański's avatar
Daniel Kochmański committed
229
                                       ',(accumulate-cases clauses t))))))