/[gcl]/gcl/lsp/gcl_assert.lsp
ViewVC logotype

Diff of /gcl/lsp/gcl_assert.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by camm, Sun Sep 14 02:30:35 2003 UTC revision 1.2 by camm, Sun Sep 14 02:43:04 2003 UTC
# Line 0  Line 1 
1    ;; Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
2    
3    ;; This file is part of GNU Common Lisp, herein referred to as GCL
4    ;;
5    ;; GCL is free software; you can redistribute it and/or modify it under
6    ;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
7    ;; the Free Software Foundation; either version 2, or (at your option)
8    ;; any later version.
9    ;;
10    ;; GCL is distributed in the hope that it will be useful, but WITHOUT
11    ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12    ;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public
13    ;; License for more details.
14    ;;
15    ;; You should have received a copy of the GNU Library General Public License
16    ;; along with GCL; see the file COPYING.  If not, write to the Free Software
17    ;; Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
18    
19    
20    ;;;;    assert.lsp
21    
22    
23    (in-package 'lisp)
24    
25    
26    (export '(check-type assert
27              ecase ccase typecase etypecase ctypecase))
28    
29    
30    (in-package 'system)
31    
32    
33    (proclaim '(optimize (safety 2) (space 3)))
34    
35    
36    (defmacro check-type (place typespec &optional (string nil s))
37      `(do ((*print-level* 4)
38            (*print-length* 4))
39           ((typep ,place ',typespec) nil)
40           (cerror ""
41                   "The value of ~:@(~S~), ~:@(~S~), is not ~A."
42                   ',place ,place
43                   ,(if s string `',typespec))
44           ,(ask-for-form place)
45           (format *error-output* "Now continuing ...~%")))
46    
47    
48    (defmacro assert (test-form &optional places string &rest args)
49      `(do ((*print-level* 4)
50            (*print-length* 4))
51           (,test-form nil)
52           ,(if string
53                `(cerror "" ,string ,@args)
54                `(cerror "" "The assertion ~:@(~S~) is failed." ',test-form))
55           ,@(mapcar #'ask-for-form places)
56           (format *error-output* "Now continuing ...~%")))
57    
58    
59    (defun ask-for-form (place)
60      `(progn (format  *error-output*
61                       "Please input the new value for the place ~:@(~S~): "
62                       ',place)
63              (finish-output *error-output*)
64              (setf ,place (read))))
65    
66    
67    (defmacro ecase (keyform &rest clauses &aux (key (gensym)))
68       (do ((l (reverse clauses) (cdr l))
69            (form `(let ((*print-level* 4)
70                         (*print-length* 4))
71                     (error
72                      "The value of ~:@(~S~), ~:@(~S~), is ~
73                      ~#[nonsense~;not ~:@(~S~)~;neither ~:@(~S~) nor ~:@(~S~)~
74                      ~:;not ~@{~#[~;or ~]~:@(~S~)~^, ~}~]."
75                      ',keyform
76                      ,key
77                      ,@(mapcan #'(lambda (x)
78                                    (if (listp (car x))
79                                        (mapcar #'(lambda (y) `',y) (car x))
80                                        `(',(car x))))
81                                clauses)))))
82           ((endp l) `(let ((,key ,keyform)) ,form))
83           (when (caar l)
84                 (setq form `(if ,(if (listp (caar l))
85                                      `(member ,key ',(caar l))
86                                      `(eql ,key ',(caar l)))
87                                 (progn ,@(cdar l))
88                                 ,form))))
89    )
90    
91    (defmacro ccase (keyplace &rest clauses &aux (key (gensym)))
92       `(loop (let ((,key ,keyplace))
93                   ,@(mapcar #'(lambda (l)
94                                      `(when ,(if (listp (car l))
95                                                  `(member ,key ',(car l))
96                                                  `(eql ,key ',(car l)))
97                                             (return (progn ,@(cdr l)))))
98                             clauses)
99                   (let ((*print-level* 4)
100                         (*print-length* 4))
101                        (cerror ""
102                                "The value of ~:@(~S~), ~:@(~S~), is ~
103                                 ~#[nonsense~;not ~:@(~S~)~;neither ~
104                                 ~:@(~S~) nor ~:@(~S~)~
105                                 ~:;not ~@{~#[~;or ~]~:@(~S~)~^, ~}~]."
106                                 ',keyplace
107                                 ,key
108                                 ,@(mapcan
109                                    #'(lambda (x)
110                                             (if (listp (car x))
111                                                 (mapcar #'(lambda (y) `',y)
112                                                         (car x))
113                                                 `(',(car x))))
114                                    clauses))
115                        ,(ask-for-form keyplace)
116                        (format *error-output* "Now continuing ...~%"))))
117       )
118    
119    (defmacro typecase (keyform &rest clauses)
120      (do ((l (reverse clauses) (cdr l))
121           (form nil) (key (gensym)))
122          ((endp l) `(let ((,key ,keyform)) ,form))
123          (if (or (eq (caar l) 't) (eq (caar l) 'otherwise))
124              (setq form `(progn ,@(cdar l)))
125              (setq form
126                    `(if (typep ,key (quote ,(caar l)))
127                         (progn ,@(cdar l))
128                         ,form))))
129      )
130    
131    (defmacro etypecase (keyform &rest clauses &aux (key (gensym)))
132       (do ((l (reverse clauses) (cdr l))
133            (form `(error (typecase-error-string
134                           ',keyform ,key
135                           ',(mapcar #'(lambda (l) (car l)) clauses)))))
136           ((endp l) `(let ((,key ,keyform)) ,form))
137           (setq form `(if (typep ,key ',(caar l))
138                           (progn ,@(cdar l))
139                           ,form))
140           )
141       )
142    
143    (defmacro ctypecase (keyplace &rest clauses &aux (key (gensym)))
144      `(loop (let ((,key ,keyplace))
145                  ,@(mapcar #'(lambda (l)
146                                     `(when (typep ,key ',(car l))
147                                            (return (progn ,@(cdr l)))))
148                            clauses)
149                  (cerror ""
150                          (typecase-error-string
151                           ',keyplace ,key
152                           ',(mapcar #'(lambda (l) (car l)) clauses))))
153             ,(ask-for-form keyplace)
154             (format *error-output* "Now continuing ...~%")))
155      )
156    
157    (defun typecase-error-string
158           (keyform keyvalue negs
159                    &aux (negs1 nil) (poss nil) (poss1 nil))
160       (do ()
161           ((endp negs))
162           (if (symbolp (car negs))
163               (progn (push (list (car negs)) negs1) (pop negs))
164               (case (caar negs)
165                     (or (setq negs (append (cdar negs) (cdr negs))))
166                     (member (mapc #'(lambda (x) (push `(member ,x) negs1))
167                                   (cdar negs))
168                             (pop negs))
169                     (not (push (cadar negs) poss) (pop negs))
170                     (otherwise (push (car negs) negs1) (pop negs)))))
171       (do ()
172           ((endp poss))
173           (cond ((symbolp (car poss)) (push (list (car poss)) poss1) (pop poss))
174                 ((eq (caar poss) 'and)
175                  (setq poss (append (cdar poss) (cdr poss))))
176                 (t (push (car poss) poss1) (pop poss))))
177       (format
178        nil
179        "The value of ~:@(~S~), ~:@(~S~), is ~?~?."
180        keyform
181        keyvalue
182        "~#[~;~;~?~;~;~? and ~?~:;~%~@{~#[~;~;and ~]~?~^, ~}~]"
183        (mapcan 'typecase-error-strings poss1)
184        "~:[~[something~;~:;~%~]~;~[~:;, but~%~]~]~
185         ~#[~;~;not ~?~;~;neither ~? nor ~?~:;not ~@{~#[~;~;or ~]~?~^, ~}~]"
186        (cons poss1 (cons (length negs1)
187                          (mapcan 'typecase-error-strings (reverse negs1))))
188        )
189       )
190    
191    (defun typecase-error-strings (type)
192     (cond ((eq (car type) 'member)
193            (case (length (cdr type))
194                  (0 `("one of none" nil))
195                  (1 `("~:@(~S~)" (,(cadr type))))
196                  (2 `("either ~:@(~S~) or ~:@(~S~)" ,(cdr type)))
197                  (t `("one of ~:@(~S~)" (,(cdr type))))))
198           ((eq (car type) 'satisfies)
199            `("an object satisfying ~:@(~S~)" ,(cdr type)))
200           ((or (endp (cdr type)) (null (remove '* (cdr type))))
201            (let ((x (assoc (car type)
202                            '((t "anything")
203                              (nil "none")
204                              (null "nil")
205                              (common "an object of a standard data type")))))
206                 (if x
207                     `(,(cadr x) nil)
208                     `("~:[a~;an~] ~(~A~)" (,(boin-p (car type)) ,(car type))))))
209           (t `("~:[a~;an~] ~:@(~S~)" (,(boin-p (car type)) ,type))))
210     )
211    
212    (defun boin-p (symbol)
213           (member (elt (symbol-name symbol) 0)
214                   '(#\A #\I #\U #\E #\O #\a #\i #\u #\e #\o))
215    )
216    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26