clisp-cvs Digest, Vol 27, Issue 44

[<cli...@li...>]

Send clisp-cvs mailing list submissions to
	cli...@li...

To subscribe or unsubscribe via the World Wide Web, visit
	https://lists.sourceforge.net/lists/listinfo/clisp-cvs
or, via email, send a message with subject or body 'help' to
	cli...@li...

You can reach the person managing the list at
	cli...@li...

When replying, please edit your Subject line so it is more specific
than "Re: Contents of clisp-cvs digest..."


CLISP CVS commits for today

Today's Topics:

   1. clisp/src compiler.lisp,1.338,1.339 ChangeLog,1.6432,1.6433
      (Sam Steingold)
   2. clisp/tests bind.tst,1.16,1.17 (Sam Steingold)
   3. clisp/src ChangeLog,1.6433,1.6434 (Sam Steingold)
   4. clisp/utils clispload.lsp,1.59,1.60 (Sam Steingold)
   5. clisp/tests ChangeLog,1.576,1.577 eval20.tst,1.17,1.18
      (Sam Steingold)
   6. clisp/src spvw.d,1.438,1.439 (Sam Steingold)
   7. clisp/src ChangeLog,1.6434,1.6435 format.lisp,1.55,1.56
      (Sam Steingold)


----------------------------------------------------------------------

Message: 1
Date: Thu, 24 Jul 2008 03:57:21 +0000
From: Sam Steingold <sd...@us...>
Subject: clisp/src compiler.lisp,1.338,1.339 ChangeLog,1.6432,1.6433
To: cli...@li...
Message-ID: <E1K...@ma...>

Update of /cvsroot/clisp/clisp/src
In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv16167/src

Modified Files:
	compiler.lisp ChangeLog 
Log Message:
(c-LABELS, c-FLET, c-MACROLET): rework
the "ANSI SPECIAL declarations" patch to fix a LABELS flaw


Index: compiler.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/src/compiler.lisp,v
retrieving revision 1.338
retrieving revision 1.339
diff -u -d -r1.338 -r1.339
--- compiler.lisp	24 Jul 2008 02:50:22 -0000	1.338
+++ compiler.lisp	24 Jul 2008 03:57:19 -0000	1.339
@@ -5356,27 +5356,27 @@
                :usedp t :for-value-usedp t :really-usedp nil
                :closurep nil ; later poss. set to T
                :stackz *stackz* :venvc *venvc* :fnode *func*))
-           (with-bindings-lite ((body body-rest) &body forms)
-             `(multiple-value-bind (,body-rest declarations) (parse-body ,body)
-                (let ((*denv* *denv*) (*venv* *venv*))
-                  (multiple-value-bind
-                        (*specials* *ignores* *ignorables* *readonlys* others)
-                      (process-declarations declarations)
-                    (push-specials) (push-*denv* others)
-                    ,@forms))))
-           (with-bindings ((body body-rest) &body forms)
-             `(multiple-value-bind (,body-rest declarations) (parse-body ,body)
+           (c-declarations (c declarations body-rest)
+             `(multiple-value-bind
+                    (*specials* *ignores* *ignorables* *readonlys* other-decls)
+                  (process-declarations ,declarations)
+                (push-specials) (push-*denv* other-decls)
+                ;; compile the remaining forms:
+                (funcall ,c `(PROGN ,@body-rest))))
+           (with-bindings ((body body-rest declarations mvb-var)
+                           mvb-form &body forms)
+             `(multiple-value-bind (,body-rest ,declarations)
+                  (parse-body ,body)
                 (let ((oldstackz *stackz*)
                       (*stackz* *stackz*)
                       (*denv* *denv*)
                       (*venvc* *venvc*)
                       (*venv* *venv*))
-                  (multiple-value-bind
-                        (*specials* *ignores* *ignorables* *readonlys* others)
-                      (process-declarations declarations)
-                    (push 0 *stackz*) (push nil *venvc*) ; for Closure-Dummyvar
-                    (push-specials) (push-*denv* others)
-                    ,@forms))))
+                  (push 0 *stackz*) (push nil *venvc*) ; for Closure-Dummyvar
+                  (let ((closuredummy-stackz *stackz*)
+                        (closuredummy-venvc *venvc*))
+                    (multiple-value-bind ,mvb-var ,mvb-form
+                      ,@forms)))))
            (get-anode (type)
              `(let* ((closurevars (checking-movable-var-list varlist anodelist))
                      (anode
@@ -5406,148 +5406,141 @@
 (defun c-FLET ()
   (test-list *form* 2)
   (test-list (second *form*) 0)
-  (multiple-value-bind (namelist fnodelist)
-      (do ((fdefsr (second *form*) (cdr fdefsr))
-           (L1 '())
-           (L2 '()))
-          ((null fdefsr) (values (nreverse L1) (nreverse L2)))
-        (let ((fdef (car fdefsr)))
-          (check-fdef-name FLET fdef)
-          (let* ((name (car fdef))
-                 (fnode (c-lambdabody
-                         (symbol-suffix (fnode-name *func*) name)
-                         (add-implicit-block name (cdr fdef)))))
-            (push name L1)
-            (push fnode L2))))
-    ;; namelist = list of names, fnodelist = list of fnodes of the functions
-    (with-bindings ((cddr *form*) body-rest)
-      (let ((closuredummy-stackz *stackz*)
-            (closuredummy-venvc *venvc*))
-        (multiple-value-bind (vfnodelist varlist anodelist *fenv*)
-            (do ((namelistr namelist (cdr namelistr))
-                 (fnodelistr fnodelist (cdr fnodelistr))
-                 (vfnodelist '())
-                 (varlist '())
-                 (anodelist '())
-                 (fenv '()))
-                ((null namelistr)
-                 (values (nreverse vfnodelist) (nreverse varlist)
-                         (nreverse anodelist)
-                         (sys::cons-*fenv* fenv)))
-              (push (car namelistr) fenv)
-              (let ((fnode (car fnodelistr)))
-                (if (zerop (fnode-keyword-offset fnode))
-                  ;; function-definition is autonomous
-                  (push (cons (list fnode) (new-const fnode)) fenv)
-                  (progn
-                    (push fnode vfnodelist)
-                    (push (c-fnode-function fnode) anodelist)
-                    (push 1 *stackz*)
-                    (let ((var (mk-var)))
-                      (push (cons (list fnode) var) fenv)
-                      (push var varlist))))))
-          (apply #'push-*venv* varlist) ; activate auxiliary variables
-          (let ((body-anode (c-form `(PROGN ,@body-rest)))) ; compile body
-            (unless *no-code*
-              (mapc #'(lambda (var fnode)
-                        (when (var-really-usedp var)
-                          (propagate-far-used fnode)))
-                    varlist vfnodelist))
-            (get-anode FLET)))))))
+  ;; namelist = list of names, fnodelist = list of fnodes of the functions
+  (with-bindings ((cddr *form*) body-rest declarations (namelist fnodelist))
+    (do ((fdefsr (second *form*) (cdr fdefsr))
+         (L1 '())               ; namelist
+         (L2 '()))              ; fnodelist
+        ((null fdefsr) (values (nreverse L1) (nreverse L2)))
+      (let ((fdef (car fdefsr)))
+        (check-fdef-name FLET fdef)
+        (let* ((name (car fdef))
+               (fnode (c-lambdabody
+                       (symbol-suffix (fnode-name *func*) name)
+                       (add-implicit-block name (cdr fdef)))))
+          (push name L1)
+          (push fnode L2))))
+    (multiple-value-bind (vfnodelist varlist anodelist *fenv*)
+        (do ((namelistr namelist (cdr namelistr))
+             (fnodelistr fnodelist (cdr fnodelistr))
+             (vfnodelist '())
+             (varlist '())
+             (anodelist '())
+             (fenv '()))
+            ((null namelistr)
+             (values (nreverse vfnodelist) (nreverse varlist)
+                     (nreverse anodelist)
+                     (sys::cons-*fenv* fenv)))
+          (push (car namelistr) fenv)
+          (let ((fnode (car fnodelistr)))
+            (if (zerop (fnode-keyword-offset fnode))
+              ;; function-definition is autonomous
+              (push (cons (list fnode) (new-const fnode)) fenv)
+              (progn
+                (push fnode vfnodelist)
+                (push (c-fnode-function fnode) anodelist)
+                (push 1 *stackz*)
+                (let ((var (mk-var)))
+                  (push (cons (list fnode) var) fenv)
+                  (push var varlist))))))
+      (apply #'push-*venv* varlist) ; activate auxiliary variables
+      (let ((body-anode (c-declarations #'c-form declarations body-rest)))
+        (unless *no-code*
+          (mapc #'(lambda (var fnode)
+                    (when (var-really-usedp var)
+                      (propagate-far-used fnode)))
+                varlist vfnodelist))
+        (get-anode FLET)))))
 
 ;; compile (LABELS ({fundef}*) {form}*)
 (defun c-LABELS ()
   (test-list *form* 2)
   (test-list (second *form*) 0)
-  (with-bindings ((cddr *form*) body-rest)
-    (let ((closuredummy-stackz *stackz*)
-          (closuredummy-venvc *venvc*))
-      (multiple-value-bind
-            (namelist varlist lambdanamelist lambdabodylist fenvconslist)
-          (do ((fdefsr (second *form*) (cdr fdefsr))
-               (L1 '())
-               (L2 '())
-               (L3 '())
-               (L4 '())
-               (L5 '()))
-              ((null fdefsr)
-               (values (nreverse L1) (nreverse L2) (nreverse L3)
-                       (nreverse L4) (nreverse L5)))
-            (let ((fdef (car fdefsr)))
-              (check-fdef-name LABELS fdef)
-              (let ((name (car fdef)))
-                (push name L1)
-                (push 1 *stackz*)
-                (push (mk-var) L2)
-                (push (symbol-suffix (fnode-name *func*) name) L3)
-                (push (cdr fdef) L4)
-                (push
-                  (cons
-                    ;; fdescr, consisting of:
-                    (cons nil ; room for the FNODE
-                      (cons 'LABELS
-                        (multiple-value-list ; values from c-analyze-lambdalist
-                          (c-analyze-lambdalist
-                           (if *defun-accept-specialized-lambda-list*
-                             (sys::specialized-lambda-list-to-ordinary
-                               (cadr fdef) 'compile)
-                             (cadr fdef))))))
-                    ;; Variable
-                    (car L2))
-                  L5))))
-        ;; namelist = list of names, varlist = list of variables,
-        ;; lambdanamelist = list of Dummy-names of the functions,
-        ;; lambdabodylist = list of Lambda-bodies of the functions,
-        ;; fenvconslist = list of Conses (fdescr . var) for *fenv*
-        ;; (fdescr still without fnode, which is inserted later).
-        (let ((*fenv* ; activate function-name
-                (add-fenv namelist fenvconslist)))
-          (apply #'push-*venv* varlist) ; activate auxiliary variables
-          (let* ((fnodelist ; compile functions
-                   (mapcar #'(lambda (name lambdaname lambdabody fenvcons)
-                               (c-lambdabody
-                                 lambdaname
-                                 (add-implicit-block name lambdabody)
-                                 fenvcons))
-                           namelist lambdanamelist lambdabodylist
-                           fenvconslist))
-                 (anodelist
-                   (mapcar #'(lambda (fnode var)
-                               (c-fnode-function fnode (cdr (var-stackz var))))
-                           fnodelist varlist))
-                 (body-anode (c-form `(PROGN ,@body-rest)))) ; compile body
-            ;; the variables, for which the function was autonomous, are
-            ;; additionally declared as constants:
-            (do ((varlistr varlist (cdr varlistr))
-                 (fnodelistr fnodelist (cdr fnodelistr)))
-                ((null varlistr))
-              (let ((var (car varlistr))
-                    (fnode (car fnodelistr)))
-                (when (zerop (fnode-keyword-offset fnode))
-                  ;; function-definition is autonomous
-                  (setf (var-constantp var) t)
-                  (setf (var-constant var) (new-const fnode)))))
-            ;; Determine the functions which are really used.
-            ;; Functions with closure variables can pull in other functions.
-            (unless *no-code*
-              (let ((last-count 0))
-                (loop
-                  ;; Iterate as long as at least one function has been
-                  ;; pulled in.
-                  (when (eql last-count
-                             (setq last-count (count-if #'var-really-usedp
-                                                        varlist)))
-                    (return))
-                  (do ((varlistr varlist (cdr varlistr))
-                       (fnodelistr fnodelist (cdr fnodelistr)))
-                      ((null varlistr))
-                    (let ((var (car varlistr))
-                          (fnode (car fnodelistr)))
-                      (unless (zerop (fnode-keyword-offset fnode))
-                        ;; function with closure variables
-                        (when (var-really-usedp var)
-                          (propagate-far-used fnode))))))))
-            (get-anode LABELS)))))))
+  (with-bindings ((cddr *form*) body-rest declarations
+                  (namelist varlist lambdanamelist lambdabodylist fenvconslist))
+    (do ((fdefsr (second *form*) (cdr fdefsr))
+         (L1 '())               ; namelist
+         (L2 '())               ; varlist
+         (L3 '())               ; lambdanamelist
+         (L4 '())               ; lambdabodylist
+         (L5 '()))              ; fenvconslist
+        ((null fdefsr)
+         (values (nreverse L1) (nreverse L2) (nreverse L3)
+                 (nreverse L4) (nreverse L5)))
+      (let ((fdef (car fdefsr)))
+        (check-fdef-name LABELS fdef)
+        (let ((name (car fdef)))
+          (push name L1)
+          (push 1 *stackz*)
+          (push (mk-var) L2)
+          (push (symbol-suffix (fnode-name *func*) name) L3)
+          (push (cdr fdef) L4)
+          (push
+           (cons
+            ;; fdescr, consisting of:
+            (cons nil ; room for the FNODE
+              (cons 'LABELS
+                (multiple-value-list ; values from c-analyze-lambdalist
+                 (c-analyze-lambdalist
+                  (if *defun-accept-specialized-lambda-list*
+                      (sys::specialized-lambda-list-to-ordinary
+                       (cadr fdef) 'compile)
+                      (cadr fdef))))))
+            ;; Variable
+            (car L2))
+           L5))))
+    ;; namelist = list of names, varlist = list of variables,
+    ;; lambdanamelist = list of Dummy-names of the functions,
+    ;; lambdabodylist = list of Lambda-bodies of the functions,
+    ;; fenvconslist = list of Conses (fdescr . var) for *fenv*
+    ;; (fdescr still without fnode, which is inserted later).
+    (let ((*fenv* ; activate function-name
+           (add-fenv namelist fenvconslist)))
+      (apply #'push-*venv* varlist) ; activate auxiliary variables
+      (let* ((fnodelist ; compile functions
+              (mapcar #'(lambda (name lambdaname lambdabody fenvcons)
+                          (c-lambdabody
+                           lambdaname
+                           (add-implicit-block name lambdabody)
+                           fenvcons))
+                      namelist lambdanamelist lambdabodylist
+                      fenvconslist))
+             (anodelist
+              (mapcar #'(lambda (fnode var)
+                          (c-fnode-function fnode (cdr (var-stackz var))))
+                      fnodelist varlist))
+             (body-anode (c-declarations #'c-form declarations body-rest)))
+        ;; the variables, for which the function was autonomous, are
+        ;; additionally declared as constants:
+        (do ((varlistr varlist (cdr varlistr))
+             (fnodelistr fnodelist (cdr fnodelistr)))
+            ((null varlistr))
+          (let ((var (car varlistr))
+                (fnode (car fnodelistr)))
+            (when (zerop (fnode-keyword-offset fnode))
+              ;; function-definition is autonomous
+              (setf (var-constantp var) t)
+              (setf (var-constant var) (new-const fnode)))))
+        ;; Determine the functions which are really used.
+        ;; Functions with closure variables can pull in other functions.
+        (unless *no-code*
+          (let ((last-count 0))
+            (loop
+              ;; Iterate as long as at least one function has been pulled in.
+              (when (eql last-count
+                         (setq last-count (count-if #'var-really-usedp
+                                                    varlist)))
+                (return))
+              (do ((varlistr varlist (cdr varlistr))
+                   (fnodelistr fnodelist (cdr fnodelistr)))
+                  ((null varlistr))
+                (let ((var (car varlistr))
+                      (fnode (car fnodelistr)))
+                  (unless (zerop (fnode-keyword-offset fnode))
+                    ;; function with closure variables
+                    (when (var-really-usedp var)
+                      (propagate-far-used fnode))))))))
+        (get-anode LABELS)))))
 
 ;; compile
 ;; (SYS::FUNCTION-MACRO-LET ({(name fun-lambdabody macro-lambdabody)}) {form})
@@ -5729,10 +5722,10 @@
   (do ((L1 (second *form*) (cdr L1))
        (L2 '()))
       ((null L1)
-       (with-bindings-lite ((cddr *form*) body-rest)
-         (let ((*fenv* (sys::cons-*fenv* L2)))
-           ;; compile the remaining forms:
-           (funcall c `(PROGN ,@body-rest)))))
+       (multiple-value-bind (body-rest declarations) (parse-body (cddr *form*))
+         (let ((*denv* *denv*) (*venv* *venv*)
+               (*fenv* (sys::cons-*fenv* L2)))
+           (c-declarations c declarations body-rest))))
     (let* ((macrodef (car L1))
            (name (car macrodef)))
       (push name L2)

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v
retrieving revision 1.6432
retrieving revision 1.6433
diff -u -d -r1.6432 -r1.6433
--- ChangeLog	24 Jul 2008 02:50:22 -0000	1.6432
+++ ChangeLog	24 Jul 2008 03:57:19 -0000	1.6433
@@ -1,5 +1,10 @@
 2008-07-23  Sam Steingold  <sd...@gn...>
 
+	* compiler.lisp (c-LABELS, c-FLET, c-MACROLET): rework the "ANSI
+	SPECIAL declarations" patch to fix a LABELS flaw
+
+2008-07-23  Sam Steingold  <sd...@gn...>
+
 	* compiler.lisp (check-fdef-name): add local macro
 	(c-FLET, c-LABELS, c-FUNCTION-MACRO-LET, c-GENERIC-FLET)
 	(c-GENERIC-LABELS): use it




------------------------------

Message: 2
Date: Thu, 24 Jul 2008 03:57:21 +0000
From: Sam Steingold <sd...@us...>
Subject: clisp/tests bind.tst,1.16,1.17
To: cli...@li...
Message-ID: <E1K...@ma...>

Update of /cvsroot/clisp/clisp/tests
In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv16167/tests

Modified Files:
	bind.tst 
Log Message:
(c-LABELS, c-FLET, c-MACROLET): rework
the "ANSI SPECIAL declarations" patch to fix a LABELS flaw


Index: bind.tst
===================================================================
RCS file: /cvsroot/clisp/clisp/tests/bind.tst,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- bind.tst	23 Jul 2008 21:00:42 -0000	1.16
+++ bind.tst	24 Jul 2008 03:57:19 -0000	1.17
@@ -408,7 +408,7 @@
       (%m (t)))))
 nil
 
-;; macrolet.47
+;; macrolet.47, labels.47
 (let ((x :special))
   (declare (special x))
   (let ((x :lexical))
@@ -426,6 +426,13 @@
 (let ((x :special))
   (declare (special x))
   (let ((x :lexical))
+    (labels ((f () x))
+      (declare (special x))
+      (list x (f)))))
+(:SPECIAL :LEXICAL)
+(let ((x :special))
+  (declare (special x))
+  (let ((x :lexical))
     (labels ()
       (declare (special x))
       x)))




------------------------------

Message: 3
Date: Thu, 24 Jul 2008 14:56:12 +0000
From: Sam Steingold <sd...@us...>
Subject: clisp/src ChangeLog,1.6433,1.6434
To: cli...@li...
Message-ID: <E1K...@ma...>

Update of /cvsroot/clisp/clisp/src
In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv22713/src

Modified Files:
	ChangeLog 
Log Message:
(*expected-failures*): add eval-when.15 (/= LOAD :LOAD-TOPLEVEL)
and eval-when.17 (/= EVAL :EXECUTE)


Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v
retrieving revision 1.6433
retrieving revision 1.6434
diff -u -d -r1.6433 -r1.6434
--- ChangeLog	24 Jul 2008 03:57:19 -0000	1.6433
+++ ChangeLog	24 Jul 2008 14:56:08 -0000	1.6434
@@ -1,3 +1,8 @@
+2008-07-24  Sam Steingold  <sd...@gn...>
+
+	* utils/clispload.lsp (*expected-failures*): add eval-when.15 and
+	eval-when.17 (/= EVAL :EXECUTE) & (/= LOAD :LOAD-TOPLEVEL)
+
 2008-07-23  Sam Steingold  <sd...@gn...>
 
 	* compiler.lisp (c-LABELS, c-FLET, c-MACROLET): rework the "ANSI




------------------------------

Message: 4
Date: Thu, 24 Jul 2008 14:56:13 +0000
From: Sam Steingold <sd...@us...>
Subject: clisp/utils clispload.lsp,1.59,1.60
To: cli...@li...
Message-ID: <E1K...@ma...>

Update of /cvsroot/clisp/clisp/utils
In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv22713/utils

Modified Files:
	clispload.lsp 
Log Message:
(*expected-failures*): add eval-when.15 (/= LOAD :LOAD-TOPLEVEL)
and eval-when.17 (/= EVAL :EXECUTE)


Index: clispload.lsp
===================================================================
RCS file: /cvsroot/clisp/clisp/utils/clispload.lsp,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -d -r1.59 -r1.60
--- clispload.lsp	22 Jul 2008 18:13:33 -0000	1.59
+++ clispload.lsp	24 Jul 2008 14:56:10 -0000	1.60
@@ -218,6 +218,13 @@
   ;; CLISP extends DISASSEMBLE to accept STRINGs, METHODs, and forms
   DISASSEMBLE.ERROR.3
 
+  ;; CLISP keeps the deprecated EVAL-WHEN situations EVAL, COMPILE, LOAD
+  ;; at their old cltl2 meanings, different from :EXECUTE, :LOAD-TOPLEVEL,
+  ;; :COMPILE-TOPLEVEL (they ignore the top-level vs non-top-level difference)
+  ;; see http://clisp.cons.org/impnotes/evaluation.html#eval-when
+  ;; [these test fail only on compiled mode]
+  EVAL-WHEN.15 EVAL-WHEN.17
+
   ;; To be revisited:
 
 ))




------------------------------

Message: 5
Date: Thu, 24 Jul 2008 14:58:37 +0000
From: Sam Steingold <sd...@us...>
Subject: clisp/tests ChangeLog,1.576,1.577 eval20.tst,1.17,1.18
To: cli...@li...
Message-ID: <E1K...@ma...>

Update of /cvsroot/clisp/clisp/tests
In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv23576/tests

Modified Files:
	ChangeLog eval20.tst 
Log Message:
add tests based on ansi-tests eval-when.15 & eval-when.17


Index: eval20.tst
===================================================================
RCS file: /cvsroot/clisp/clisp/tests/eval20.tst,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -d -r1.17 -r1.18
--- eval20.tst	23 Jul 2008 15:30:50 -0000	1.17
+++ eval20.tst	24 Jul 2008 14:58:35 -0000	1.18
@@ -78,6 +78,35 @@
   (LET :COMPILE-TOPLEVEL :EXECUTE)
   (LET :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)))
 
+;; eval-when.15: in CLISP LOAD is not the same as :LOAD-TOPLEVEL
+(let ((f "eval-when-test.lisp") (ret ()))
+  (dolist (situation '(load :load-toplevel) (nreverse ret))
+    (let ((*collector* ()))
+      (with-open-file (o f :direction :output)
+        (prin1 `(let ((x :let))
+                  (push (list (eval-when (,situation) (setq x :eval-when)) x)
+                        *collector*))
+               o))
+      (load f) (load (compile-file f))
+      (post-compile-file-cleanup f)
+      (push (nreverse *collector*) ret))))
+(((NIL :LET) (:EVAL-WHEN :EVAL-WHEN)) ((NIL :LET) (NIL :LET)))
+
+;; eval-when.17: in CLISP EVAL is not the same as :EXECUTE
+(let ((f "eval-when-test.lisp") (ret ()))
+  (dolist (situation '(eval :execute) (nreverse ret))
+    (let ((*collector* ()))
+      (with-open-file (o f :direction :output)
+        (prin1 `(let ((x :let))
+                  (push (list (eval-when (,situation) (setq x :eval-when)) x)
+                        *collector*))
+               o))
+      (load f) (load (compile-file f))
+      (post-compile-file-cleanup f)
+      (push (nreverse *collector*) ret))))
+(((:EVAL-WHEN :EVAL-WHEN) (NIL :LET))
+ ((:EVAL-WHEN :EVAL-WHEN) (:EVAL-WHEN :EVAL-WHEN)))
+
 ;; constantp
 
 (constantp 2)
@@ -265,6 +294,7 @@
 (progn (symbol-cleanup 'setf-foo)
        (symbol-cleanup 'bar)
        (symbol-cleanup 'x)
+       (symbol-cleanup '*collector*)
        (symbol-cleanup 'dummy-function)
        (symbol-cleanup 'recursive-times)
        (symbol-cleanup 'mlets)

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v
retrieving revision 1.576
retrieving revision 1.577
diff -u -d -r1.576 -r1.577
--- ChangeLog	23 Jul 2008 21:00:42 -0000	1.576
+++ ChangeLog	24 Jul 2008 14:58:35 -0000	1.577
@@ -1,3 +1,7 @@
+2008-07-24  Sam Steingold  <sd...@gn...>
+
+	* eval20.tst: add tests based on ansi-tests eval-when.15 & eval-when.17
+
 2008-07-23  Sam Steingold  <sd...@gn...>
 
 	* bind.tst: test that flet/labels/macrolet respect SPECIAL declarations




------------------------------

Message: 6
Date: Thu, 24 Jul 2008 17:44:13 +0000
From: Sam Steingold <sd...@us...>
Subject: clisp/src spvw.d,1.438,1.439
To: cli...@li...
Message-ID: <E1K...@ma...>

Update of /cvsroot/clisp/clisp/src
In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv21544

Modified Files:
	spvw.d 
Log Message:
whitespace


Index: spvw.d
===================================================================
RCS file: /cvsroot/clisp/clisp/src/spvw.d,v
retrieving revision 1.438
retrieving revision 1.439
diff -u -d -r1.438 -r1.439
--- spvw.d	21 Jul 2008 22:16:38 -0000	1.438
+++ spvw.d	24 Jul 2008 17:44:11 -0000	1.439
@@ -3280,7 +3280,7 @@
   init_ffi();
  #endif
   init_other_modules_2();     /* initialize modules yet uninitialized */
-  {                           /* final module initializations: */
+  { /* final module initializations: */
     var module_t* module;     /* loop over modules */
     for_modules(all_other_modules,{
       if (module->initfunction2)
@@ -3289,8 +3289,7 @@
     });
   }
   run_hooks(Symbol_value(S(init_hooks)));
-  /* Init O(argv). */
-  {
+  { /* Init O(argv). */
     O(argv) = allocate_vector(argc);
     var argc_t count;
     for (count = 0; count < argc; count++) {




------------------------------

Message: 7
Date: Thu, 24 Jul 2008 17:45:53 +0000
From: Sam Steingold <sd...@us...>
Subject: clisp/src ChangeLog,1.6434,1.6435 format.lisp,1.55,1.56
To: cli...@li...
Message-ID: <E1K...@ma...>

Update of /cvsroot/clisp/clisp/src
In directory sc8-pr-cvs4.sourceforge.net:/tmp/cvs-serv21972/src

Modified Files:
	ChangeLog format.lisp 
Log Message:
(format-logical-block-parse): uniform error messages


Index: format.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/src/format.lisp,v
retrieving revision 1.55
retrieving revision 1.56
diff -u -d -r1.55 -r1.56
--- format.lisp	5 May 2008 21:30:40 -0000	1.55
+++ format.lisp	24 Jul 2008 17:45:50 -0000	1.56
@@ -1685,7 +1685,7 @@
                                   (csd-data (car csdl))))
              (pop csdl))
             (t (format-error 'error *FORMAT-CS* (csd-cs-index (car csdl))
-                 (TEXT "Prefix for logical block must be constant")))))
+                 (TEXT "Logical block prefix must be constant")))))
     (setq body-csdl (cdr csdl))
     (setq temp (csd-clause-chain (car csdl)))
     (unless (eq (csd-data (car temp)) 'FORMAT-JUSTIFICATION-END)

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v
retrieving revision 1.6434
retrieving revision 1.6435
diff -u -d -r1.6434 -r1.6435
--- ChangeLog	24 Jul 2008 14:56:08 -0000	1.6434
+++ ChangeLog	24 Jul 2008 17:45:45 -0000	1.6435
@@ -1,5 +1,9 @@
 2008-07-24  Sam Steingold  <sd...@gn...>
 
+	* format.lisp (format-logical-block-parse): uniform error messages
+
+2008-07-24  Sam Steingold  <sd...@gn...>
+
 	* utils/clispload.lsp (*expected-failures*): add eval-when.15 and
 	eval-when.17 (/= EVAL :EXECUTE) & (/= LOAD :LOAD-TOPLEVEL)
 




------------------------------

-------------------------------------------------------------------------
This SF.Net email is sponsored by the Moblin Your Move Developer's challenge
Build the coolest Linux based applications with Moblin SDK & win great prizes
Grand prize is a trip for two to an Open Source event anywhere in the world
http://moblin-contest.org/redirect.php?banner_id=100&url=/

------------------------------

_______________________________________________
clisp-cvs mailing list
cli...@li...
https://lists.sourceforge.net/lists/listinfo/clisp-cvs


End of clisp-cvs Digest, Vol 27, Issue 44
*****************************************