<html lang='en'>
<head>
<meta content='text/html; charset=utf-8' http-equiv='Content-Type'>
<title>
GitLab
</title>
</meta>
</head>
<style>
img {
max-width: 100%;
height: auto;
}
p.details {
font-style:italic;
color:#777
}
.footer p {
font-size:small;
color:#777
}
pre.commit-message {
white-space: pre-wrap;
}
.file-stats a {
text-decoration: none;
}
.file-stats .new-file {
color: #090;
}
.file-stats .deleted-file {
color: #B00;
}
</style>
<body>
<div class='content'>
<h3>Raymond Toy pushed to branch master at <a href="https://gitlab.common-lisp.net/cmucl/cmucl">cmucl / cmucl</a></h3>
<h4>
Commits:
</h4>
<ul>
<li>
<strong><a href="https://gitlab.common-lisp.net/cmucl/cmucl/commit/78c91b67208bc2e80428f9d3f2191d66bc2afe5a">78c91b67</a></strong>
<div>
<span>by Raymond Toy</span>
<i>at 2015-06-24T16:45:27Z</i>
</div>
<pre class='commit-message'>Fix #6, removing unused errorp argument for case-body
This requires using boot-2015-06-1 to make the change.
Regenerated cmucl.pot too.</pre>
</li>
</ul>
<h4>3 changed files:</h4>
<ul>
<li class='file-stats'>
<a href='#diff-0'>
<span class='new-file'>
+
src/bootfiles/20f/boot-2015-06-1.lisp
</span>
</a>
</li>
<li class='file-stats'>
<a href='#diff-1'>
src/code/macros.lisp
</a>
</li>
<li class='file-stats'>
<a href='#diff-2'>
src/i18n/locale/cmucl.pot
</a>
</li>
</ul>
<h4>Changes:</h4>
<li id='diff-0'>
<a href='https://gitlab.common-lisp.net/cmucl/cmucl/commit/78c91b67208bc2e80428f9d3f2191d66bc2afe5a#diff-0'>
<strong>
src/bootfiles/20f/boot-2015-06-1.lisp
</strong>
</a>
<hr>
<pre class="highlight"><code><span style="color: #000000;background-color: #ffdddd">--- /dev/null
</span><span style="color: #000000;background-color: #ddffdd">+++ b/src/bootfiles/20f/boot-2015-06-1.lisp
</span><span style="color: #aaaaaa">@@ -0,0 +1,156 @@
</span><span style="color: #000000;background-color: #ddffdd">+;; Fix #6.
+;;
+;; Use this to bootstrap the change using the snapshot-2015-06 binary.
+(in-package "KERNEL")
+(export '(invalid-case))
+(in-package "CONDITIONS")
+
+(ext:without-package-locks
+(define-condition invalid-case (reference-condition error)
+ ((name :initarg :name
+ :reader invalid-case-name)
+ (format :initarg :format-control
+ :reader invalid-case-format)
+ (args :initarg :format-arguments
+ :reader invalid-case-format-args))
+ (:report (lambda (condition stream)
+ (format stream "~A: " (invalid-case-name condition))
+ (apply #'format stream (invalid-case-format condition) (invalid-case-format-args condition))
+ (print-references (reference-condition-references condition) stream))))
+)
+
+(in-package "LISP")
+
+(ext:without-package-locks
+(defun case-body (name keyform cases multi-p test proceedp &optional allow-otherwise)
+ (let ((keyform-value (gensym))
+ (clauses ())
+ (keys ()))
+ (do* ((case-list cases (cdr case-list))
+ (case (first case-list) (first case-list)))
+ ((null case-list))
+ (cond ((atom case)
+ (error (intl:gettext "~S -- Bad clause in ~S.") case name))
+ ((and (not allow-otherwise)
+ (memq (car case) '(t otherwise)))
+ (cond ((null (cdr case-list))
+ ;; The CLHS says OTHERWISE clause is an OTHERWISE clause
+ ;; only if it's the last case. Otherwise, it's just a
+ ;; normal clause.
+ (push `(t nil ,@(rest case)) clauses))
+ ((and (eq name 'case))
+ (let ((key (first case)))
+ (error 'kernel:invalid-case
+ :name name
+ :format-control (intl:gettext
+ "~<~A is a key designator only in the final otherwise-clause. ~
+ Use (~A) to use it as a normal-clause or move the clause to the ~
+ correct position.~:@>")
+ :format-arguments (list (list key key))
+ :references (list '(:ansi-cl :section (5 3))
+ (list :ansi-cl :macro name)))))
+ ((eq (first case) t)
+ ;; The key T is normal clause, because it's not
+ ;; the last clause.
+ (push (first case) keys)
+ (push `((,test ,keyform-value
+ ',(first case)) nil ,@(rest case)) clauses))))
+ ((and multi-p (listp (first case)))
+ (setf keys (append (first case) keys))
+ (push `((or ,@(mapcar #'(lambda (key)
+ `(,test ,keyform-value ',key))
+ (first case)))
+ nil ,@(rest case))
+ clauses))
+ (t
+ (when (and allow-otherwise
+ (memq (car case) '(t otherwise)))
+ (warn 'kernel:simple-style-warning
+ :format-control (intl:gettext "Bad style to use ~S in ~S")
+ :format-arguments (list (car case) name)))
+ (push (first case) keys)
+ (push `((,test ,keyform-value
+ ',(first case)) nil ,@(rest case)) clauses))))
+ (case-body-aux name keyform keyform-value clauses keys proceedp
+ allow-otherwise
+ `(,(if multi-p 'member 'or) ,@keys))))
+
+;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled all the
+;;; cases. Note: it is not necessary that the resulting code signal
+;;; case-failure conditions, but that's what KMP's prototype code did. We call
+;;; CASE-BODY-ERROR, because of how closures are compiled. RESTART-CASE has
+;;; forms with closures that the compiler causes to be generated at the top of
+;;; any function using the case macros, regardless of whether they are needed.
+;;;
+(defun case-body-aux (name keyform keyform-value clauses keys
+ proceedp allow-otherwise expected-type)
+ (if proceedp
+ (let ((block (gensym))
+ (again (gensym)))
+ `(let ((,keyform-value ,keyform))
+ (block ,block
+ (tagbody
+ ,again
+ (return-from
+ ,block
+ (cond ,@(nreverse clauses)
+ (t
+ (setf ,keyform-value
+ (setf ,keyform
+ (case-body-error
+ ',name ',keyform ,keyform-value
+ ',expected-type ',keys)))
+ (go ,again))))))))
+ `(let ((,keyform-value ,keyform))
+ ,keyform-value ; prevent warnings when key not used eg (case key (t))
+ (cond
+ ,@(nreverse clauses)
+ ,@(if allow-otherwise
+ `((t (error 'conditions::case-failure
+ :name ',name
+ :datum ,keyform-value
+ :expected-type ',expected-type
+ :possibilities ',keys))))))))
+
+(defmacro case (keyform &body cases)
+ "CASE Keyform {({(Key*) | Key} Form*)}*
+ Evaluates the Forms in the first clause with a Key EQL to the value
+ of Keyform. If a singleton key is T or Otherwise then the clause is
+ a default clause."
+ (case-body 'case keyform cases t 'eql nil))
+
+(defmacro ccase (keyform &body cases)
+ "CCASE Keyform {({(Key*) | Key} Form*)}*
+ Evaluates the Forms in the first clause with a Key EQL to the value of
+ Keyform. If none of the keys matches then a correctable error is
+ signalled."
+ (case-body 'ccase keyform cases t 'eql t t))
+
+(defmacro ecase (keyform &body cases)
+ "ECASE Keyform {({(Key*) | Key} Form*)}*
+ Evaluates the Forms in the first clause with a Key EQL to the value of
+ Keyform. If none of the keys matches then an error is signalled."
+ (case-body 'ecase keyform cases t 'eql nil t))
+
+(defmacro typecase (keyform &body cases)
+ "TYPECASE Keyform {(Type Form*)}*
+ Evaluates the Forms in the first clause for which TYPEP of Keyform
+ and Type is true. If a singleton key is T or Otherwise then the
+ clause is a default clause."
+ (case-body 'typecase keyform cases nil 'typep nil))
+
+(defmacro ctypecase (keyform &body cases)
+ "CTYPECASE Keyform {(Type Form*)}*
+ Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
+ is true. If no form is satisfied then a correctable error is signalled."
+ (case-body 'ctypecase keyform cases nil 'typep t t))
+
+(defmacro etypecase (keyform &body cases)
+ "ETYPECASE Keyform {(Type Form*)}*
+ Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
+ is true. If no form is satisfied then an error is signalled."
+ (case-body 'etypecase keyform cases nil 'typep nil t))
+
+
+)
+
</span></code></pre>
<br>
</li>
<li id='diff-1'>
<a href='https://gitlab.common-lisp.net/cmucl/cmucl/commit/78c91b67208bc2e80428f9d3f2191d66bc2afe5a#diff-1'>
<strong>
src/code/macros.lisp
</strong>
</a>
<hr>
<pre class="highlight"><code><span style="color: #000000;background-color: #ffdddd">--- a/src/code/macros.lisp
</span><span style="color: #000000;background-color: #ddffdd">+++ b/src/code/macros.lisp
</span><span style="color: #aaaaaa">@@ -1347,7 +1347,7 @@
</span> ;;; generate an ERROR form. (This is for CCASE and ECASE which allow
;;; using T and OTHERWISE as regular keys.)
;;;
-(defun case-body (name keyform cases multi-p test errorp proceedp &optional allow-otherwise)
<span style="color: #000000;background-color: #ddffdd">+(defun case-body (name keyform cases multi-p test proceedp &optional allow-otherwise)
</span> (let ((keyform-value (gensym))
(clauses ())
(keys ()))
<span style="color: #aaaaaa">@@ -1362,9 +1362,7 @@
</span> ;; The CLHS says OTHERWISE clause is an OTHERWISE clause
;; only if it's the last case. Otherwise, it's just a
;; normal clause.
- (if errorp
- (error (intl:gettext "No default clause allowed in ~S: ~S") name case)
- (push `(t nil ,@(rest case)) clauses)))
<span style="color: #000000;background-color: #ddffdd">+ (push `(t nil ,@(rest case)) clauses))
</span> ((and (eq name 'case))
(let ((key (first case)))
(error 'kernel:invalid-case
<span style="color: #aaaaaa">@@ -1398,7 +1396,7 @@
</span> (push (first case) keys)
(push `((,test ,keyform-value
',(first case)) nil ,@(rest case)) clauses))))
<span style="color: #000000;background-color: #ffdddd">- (case-body-aux name keyform keyform-value clauses keys errorp proceedp
</span><span style="color: #000000;background-color: #ddffdd">+ (case-body-aux name keyform keyform-value clauses keys proceedp
</span> allow-otherwise
`(,(if multi-p 'member 'or) ,@keys))))
<span style="color: #aaaaaa">@@ -1410,7 +1408,7 @@
</span> ;;; any function using the case macros, regardless of whether they are needed.
;;;
(defun case-body-aux (name keyform keyform-value clauses keys
- errorp proceedp allow-otherwise expected-type)
<span style="color: #000000;background-color: #ddffdd">+ proceedp allow-otherwise expected-type)
</span> (if proceedp
(let ((block (gensym))
(again (gensym)))
<span style="color: #aaaaaa">@@ -1432,7 +1430,7 @@
</span> ,keyform-value ; prevent warnings when key not used eg (case key (t))
(cond
,@(nreverse clauses)
- ,@(if (or errorp allow-otherwise)
<span style="color: #000000;background-color: #ddffdd">+ ,@(if allow-otherwise
</span> `((t (error 'conditions::case-failure
:name ',name
:datum ,keyform-value
<span style="color: #aaaaaa">@@ -1460,39 +1458,39 @@
</span> Evaluates the Forms in the first clause with a Key EQL to the value
of Keyform. If a singleton key is T or Otherwise then the clause is
a default clause."
<span style="color: #000000;background-color: #ffdddd">- (case-body 'case keyform cases t 'eql nil nil))
</span><span style="color: #000000;background-color: #ddffdd">+ (case-body 'case keyform cases t 'eql nil))
</span>
(defmacro ccase (keyform &body cases)
"CCASE Keyform {({(Key*) | Key} Form*)}*
Evaluates the Forms in the first clause with a Key EQL to the value of
Keyform. If none of the keys matches then a correctable error is
signalled."
<span style="color: #000000;background-color: #ffdddd">- (case-body 'ccase keyform cases t 'eql nil t t))
</span><span style="color: #000000;background-color: #ddffdd">+ (case-body 'ccase keyform cases t 'eql t t))
</span>
(defmacro ecase (keyform &body cases)
"ECASE Keyform {({(Key*) | Key} Form*)}*
Evaluates the Forms in the first clause with a Key EQL to the value of
Keyform. If none of the keys matches then an error is signalled."
<span style="color: #000000;background-color: #ffdddd">- (case-body 'ecase keyform cases t 'eql nil nil t))
</span><span style="color: #000000;background-color: #ddffdd">+ (case-body 'ecase keyform cases t 'eql nil t))
</span>
(defmacro typecase (keyform &body cases)
"TYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform
and Type is true. If a singleton key is T or Otherwise then the
clause is a default clause."
<span style="color: #000000;background-color: #ffdddd">- (case-body 'typecase keyform cases nil 'typep nil nil))
</span><span style="color: #000000;background-color: #ddffdd">+ (case-body 'typecase keyform cases nil 'typep nil))
</span>
(defmacro ctypecase (keyform &body cases)
"CTYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
is true. If no form is satisfied then a correctable error is signalled."
<span style="color: #000000;background-color: #ffdddd">- (case-body 'ctypecase keyform cases nil 'typep nil t t))
</span><span style="color: #000000;background-color: #ddffdd">+ (case-body 'ctypecase keyform cases nil 'typep t t))
</span>
(defmacro etypecase (keyform &body cases)
"ETYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
is true. If no form is satisfied then an error is signalled."
<span style="color: #000000;background-color: #ffdddd">- (case-body 'etypecase keyform cases nil 'typep nil nil t))
</span><span style="color: #000000;background-color: #ddffdd">+ (case-body 'etypecase keyform cases nil 'typep nil t))
</span>
;;;; ASSERT and CHECK-TYPE.
</code></pre>
<br>
</li>
<li id='diff-2'>
<a href='https://gitlab.common-lisp.net/cmucl/cmucl/commit/78c91b67208bc2e80428f9d3f2191d66bc2afe5a#diff-2'>
<strong>
src/i18n/locale/cmucl.pot
</strong>
</a>
<hr>
<pre class="highlight"><code><span style="color: #000000;background-color: #ffdddd">--- a/src/i18n/locale/cmucl.pot
</span><span style="color: #000000;background-color: #ddffdd">+++ b/src/i18n/locale/cmucl.pot
</span><span style="color: #aaaaaa">@@ -14689,10 +14689,6 @@ msgid "~S -- Bad clause in ~S."
</span> msgstr ""
#: src/code/macros.lisp
-msgid "No default clause allowed in ~S: ~S"
-msgstr ""
-
-#: src/code/macros.lisp
msgid ""
"~<~A is a key designator only in the final otherwise-clause. ~\n"
" Use (~A) to use it as a "
</code></pre>
<br>
</li>
</div>
<div class='footer' style='margin-top: 10px;'>
<p>
—
<br>
<a href="https://gitlab.common-lisp.net/cmucl/cmucl/commit/78c91b67208bc2e80428f9d3f2191d66bc2afe5a">View it on GitLab</a>
<script type="application/ld+json">{"@context":"http://schema.org","@type":"EmailMessage","action":{"@type":"ViewAction","name":"View Commit","url":"https://gitlab.common-lisp.net/cmucl/cmucl/commit/78c91b67208bc2e80428f9d3f2191d66bc2afe5a"}}</script>
</p>
</div>
</body>
</html>