source: trunk/j/src/org/armedbear/lisp/case.lisp @ 8427

Last change on this file since 8427 was 8427, checked in by piso, 17 years ago

EXT:STYLE-WARN is now implemented in restart.lisp.

File size: 6.7 KB
Line 
1;;; case.lisp
2;;;
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: case.lisp,v 1.3 2005-01-31 17:22:22 piso Exp $
5;;;
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
10;;;
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
19
20;;; Adapted from SBCL.
21
22(in-package "SYSTEM")
23
24;;; Is X a (possibly-improper) list of at least N elements?
25(defun list-of-length-at-least-p (x n)
26  (or (zerop n) ; since anything can be considered an improper list of length 0
27      (and (consp x)
28     (list-of-length-at-least-p (cdr x) (1- n)))))
29
30(defun case-body-error (name keyform keyform-value expected-type keys)
31  (restart-case
32   #+sbcl
33   (error 'case-failure
34          :name name
35          :datum keyform-value
36          :expected-type expected-type
37          :possibilities keys)
38   #+armedbear
39   (error 'type-error
40          :datum keyform-value
41          :expected-type expected-type)
42   (store-value (value)
43                :report (lambda (stream)
44                          (format stream "Supply a new value for ~S." keyform))
45                :interactive read-evaluated-form
46                value)))
47
48;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled
49;;; all the cases. Note: it is not necessary that the resulting code
50;;; signal case-failure conditions, but that's what KMP's prototype
51;;; code did. We call CASE-BODY-ERROR, because of how closures are
52;;; compiled. RESTART-CASE has forms with closures that the compiler
53;;; causes to be generated at the top of any function using the case
54;;; macros, regardless of whether they are needed.
55;;;
56;;; The CASE-BODY-ERROR function is defined later, when the
57;;; RESTART-CASE macro has been defined.
58(defun case-body-aux (name keyform keyform-value clauses keys
59                           errorp proceedp expected-type)
60  (if proceedp
61      (let ((block (gensym))
62      (again (gensym)))
63  `(let ((,keyform-value ,keyform))
64     (block ,block
65       (tagbody
66        ,again
67        (return-from
68         ,block
69         (cond ,@(nreverse clauses)
70         (t
71          (setf ,keyform-value
72          (setf ,keyform
73          (case-body-error
74           ',name ',keyform ,keyform-value
75           ',expected-type ',keys)))
76          (go ,again))))))))
77      `(let ((,keyform-value ,keyform))
78   (cond
79    ,@(nreverse clauses)
80    ,@(if errorp
81;;    `((t (error 'case-failure
82;;          :name ',name
83;;          :datum ,keyform-value
84;;          :expected-type ',expected-type
85;;          :possibilities ',keys))))))))
86    `((t (error 'type-error
87          :datum ,keyform-value
88          :expected-type ',expected-type))))))))
89
90;;; CASE-BODY returns code for all the standard "case" macros. NAME is
91;;; the macro name, and KEYFORM is the thing to case on. MULTI-P
92;;; indicates whether a branch may fire off a list of keys; otherwise,
93;;; a key that is a list is interpreted in some way as a single key.
94;;; When MULTI-P, TEST is applied to the value of KEYFORM and each key
95;;; for a given branch; otherwise, TEST is applied to the value of
96;;; KEYFORM and the entire first element, instead of each part, of the
97;;; case branch. When ERRORP, no T or OTHERWISE branch is permitted,
98;;; and an ERROR form is generated. When PROCEEDP, it is an error to
99;;; omit ERRORP, and the ERROR form generated is executed within a
100;;; RESTART-CASE allowing KEYFORM to be set and retested.
101(defun case-body (name keyform cases multi-p test errorp proceedp needcasesp)
102  (unless (or cases (not needcasesp))
103    (warn "no clauses in ~S" name))
104  (let ((keyform-value (gensym))
105  (clauses ())
106  (keys ()))
107    (do* ((cases cases (cdr cases))
108    (case (car cases) (car cases)))
109   ((null cases) nil)
110      (unless (list-of-length-at-least-p case 1)
111  (error "~S -- bad clause in ~S" case name))
112      (destructuring-bind (keyoid &rest forms) case
113  (cond ((and (memq keyoid '(t otherwise))
114        (null (cdr cases)))
115         (if errorp
116       (progn
117         (style-warn "~@<Treating bare ~A in ~A as introducing a ~
118                                  normal-clause, not an otherwise-clause~@:>"
119         keyoid name)
120         (push keyoid keys)
121         (push `((,test ,keyform-value ',keyoid) nil ,@forms)
122         clauses))
123       (push `(t nil ,@forms) clauses)))
124        ((and multi-p (listp keyoid))
125         (setf keys (append keyoid keys))
126         (push `((or ,@(mapcar (lambda (key)
127               `(,test ,keyform-value ',key))
128             keyoid))
129           nil
130           ,@forms)
131         clauses))
132        (t
133         (push keyoid keys)
134         (push `((,test ,keyform-value ',keyoid)
135           nil
136           ,@forms)
137         clauses)))))
138    (case-body-aux name keyform keyform-value clauses keys errorp proceedp
139       `(,(if multi-p 'member 'or) ,@keys))))
140
141(defmacro case (keyform &body cases)
142  "CASE Keyform {({(Key*) | Key} Form*)}*
143  Evaluates the Forms in the first clause with a Key EQL to the value of
144  Keyform. If a singleton key is T then the clause is a default clause."
145  (case-body 'case keyform cases t 'eql nil nil nil))
146
147(defmacro ccase (keyform &body cases)
148  "CCASE Keyform {({(Key*) | Key} Form*)}*
149  Evaluates the Forms in the first clause with a Key EQL to the value of
150  Keyform. If none of the keys matches then a correctable error is
151  signalled."
152  (case-body 'ccase keyform cases t 'eql t t t))
153
154(defmacro ecase (keyform &body cases)
155  "ECASE Keyform {({(Key*) | Key} Form*)}*
156  Evaluates the Forms in the first clause with a Key EQL to the value of
157  Keyform. If none of the keys matches then an error is signalled."
158  (case-body 'ecase keyform cases t 'eql t nil t))
159
160(defmacro typecase (keyform &body cases)
161  "TYPECASE Keyform {(Type Form*)}*
162  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
163  is true."
164  (case-body 'typecase keyform cases nil 'typep nil nil nil))
165
166(defmacro ctypecase (keyform &body cases)
167  "CTYPECASE Keyform {(Type Form*)}*
168  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
169  is true. If no form is satisfied then a correctable error is signalled."
170  (case-body 'ctypecase keyform cases nil 'typep t t t))
171
172(defmacro etypecase (keyform &body cases)
173  "ETYPECASE Keyform {(Type Form*)}*
174  Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
175  is true. If no form is satisfied then an error is signalled."
176  (case-body 'etypecase keyform cases nil 'typep t nil t))
Note: See TracBrowser for help on using the repository browser.