Re: [Gcl-devel] Compiler does not give error if T clause in case construct is not last one

[Camm Maguire]

Greetings!

cvs -z9 -q diff -u -r Version_2_6_8pre:2012-03-20 -r Version_2_6_8pre:2012-03-24


Index: cmpnew/gcl_cmpif.lsp
===================================================================
RCS file: /sources/gcl/gcl/cmpnew/gcl_cmpif.lsp,v
retrieving revision 1.1.2.1.14.1
retrieving revision 1.1.2.1.14.2
diff -u -u -r1.1.2.1.14.1 -r1.1.2.1.14.2
--- cmpnew/gcl_cmpif.lsp        21 Jun 2006 20:03:05 -0000      1.1.2.1.14.1
+++ cmpnew/gcl_cmpif.lsp        23 Mar 2012 14:13:07 -0000      1.1.2.1.14.2
@@ -330,32 +330,55 @@
   (when (endp args) (too-few-args 'case 1 0))
   (let* ((info (make-info))
          (key-form (c1expr* (car args) info))
-         (clauses nil))
+         clauses)
     (cond ((subtypep (info-type (second key-form)) 'fixnum)
-          (return-from c1case  (c1expr (convert-case-to-switch
-                                args default )))))
-    (dolist (clause (cdr args))
-      (cmpck (endp clause) "The CASE clause ~S is illegal." clause)
-      (case (car clause)
-            ((nil))
-            ((t otherwise)
-             (when default
-                   (cmperr (if (eq default 't)
-                               "ECASE had an OTHERWISE clause."
-                               "CASE had more than one OTHERWISE clauses.")))
-             (setq default (c1progn (cdr clause)))
-             (add-info info (cadr default)))
-            (t (let* ((keylist
-                       (cond ((consp (car clause))
-                              (mapcar #'(lambda (key) (if (symbolp key) key
-                                                          (add-object key)))
-                                      (car clause)))
-                             ((symbolp (car clause)) (list (car clause)))
-                             (t (list (add-object (car clause))))))
-                      (body (c1progn (cdr clause))))
-                 (add-info info (cadr body))
-                 (push (cons keylist body) clauses)))))
-    (list 'case info key-form (reverse clauses) (or default (c1nil)))))
+          (return-from c1case  (c1expr (convert-case-to-switch args default 
)))))
+    (do ((c (cdr args) (cdr c))) ((not c))
+       (let* ((clause (car c)))
+         (cmpck (endp clause) "The CASE clause ~S is illegal." clause)
+         (let* ((k (pop clause))(dfp (unless default (member k '(t 
otherwise))))
+                (keylist
+                 (cond ((listp k)
+                        (mapcar (lambda (key) (if (symbolp key) key 
(add-object key))) k))
+                       ((symbolp k) 
+                        (when dfp (when (cdr c) (cmperr "default case found in 
bad place")))
+                        (list k))
+                       ((list (add-object k)))))
+                (body (c1progn clause)))
+           (add-info info (cadr body))
+           (if dfp (setq default body) (push (cons keylist body) clauses)))))
+    (list 'case info key-form (nreverse clauses) (or default (c1nil)))))
+
+;; (defun c1case (args &optional (default nil))
+;;   (when (endp args) (too-few-args 'case 1 0))
+;;   (let* ((info (make-info))
+;;          (key-form (c1expr* (car args) info))
+;;          (clauses nil))
+;;     (cond ((subtypep (info-type (second key-form)) 'fixnum)
+;;        (return-from c1case  (c1expr (convert-case-to-switch
+;;                              args default )))))
+;;     (dolist (clause (cdr args))
+;;       (cmpck (endp clause) "The CASE clause ~S is illegal." clause)
+;;       (case (car clause)
+;;             ((nil))
+;;             ((t otherwise)
+;;              (when default
+;;                    (cmperr (if (eq default 't)
+;;                                "ECASE had an OTHERWISE clause."
+;;                                "CASE had more than one OTHERWISE 
clauses.")))
+;;              (setq default (c1progn (cdr clause)))
+;;              (add-info info (cadr default)))
+;;             (t (let* ((keylist
+;;                        (cond ((consp (car clause))
+;;                               (mapcar #'(lambda (key) (if (symbolp key) key
+;;                                                           (add-object key)))
+;;                                       (car clause)))
+;;                              ((symbolp (car clause)) (list (car clause)))
+;;                              (t (list (add-object (car clause))))))
+;;                       (body (c1progn (cdr clause))))
+;;                  (add-info info (cadr body))
+;;                  (push (cons keylist body) clauses)))))
+;;     (list 'case info key-form (reverse clauses) (or default (c1nil)))))
 
 (defun c2case (key-form clauses default
                &aux (cvar (next-cvar)) (*vs* *vs*) (*inline-blocks* 0))
Index: debian/changelog
===================================================================
RCS file: /sources/gcl/gcl/debian/changelog,v
retrieving revision 
1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.154
retrieving revision 
1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.155
diff -u -u 
-r1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.154 
-r1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.155
--- debian/changelog    20 Jan 2012 19:53:52 -0000      
1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.154
+++ debian/changelog    23 Mar 2012 14:15:55 -0000      
1.220.2.1.4.1.2.1.2.1.2.2.2.1.2.19.2.207.2.23.2.11.2.14.2.13.4.7.2.22.2.155
@@ -242,8 +242,9 @@
   * make-array;make-sequence;replace;coerce
   * restore traditional make-sequence,make-array, and coerce, and
     optimize replace, as 2.6.8 compiler is still too weak re: inlines
+  * case default error checking
 
- -- Camm Maguire <address@hidden>  Fri, 20 Jan 2012 19:53:29 +0000
+ -- Camm Maguire <address@hidden>  Fri, 23 Mar 2012 14:15:50 +0000
 
 gcl (2.6.7-7) unstable; urgency=high
 
Index: lsp/gcl_evalmacros.lsp
===================================================================
RCS file: /sources/gcl/gcl/lsp/gcl_evalmacros.lsp,v
retrieving revision 1.1.2.2.4.1.10.3
retrieving revision 1.1.2.2.4.1.10.4
diff -u -u -r1.1.2.2.4.1.10.3 -r1.1.2.2.4.1.10.4
--- lsp/gcl_evalmacros.lsp      24 Sep 2010 19:30:57 -0000      1.1.2.2.4.1.10.3
+++ lsp/gcl_evalmacros.lsp      23 Mar 2012 14:13:07 -0000      1.1.2.2.4.1.10.4
@@ -254,20 +254,33 @@
                         (go ,label))))
   )
 
-(defmacro case (keyform &rest clauses &aux (form nil) (key (gensym)))
-  (dolist (clause (reverse clauses) `(let ((,key ,keyform)) ,form))
-          (declare (object clause))
-    (cond ((or (eq (car clause) 't) (eq (car clause) 'otherwise))
-           (setq form `(progn ,@(cdr clause))))
-          ((consp (car clause))
-           (setq form `(if (member ,key ',(car clause))
-                           (progn ,@(cdr clause))
-                           ,form)))
-          ((car clause)
-           (setq form `(if (eql ,key ',(car clause))
-                           (progn ,@(cdr clause))
-                           ,form)))))
-  )
+(defmacro case (keyform &rest clauses &aux (key (load-time-value (gensym 
"CASE"))) (c (reverse clauses)))
+  (declare (optimize (safety 2)))
+  (labels ((sw (x) `(eql ,key ',x))(dfp (x) (or (eq x t) (eq x 'otherwise)))
+          (v (x) (if (when (listp x) (not (cdr x))) (car x) x))
+          (m (x c &aux (v (v x))) (if (eq v x) (cons c v) v)))
+         `(let ((,key ,keyform))
+            (declare (ignorable ,key))
+            ,(let ((df (when (dfp (caar c)) (m (cdr (pop c)) 'progn))))
+               (reduce (lambda (y c &aux (a (pop c))(v (v a)))
+                         (when (dfp a) (error "default case must be last"))
+                         `(if ,(if (when (eq a v) (listp v)) (m (mapcar #'sw 
v) 'or) (sw v)) ,(m c 'progn) ,y))
+                       c :initial-value df)))))
+
+;; (defmacro case (keyform &rest clauses &aux (form nil) (key (gensym)))
+;;   (dolist (clause (reverse clauses) `(let ((,key ,keyform)) ,form))
+;;           (declare (object clause))
+;;     (cond ((or (eq (car clause) 't) (eq (car clause) 'otherwise))
+;;            (setq form `(progn ,@(cdr clause))))
+;;           ((consp (car clause))
+;;            (setq form `(if (member ,key ',(car clause))
+;;                            (progn ,@(cdr clause))
+;;                            ,form)))
+;;           ((car clause)
+;;            (setq form `(if (eql ,key ',(car clause))
+;;                            (progn ,@(cdr clause))
+;;                            ,form)))))
+;;   )
 
 
 (defmacro return (&optional (val nil)) `(return-from nil ,val))


Take care,

Faheem Mitha <address@hidden> writes:

> On Sat, 24 Mar 2012, Camm Maguire wrote:
>
>> Greetings!
>>
>> export CVSROOT=:pserver:address@hidden:/sources/gcl
>> cvs -z9 -q co -d gcl-2.6.8pre -r Version_2_6_8pre gcl
>>
>> Take care,
>
> Thanks for the information. I think this commit must be the one.
>
> revision 1.1.2.1.14.2
> date: 2012-03-23 19:43:07 +0530;  author: camm;  state: Exp;  lines:
> +48 -25;  commitid: OhlbKUngXCha01Yv;
> case default error checking
>
> How do I get the diff? Sorry, I've never used cvs.
>
>                                   Regards, Faheem
>
>
>
>

-- 
Camm Maguire                                        address@hidden
==========================================================================
"The earth is but one country, and mankind its citizens."  --  Baha'u'llah