clisp-cvs digest, Vol 1 #936 - 6 msgs

[<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 socket.d,1.90,1.91 genclisph.d,1.169,1.170 ChangeLog,1.4172,1.4173 (Bruno Haible)
   2. clisp/src clos-class3.lisp,1.81,1.82 ChangeLog,1.4173,1.4174 (Bruno Haible)
   3. clisp/tests bind.tst,1.7,1.8 ChangeLog,1.312,1.313 (Bruno Haible)
   4. clisp/src control.d,1.124,1.125 defmacro.lisp,1.33,1.34 eval.d,1.187,1.188 init.lisp,1.216,1.217 compiler.lisp,1.249,1.250 NEWS,1.234,1.235 ChangeLog,1.4174,1.4175 (Bruno Haible)
   5. clisp/src macros2.lisp,1.32,1.33 ChangeLog,1.4175,1.4176 (Bruno Haible)
   6. clisp/src foreign1.lisp,1.80,1.81 ChangeLog,1.4176,1.4177 (Bruno Haible)

--__--__--

Message: 1
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/src socket.d,1.90,1.91 genclisph.d,1.169,1.170 ChangeLog,1.4172,1.4173
Date: Sat, 29 Jan 2005 14:58:19 +0000
Reply-To: cli...@li...

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

Modified Files:
	socket.d genclisph.d ChangeLog 
Log Message:
Use const where appropriate. Fixes compilation in C++ mode.


Index: socket.d
===================================================================
RCS file: /cvsroot/clisp/clisp/src/socket.d,v
retrieving revision 1.90
retrieving revision 1.91
diff -u -d -r1.90 -r1.91
--- socket.d	29 Jan 2005 14:57:10 -0000	1.90
+++ socket.d	29 Jan 2005 14:58:16 -0000	1.91
@@ -307,21 +307,21 @@
 #endif
 
 /* for syscalls and rawsock modules */
-typedef int (*host_fn_t) (void* addr, int addrlen, int family, void* opts);
+typedef int (*host_fn_t) (const void* addr, int addrlen, int family, void* opts);
 /* call FN on host/size/opts if HOST is an IP address */
-local int with_host (char* host, host_fn_t fn, void* opts) {
+local int with_host (const char* host, host_fn_t fn, void* opts) {
 #ifdef HAVE_INET_PTON
  #ifdef HAVE_IPV6
   {
     var struct in6_addr inaddr;
     if (inet_pton(AF_INET6,host,&inaddr) > 0)
-      return fn((void*)&inaddr,sizeof(struct in6_addr),AF_INET6,opts);
+      return fn(&inaddr,sizeof(struct in6_addr),AF_INET6,opts);
   }
  #endif
   {
     var struct in_addr inaddr;
     if (inet_pton(AF_INET,host,&inaddr) > 0)
-      return fn((void*)&inaddr,sizeof(struct in_addr),AF_INET,opts);
+      return fn(&inaddr,sizeof(struct in_addr),AF_INET,opts);
   }
 #else
   /* if numeric host name then try to parse it as such; do the number check
@@ -329,29 +329,31 @@
   if (all_digits_dots(host)) {
     var uint32 hostinetaddr = inet_addr(host) INET_ADDR_SUFFIX ;
     if (!(hostinetaddr == ((uint32) -1)))
-      return fn((void*)&hostinetaddr,sizeof(uint32),AF_INET,opts);
+      return fn(&hostinetaddr,sizeof(uint32),AF_INET,opts);
   }
 #endif
   return fn(host,0,0,opts);
 }
 
-local int string_to_addr1 (void* addr, int addrlen, int family, void* ret) {
+local int string_to_addr1 (const void* addr, int addrlen, int family, void* ret) {
   *(object*)ret = (addrlen
                    ? LEbytes_to_UI(addrlen,(const uintB*)addr)
-                   : asciz_to_string((char*)addr,O(misc_encoding)));
+                   : asciz_to_string((const char*)addr,O(misc_encoding)));
   (void)family; /* ignore */
   return 0;
 }
-global object string_to_addr (char* name) {
+global object string_to_addr (const char* name) {
   object ret;
   begin_system_call();
   with_host(name,&string_to_addr1,&ret);
   end_system_call();
   return ret;
 }
-local int resolve_host1 (void* addr, int addrlen, int family, void* ret) {
+local int resolve_host1 (const void* addr, int addrlen, int family, void* ret) {
   *(struct hostent**)ret =
-    (addrlen ? gethostbyaddr(addr,addrlen,family) : gethostbyname(addr));
+    (addrlen
+     ? gethostbyaddr(addr,addrlen,family)
+     : gethostbyname((const char*)addr));
   return 0;
 }
 global struct hostent* resolve_host (object arg) {

Index: genclisph.d
===================================================================
RCS file: /cvsroot/clisp/clisp/src/genclisph.d,v
retrieving revision 1.169
retrieving revision 1.170
diff -u -d -r1.169 -r1.170
--- genclisph.d	29 Jan 2005 14:57:10 -0000	1.169
+++ genclisph.d	29 Jan 2005 14:58:16 -0000	1.170
@@ -2123,7 +2123,7 @@
   printf("extern object file_stream_truename (object s);\n");
   printf("extern object open_file_stream_handle (object stream, Handle *fd);\n");
   printf("extern object addr_to_string (short type, char *addr);\n");
-  printf("extern object string_to_addr (char *name);\n");
+  printf("extern object string_to_addr (const char *name);\n");
   printf("extern struct hostent* resolve_host (object arg);\n");
   printf("#define strm_buffered_bufflen %d\n",strm_buffered_bufflen);
 #if notused

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v
retrieving revision 1.4172
retrieving revision 1.4173
diff -u -d -r1.4172 -r1.4173
--- ChangeLog	29 Jan 2005 14:57:10 -0000	1.4172
+++ ChangeLog	29 Jan 2005 14:58:16 -0000	1.4173
@@ -1,5 +1,11 @@
 2005-01-28  Bruno Haible  <br...@cl...>
 
+	* socket.d (host_fn_t, with_host, string_to_addr1, string_to_addr,
+	resolve_host1): Use const where appropriate.
+	* genclisph.d (main): Update.
+
+2005-01-28  Bruno Haible  <br...@cl...>
+
 	* lispbibl.d (udigits_to_I): Remove declaration.
 	* intelem.d (udigits_to_I): Remove function.
 	* socket.d (string_to_addr1): Call LEbytes_to_UI instead of



--__--__--

Message: 2
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/src clos-class3.lisp,1.81,1.82 ChangeLog,1.4173,1.4174
Date: Sat, 29 Jan 2005 14:59:45 +0000
Reply-To: cli...@li...

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

Modified Files:
	clos-class3.lisp ChangeLog 
Log Message:
Tweak an error message.


Index: clos-class3.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/src/clos-class3.lisp,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -d -r1.81 -r1.82
--- clos-class3.lisp	28 Jan 2005 13:58:46 -0000	1.81
+++ clos-class3.lisp	29 Jan 2005 14:59:42 -0000	1.82
@@ -1382,7 +1382,7 @@
              'compute-slots (class-name class) slots))
     (dolist (slot slots)
       (unless (slot-definition-location slot)
-        (error (TEXT "Wrong ~S result for class ~S: not slot location has been assigned to ~S")
+        (error (TEXT "Wrong ~S result for class ~S: no slot location has been assigned to ~S")
                'compute-slots (class-name class) slot)))
     slots))
 

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v
retrieving revision 1.4173
retrieving revision 1.4174
diff -u -d -r1.4173 -r1.4174
--- ChangeLog	29 Jan 2005 14:58:16 -0000	1.4173
+++ ChangeLog	29 Jan 2005 14:59:43 -0000	1.4174
@@ -1,3 +1,7 @@
+2005-01-27  Bruno Haible  <br...@cl...>
+
+	* clos-class3.lisp (checked-compute-slots): Tweak an error message.
+
 2005-01-28  Bruno Haible  <br...@cl...>
 
 	* socket.d (host_fn_t, with_host, string_to_addr1, string_to_addr,



--__--__--

Message: 3
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/tests bind.tst,1.7,1.8 ChangeLog,1.312,1.313
Date: Sat, 29 Jan 2005 15:02:55 +0000
Reply-To: cli...@li...

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

Modified Files:
	bind.tst ChangeLog 
Log Message:
Improved error checking for references from within MACROLET-defined
macro expanders.


Index: bind.tst
===================================================================
RCS file: /cvsroot/clisp/clisp/tests/bind.tst,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- bind.tst	20 Jan 2005 20:03:54 -0000	1.7
+++ bind.tst	29 Jan 2005 15:02:38 -0000	1.8
@@ -206,3 +206,97 @@
        (1+ *global-var-for-bind.tst*))
       *global-var-for-bind.tst*)))
 (6 5)
+
+
+;;; MACROLET and environments.
+
+(eval-when (eval compile load)
+  (defmacro chk-type (form type)
+    (let ((obj (gensym)))
+      `(LET ((,obj ,form)) (ASSERT (TYPEP ,obj ',type)) (THE ,type ,obj)))))
+CHK-TYPE
+
+;; Local macros may reference locally defined symbol macros.
+(symbol-macrolet ((x (list 'symbol)))
+  (macrolet ((foo (form) `(CHK-TYPE ,form ,@x)))
+    (foo 'bar)))
+BAR
+(let ((x 5))
+  (progv '(x) '(20)
+    (symbol-macrolet ((x (list 'symbol)))
+      (macrolet ((foo (form) `(CHK-TYPE ,form ,@x)))
+        (foo 'bar)))))
+BAR
+
+;; Local macros may reference SPECIAL declarations.
+(locally
+  (declare (special symbol-type))
+  (setq symbol-type (list 'symbol)))
+(SYMBOL)
+(locally
+  (declare (special symbol-type))
+  (macrolet ((foo (form) `(CHK-TYPE ,form ,@symbol-type)))
+    (foo 'bar)))
+BAR
+
+;; Local macros may reference global variables.
+;; Careful! In interpreted mode, the value from the dynamic binding is used;
+;; in compiled mode, the original global value is used. (To change this,
+;; one would have to use COMPILER-LET.)
+(defparameter *symbol-type* (list 'symbol))
+*SYMBOL-TYPE*
+(let ((*symbol-type* (list 'symbol)))
+  (macrolet ((foo (form) `(CHK-TYPE ,form ,@*symbol-type*)))
+    (foo 'bar)))
+BAR
+
+;; Local macros must not reference lexical variable bindings.
+(progv '(x) '((symbol))
+  (let ((x (list 'symbol)))
+    (macrolet ((foo (form) `(CHK-TYPE ,form ,@x)))
+      (foo 'bar))))
+ERROR
+(progv '(x) '((symbol))
+  (let ((x (list 'symbol)))
+    (defun testfn ()
+      (macrolet ((foo (form) `(CHK-TYPE ,form ,@x)))
+        (foo 'bar))))
+  (testfn))
+ERROR
+(progv '(x) '((symbol))
+  (let ((x (list 'symbol)))
+    (macrolet ((foo (form) `(CHK-TYPE ,form ,@x)))
+      (defun testfn ()
+        (foo 'bar))))
+  (testfn))
+ERROR
+
+;; Local macros may reference locally defined macros.
+(macrolet ((x () '(list 'symbol)))
+  (macrolet ((foo (form) `(CHK-TYPE ,form ,@(x))))
+    (foo 'bar)))
+BAR
+
+;; Local macros must not reference lexical function bindings.
+(defun symbol-type-fn () (list 'symbol))
+SYMBOL-TYPE-FN
+(flet ((symbol-type-fn () (list 'symbol)))
+  (macrolet ((foo (form) `(CHK-TYPE ,form ,@(symbol-type-fn))))
+    (foo 'bar)))
+ERROR
+(progn
+  (flet ((symbol-type-fn () (list 'symbol)))
+    (defun testfn ()
+      (macrolet ((foo (form) `(CHK-TYPE ,form ,@(symbol-type-fn))))
+        (foo 'bar))))
+  (testfn))
+ERROR
+(progn
+  (flet ((symbol-type-fn () (list 'symbol)))
+    (macrolet ((foo (form) `(CHK-TYPE ,form ,@(symbol-type-fn))))
+      (defun testfn ()
+        (foo 'bar))))
+  (testfn))
+ERROR
+(fmakunbound 'symbol-type-fn)
+SYMBOL-TYPE-FN

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/tests/ChangeLog,v
retrieving revision 1.312
retrieving revision 1.313
diff -u -d -r1.312 -r1.313
--- ChangeLog	28 Jan 2005 14:01:56 -0000	1.312
+++ ChangeLog	29 Jan 2005 15:02:38 -0000	1.313
@@ -1,3 +1,7 @@
+2005-01-22  Bruno Haible  <br...@cl...>
+
+	* bind.tst: Add tests for MACROLET expander environments.
+
 2005-01-27  Bruno Haible  <br...@cl...>
 
 	* path.tst: Add test for (logical-pathname ":").



--__--__--

Message: 4
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/src control.d,1.124,1.125 defmacro.lisp,1.33,1.34 eval.d,1.187,1.188 init.lisp,1.216,1.217 compiler.lisp,1.249,1.250 NEWS,1.234,1.235 ChangeLog,1.4174,1.4175
Date: Sat, 29 Jan 2005 15:02:40 +0000
Reply-To: cli...@li...

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

Modified Files:
	control.d defmacro.lisp eval.d init.lisp compiler.lisp NEWS 
	ChangeLog 
Log Message:
Improved error checking for references from within MACROLET-defined
macro expanders.


Index: compiler.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/src/compiler.lisp,v
retrieving revision 1.249
retrieving revision 1.250
diff -u -d -r1.249 -r1.250
--- compiler.lisp	28 Jan 2005 14:05:26 -0000	1.249
+++ compiler.lisp	29 Jan 2005 15:02:35 -0000	1.250
@@ -926,32 +926,40 @@
 ;; Or:
 ;; 1. value: NIL                     if not defined locally.
 (defun fenv-search (f &optional (fenv *fenv*))
-  (loop
-    (when (null fenv) (return-from fenv-search 'NIL))
-    (unless (simple-vector-p fenv) (compiler-error 'fenv-search fenv))
-    (do ((l (1- (length fenv)))
-         (i 0 (+ i 2)))
-        ((= i l) (setq fenv (svref fenv i)))
-      (if (equal f (svref fenv i))
-        (let ((def (svref fenv (1+ i))))
-          (return-from fenv-search
-            (if (consp def)
-              (if (macrop (car def))
-                (values 'T
-                        (macro-expander (car def))
-                        'LOCAL (cddr def) (cadr def))
-                (values 'T
-                        'NIL
-                        'LOCAL (cdr def) (car def)))
-              (if (macrop def)
-                (values 'T (macro-expander def) 'NIL)
-                (if (function-macro-p def)
-                  (values 'T
-                          (function-macro-expander def)
-                          'GLOBAL fenv (1+ i) 'T)
-                  (values 'T
-                          'NIL
-                          'GLOBAL fenv (1+ i) 'NIL))))))))))
+  (let ((from-inside-macrolet nil))
+    (loop
+      (cond ((null fenv) (return-from fenv-search 'NIL))
+            ((simple-vector-p fenv)
+             (do ((l (1- (length fenv)))
+                  (i 0 (+ i 2)))
+                 ((= i l) (setq fenv (svref fenv i)))
+               (if (equal f (svref fenv i))
+                 (let ((def (svref fenv (1+ i))))
+                   (if (and from-inside-macrolet (not (macrop def)))
+                     (c-error (TEXT "Invalid access to the local function definition of ~S from within a ~S definition")
+                              f 'macrolet)
+                     (return-from fenv-search
+                       (if (consp def)
+                         (if (macrop (car def))
+                           (values 'T
+                                   (macro-expander (car def))
+                                   'LOCAL (cddr def) (cadr def))
+                           (values 'T
+                                   'NIL
+                                   'LOCAL (cdr def) (car def)))
+                         (if (macrop def)
+                           (values 'T (macro-expander def) 'NIL)
+                           (if (function-macro-p def)
+                             (values 'T
+                                     (function-macro-expander def)
+                                     'GLOBAL fenv (1+ i) 'T)
+                             (values 'T
+                                     'NIL
+                                     'GLOBAL fenv (1+ i) 'NIL))))))))))
+            ((and (consp fenv) (eq (car fenv) 'MACROLET))
+             (setq from-inside-macrolet t)
+             (setq fenv (cdr fenv)))
+            (t (compiler-error 'fenv-search fenv))))))
 ;; Determines, if a function-name is not defined in the
 ;; Function-Environment fenv and hence refers to the global function.
 (defun global-in-fenv-p (s fenv)
@@ -1158,23 +1166,32 @@
 (defun venv-search (v &optional (venv *venv*))
   (when (or (constantp v) (proclaimed-special-p v))
     (return-from venv-search 'SPECIAL))
-  (loop
-    (cond ((null venv) (return-from venv-search 'NIL))
-          ((simple-vector-p venv)
-           (do ((l (1- (length venv)))
-                (i 0 (+ i 2)))
-               ((= i l) (setq venv (svref venv i)))
-             (if (eq v (svref venv i))
-               (let ((val (svref venv (1+ i))))
-                 (return-from venv-search
-                   (if (and (var-p val) #| (eq (var-name val) v) |# )
-                     (progn
-                       (assert (not (var-specialp val)))
-                       (values T val))
-                     (if (eq val specdecl)
-                       'SPECIAL
-                       (values 'LOCAL venv (1+ i)))))))))
-          (t (compiler-error 'venv-search venv)))))
+  (let ((from-inside-macrolet nil))
+    (loop
+      (cond ((null venv) (return-from venv-search 'NIL))
+            ((simple-vector-p venv)
+             (do ((l (1- (length venv)))
+                  (i 0 (+ i 2)))
+                 ((= i l) (setq venv (svref venv i)))
+               (if (eq v (svref venv i))
+                 (let ((val (svref venv (1+ i))))
+                   (if (and from-inside-macrolet
+                            (not (eq val specdecl))
+                            (not (symbol-macro-p val)))
+                     (c-error (TEXT "Invalid access to the value of the lexical variable ~S from within a ~S definition")
+                              v 'macrolet)
+                     (return-from venv-search
+                       (if (and (var-p val) #| (eq (var-name val) v) |# )
+                         (progn
+                           (assert (not (var-specialp val)))
+                           (values T val))
+                         (if (eq val specdecl)
+                           'SPECIAL
+                           (values 'LOCAL venv (1+ i))))))))))
+            ((and (consp venv) (eq (car venv) 'MACROLET))
+             (setq from-inside-macrolet t)
+             (setq venv (cdr venv)))
+            (t (compiler-error 'venv-search venv))))))
 
 ;; (venv-search-macro v) searches in *venv* for a Variable with the Symbol v.
 ;; result:

Index: defmacro.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/src/defmacro.lisp,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -d -r1.33 -r1.34
--- defmacro.lisp	21 Jan 2005 11:46:01 -0000	1.33
+++ defmacro.lisp	29 Jan 2005 15:02:32 -0000	1.34
@@ -500,13 +500,24 @@
                lambdalist
                docstring))))))))
 
+;; Creates a macro expander for MACROLET.
 (defun make-macro-expander (macrodef whole-form
                             &optional
-                            (env (vector (and (boundp '*venv*) *venv*)
-                                         (and (boundp '*fenv*) *fenv*)
-                                         (and (boundp '*benv*) *benv*)
-                                         (and (boundp '*genv*) *genv*)
-                                         (if (boundp '*denv*) *denv*
-                                             *toplevel-denv*))))
-  (make-macro ;; CLTL1: (eval (make-macro-expansion macrodef whole-form))
-   (evalhook (make-macro-expansion macrodef whole-form) nil nil env)))
+                            ;; The environment is tricky: ANSI CL says that
+                            ;; 1. declarations, macros and symbol-macros from
+                            ;; outside can be used in the macro expander,
+                            ;; 2. other variable and function bindings cannot.
+                            ;; 3. It is unclear about BLOCK and TAGBODY tags.
+                            (env (vector (and (boundp '*venv*)
+                                              (cons 'MACROLET *venv*))
+                                         (and (boundp '*fenv*)
+                                              (cons 'MACROLET *fenv*))
+                                         (and (boundp '*benv*)
+                                              *benv*)
+                                         (and (boundp '*genv*)
+                                              *genv*)
+                                         (if (boundp '*denv*)
+                                           *denv*
+                                           *toplevel-denv*))))
+  (make-macro
+    (evalhook (make-macro-expansion macrodef whole-form) nil nil env)))

Index: init.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/src/init.lisp,v
retrieving revision 1.216
retrieving revision 1.217
diff -u -d -r1.216 -r1.217
--- init.lisp	26 Jan 2005 13:38:16 -0000	1.216
+++ init.lisp	29 Jan 2005 15:02:35 -0000	1.217
@@ -683,29 +683,43 @@
 
 ;; (fenv-assoc s fenv) searches symbol S in function-environment FENV.
 ;; the search routine uses EQUAL
-(defun fenv-assoc (s fenv)
+(defun fenv-assoc (s fenv &optional (from-inside-macrolet nil))
   (if fenv
     (if (simple-vector-p fenv)
       #+COMPILER
       (do ((l (1- (length fenv)))
            (i 0 (+ i 2)))
-          ((= i l) (fenv-assoc s (svref fenv i)))
+          ((= i l) (fenv-assoc s (svref fenv i) from-inside-macrolet))
         (if (equal s (svref fenv i))
-          (return (svref fenv (1+ i)))))
+          (if (and from-inside-macrolet (not (macrop (svref fenv (1+ i)))))
+            (error-of-type 'source-program-error
+              :form (list 'FUNCTION s)
+              :detail s
+              (TEXT "Invalid access to the local function definition of ~S from within a ~S definition")
+              s 'macrolet)
+            (return (svref fenv (1+ i))))))
       #-COMPILER
       (let ((l (1- (length fenv)))
             (i 0))
         (block nil
           (tagbody
-            1 (if (= i l) (return-from nil (fenv-assoc s (svref fenv i))))
+            1 (if (= i l) (return-from nil (fenv-assoc s (svref fenv i) from-inside-macrolet)))
               (if (equal s (svref fenv i))
-                (return-from nil (svref fenv (1+ i))))
+                (if (and from-inside-macrolet (not (macrop (svref fenv (1+ i)))))
+                  (error-of-type 'source-program-error
+                    :form (list 'FUNCTION s)
+                    :detail s
+                    (TEXT "Invalid access to the local function definition of ~S from within a ~S definition")
+                    s 'macrolet)
+                  (return-from nil (svref fenv (1+ i)))))
               (setq i (+ i 2))
               (go 1))))
-      (error-of-type 'type-error
-        :datum fenv :expected-type '(or null simple-vector)
-        (TEXT "~S is an invalid function environment")
-        fenv))
+      (if (and (consp fenv) (eq (car fenv) 'MACROLET))
+        (fenv-assoc s (cdr fenv) t)
+        (error-of-type 'type-error
+          :datum fenv :expected-type '(or null simple-vector (cons (eql macrolet) t))
+          (TEXT "~S is an invalid function environment")
+          fenv)))
     'T)) ; not found
 ;; Determines, if a function-name S in function-environment FENV is not
 ;; defined and thus refers to the global function.
@@ -727,29 +741,46 @@
 ;; Caution: The value can be #<SPECDECL> or #<SYMBOL-MACRO ...> , thus
 ;; may not be temporarily saved in a variable in interpreted Code.
 ;; the search routine uses EQ
-(defun venv-assoc (s venv)
+(defun venv-assoc (s venv &optional (from-inside-macrolet nil))
   (if venv
     (if (simple-vector-p venv)
       #+COMPILER
       (do ((l (1- (length venv)))
            (i 0 (+ i 2)))
-          ((= i l) (venv-assoc s (svref venv i)))
+          ((= i l) (venv-assoc s (svref venv i) from-inside-macrolet))
         (if (eq s (svref venv i))
-          (return (svref venv (1+ i)))))
+          (if (and from-inside-macrolet
+                   (not (eq (svref venv (1+ i)) compiler::specdecl))
+                   (not (symbol-macro-p (svref venv (1+ i)))))
+            (error-of-type 'source-program-error
+              :form s
+              :detail s
+              (TEXT "Invalid access to the value of the lexical variable ~S from within a ~S definition")
+              s 'macrolet)
+            (return (svref venv (1+ i))))))
       #-COMPILER
       (let ((l (1- (length venv)))
             (i 0))
         (block nil
           (tagbody
-            1 (if (= i l) (return-from nil (venv-assoc s (svref venv i))))
+            1 (if (= i l) (return-from nil (venv-assoc s (svref venv i) from-inside-macrolet)))
               (if (eq s (svref venv i))
-                (return-from nil (svref venv (1+ i))))
+                (if (and from-inside-macrolet
+                         (not (symbol-macro-p (svref venv (1+ i)))))
+                  (error-of-type 'source-program-error
+                    :form s
+                    :detail s
+                    (TEXT "Invalid access to the value of the lexical variable ~S from within a ~S definition")
+                    s 'macrolet)
+                  (return-from nil (svref venv (1+ i)))))
               (setq i (+ i 2))
               (go 1))))
-      (error-of-type 'type-error
-        :datum venv :expected-type '(or null simple-vector)
-        (TEXT "~S is an invalid variable environment")
-        venv))
+      (if (and (consp venv) (eq (car venv) 'MACROLET))
+        (venv-assoc s (cdr venv) t)
+        (error-of-type 'type-error
+          :datum venv :expected-type '(or null simple-vector)
+          (TEXT "~S is an invalid variable environment")
+          venv)))
     ; not found
     (if (symbol-macro-expand s)
       (global-symbol-macro-definition (get s 'SYMBOLMACRO))

Index: NEWS
===================================================================
RCS file: /cvsroot/clisp/clisp/src/NEWS,v
retrieving revision 1.234
retrieving revision 1.235
diff -u -d -r1.234 -r1.235
--- NEWS	28 Jan 2005 14:05:31 -0000	1.234
+++ NEWS	29 Jan 2005 15:02:36 -0000	1.235
@@ -254,6 +254,10 @@
   LOAD can now ignore erroneous forms using SKIP and STOP restarts.
   See <http://clisp.cons.org/impnotes.html#loadfile> for details.
 
+* References from within macros defined through MACROLET to variables or
+  functions defined in the lexical environment outside the MACROLET form
+  now signal an error. Previously, this resulted in undefined behaviour.
+
 * The FFI recognizes the c-type declaration (C-POINTER <c-type>) to
   handle references without conversion to/from Lisp structures.
   See <http://clisp.cons.org/impnotes.html#c-pointer> for details.

Index: eval.d
===================================================================
RCS file: /cvsroot/clisp/clisp/src/eval.d,v
retrieving revision 1.187
retrieving revision 1.188
diff -u -d -r1.187 -r1.188
--- eval.d	28 Jan 2005 14:09:12 -0000	1.187
+++ eval.d	29 Jan 2005 15:02:32 -0000	1.188
@@ -771,21 +771,41 @@
     }
     venv = FRAME_(frame_next_env);
     goto next_env;
-  } else if (simple_vector_p(venv)) { /* environment is a simple-vector */
-    do {
+  }
+  var bool from_inside_macrolet = false;
+  for (;;) {
+    if (simple_vector_p(venv)) {
+      /* environment is a simple-vector */
       var uintL count = floor(Svector_length(venv),2); /* number of bindings */
       var gcv_object_t* ptr = &TheSvector(venv)->data[0];
       dotimesL(count,count, {
-        if (eq(*ptr,sym)) /* right symbol? */
+        if (eq(*ptr,sym)) { /* right symbol? */
+          if (from_inside_macrolet && !eq(*(ptr+1),specdecl)
+              && !symbolmacrop(*(ptr+1)))
+            goto macrolet_error;
           return ptr+1;
+        }
         ptr += 2; /* next binding */
       });
       venv = *ptr; /* next environment */
-    } while (simple_vector_p(venv));
+      continue;
+    } elif (consp(venv)) {
+      /* environment is a MACROLET capsule */
+      ASSERT(eq(Car(venv),S(macrolet)));
+      from_inside_macrolet = true;
+      venv = Cdr(venv);
+      continue;
+    } else
+      break;
   }
   /* Environment is NIL */
   return NULL;
 #undef binds_sym_p
+ macrolet_error:
+  pushSTACK(sym); /* SOURCE-PROGRAM-ERROR slot DETAIL */
+  pushSTACK(S(macrolet)); pushSTACK(sym);
+  fehler(program_error,
+         GETTEXT("Invalid access to the value of the lexical variable ~S from within a ~S definition"));
 }
 
 /* (SYS::SPECIAL-VARIABLE-P symbol &optional environment)
@@ -924,27 +944,33 @@
         }
         env = FRAME_(frame_next_env);
         goto next_env;
-      } elif (simple_vector_p(env))
-        # Environment is a Simple-Vector
-        goto next_vector;
-      else
-        # Environment is NIL
-        goto global_value;
-     next_vector:
-      # Environment is a Simple-Vector
-      {
-        var uintL count = floor(Svector_length(env),2); # number of bindings
-        var gcv_object_t* ptr = &TheSvector(env)->data[0];
-        dotimesL(count,count, {
-          if (equal(*ptr,sym)) { # right Symbol?
-            value = *(ptr+1); goto fertig;
-          }
-          ptr += 2; # next binding
-        });
-        env = *ptr; # next Environment
-        if (simple_vector_p(env)) # a Simple-Vector?
-          goto next_vector;
-        # else: Environment is NIL
+      }
+      var bool from_inside_macrolet = false;
+      for (;;) {
+        if (simple_vector_p(env)) {
+          # Environment is a Simple-Vector
+          var uintL count = floor(Svector_length(env),2); # number of bindings
+          var gcv_object_t* ptr = &TheSvector(env)->data[0];
+          dotimesL(count,count, {
+            if (equal(*ptr,sym)) { # right Symbol?
+              value = *(ptr+1);
+              if (from_inside_macrolet && !macrop(value))
+                goto macrolet_error;
+              goto fertig;
+            }
+            ptr += 2; # next binding
+          });
+          env = *ptr; # next Environment
+          continue;
+        } elif (consp(env)) {
+          /* environment is a MACROLET capsule */
+          ASSERT(eq(Car(env),S(macrolet)));
+          from_inside_macrolet = true;
+          env = Cdr(env);
+          continue;
+        } else
+          # Environment is NIL
+          goto global_value;
       }
     }
    global_value: # global function-definition
@@ -961,6 +987,11 @@
     if (nullp(value))
       value = unbound;
     return value;
+   macrolet_error:
+    pushSTACK(sym); /* SOURCE-PROGRAM-ERROR slot DETAIL */
+    pushSTACK(S(macrolet)); pushSTACK(sym);
+    fehler(source_program_error,
+           GETTEXT("Invalid access to the local function definition of ~S from within a ~S definition"));
   }
 
 # UP: evaluates a Form in a given Environment.

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v
retrieving revision 1.4174
retrieving revision 1.4175
diff -u -d -r1.4174 -r1.4175
--- ChangeLog	29 Jan 2005 14:59:43 -0000	1.4174
+++ ChangeLog	29 Jan 2005 15:02:37 -0000	1.4175
@@ -1,3 +1,18 @@
+2005-01-22  Bruno Haible  <br...@cl...>
+
+	Improved error checking for the handling of references from local macro
+	definitions to bindings and declarations in the outer lexical
+	environment.
+	* control.d (macrolet): Add a marker to the venv and fenv being
+	passed to make-macro-expander.
+	* defmacro.lisp (make-macro-expander): Add a marker to the venv and
+	fenv being constructed.
+	* eval.d (symbol_env_search, sym_function): Respect the MACROLET
+	markers. Signal an error if an invalid reference from inside a
+	macroexpander is seen.
+	* init.lisp (fenv-assoc, venv-assoc): Likewise.
+	* compiler.lisp (fenv-search, venv-search): Likewise.
+
 2005-01-27  Bruno Haible  <br...@cl...>
 
 	* clos-class3.lisp (checked-compute-slots): Tweak an error message.

Index: control.d
===================================================================
RCS file: /cvsroot/clisp/clisp/src/control.d,v
retrieving revision 1.124
retrieving revision 1.125
diff -u -d -r1.124 -r1.125
--- control.d	25 Jan 2005 14:35:11 -0000	1.124
+++ control.d	29 Jan 2005 15:02:31 -0000	1.125
@@ -1021,6 +1021,16 @@
     pushSTACK(NIL);
     {
       aktenv_to_stack();
+      { /* Add a MACROLET cons to the venv part of env: */
+        var object new_cons = allocate_cons();
+        Car(new_cons) = S(macrolet); Cdr(new_cons) = STACK_4;
+        STACK_4 = new_cons;
+      }
+      { /* Add a MACROLET cons to the fenv part of env: */
+        var object new_cons = allocate_cons();
+        Car(new_cons) = S(macrolet); Cdr(new_cons) = STACK_3;
+        STACK_3 = new_cons;
+      }
       var object vec = vectorof(5);
       pushSTACK(vec);
     }
@@ -1081,7 +1091,7 @@
       Car(macrodef) = STACK_2; Cdr(macrodef) = STACK_0;
       pushSTACK(macrodef); pushSTACK(NIL); funcall(S(make_macro_expander),2);
       pushSTACK(value1); C_macro_expander();
-        STACK_0 = value1;
+      STACK_0 = value1;
     }
     /* collect both: */
     C_make_function_macro();



--__--__--

Message: 5
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/src macros2.lisp,1.32,1.33 ChangeLog,1.4175,1.4176
Date: Sat, 29 Jan 2005 15:04:47 +0000
Reply-To: cli...@li...

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

Modified Files:
	macros2.lisp ChangeLog 
Log Message:
Fix a scoping problem in with-output-to-string.


Index: macros2.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/src/macros2.lisp,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -d -r1.32 -r1.33
--- macros2.lisp	26 Jan 2005 13:39:07 -0000	1.32
+++ macros2.lisp	29 Jan 2005 15:04:36 -0000	1.33
@@ -327,15 +327,17 @@
          (CLOSE ,var :ABORT T)))))
 ;; ----------------------------------------------------------------------------
 (defmacro with-output-to-string ((var &optional (string nil)
-                                      &key (element-type ''CHARACTER))
+                                  &key (element-type ''CHARACTER))
                                  &body body)
   (multiple-value-bind (body-rest declarations) (SYSTEM::PARSE-BODY body)
     (if string
-      `(LET ((,var (SYS::MAKE-STRING-PUSH-STREAM ,string)))
-         (DECLARE (READ-ONLY ,var) ,@declarations)
-         (UNWIND-PROTECT
-           (PROGN ,element-type ,@(or body-rest '(NIL)))
-           (CLOSE ,var)))
+      (let ((ignored-var (gensym)))
+        `(LET ((,var (SYS::MAKE-STRING-PUSH-STREAM ,string))
+               (,ignored-var ,element-type))
+           (DECLARE (READ-ONLY ,var) (IGNORE ,ignored-var) ,@declarations)
+           (UNWIND-PROTECT
+             (PROGN ,@body-rest)
+             (CLOSE ,var))))
       `(LET ((,var (MAKE-STRING-OUTPUT-STREAM :ELEMENT-TYPE ,element-type)))
          (DECLARE (READ-ONLY ,var) ,@declarations)
          (UNWIND-PROTECT

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v
retrieving revision 1.4175
retrieving revision 1.4176
diff -u -d -r1.4175 -r1.4176
--- ChangeLog	29 Jan 2005 15:02:37 -0000	1.4175
+++ ChangeLog	29 Jan 2005 15:04:41 -0000	1.4176
@@ -1,3 +1,9 @@
+2005-01-23  Bruno Haible  <br...@cl...>
+
+	* macros2.lisp (with-output-to-string): Evaluate the element-type
+	form outside, not inside, the scope of the declarations.
+	Found by Paul Dietz's ansi-tests test suite.
+
 2005-01-22  Bruno Haible  <br...@cl...>
 
 	Improved error checking for the handling of references from local macro



--__--__--

Message: 6
From: Bruno Haible <ha...@us...>
To: cli...@li...
Subject: clisp/src foreign1.lisp,1.80,1.81 ChangeLog,1.4176,1.4177
Date: Sat, 29 Jan 2005 15:07:00 +0000
Reply-To: cli...@li...

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

Modified Files:
	foreign1.lisp ChangeLog 
Log Message:
Fix the declaration handling in with-defining-c-type.


Index: foreign1.lisp
===================================================================
RCS file: /cvsroot/clisp/clisp/src/foreign1.lisp,v
retrieving revision 1.80
retrieving revision 1.81
diff -u -d -r1.80 -r1.81
--- foreign1.lisp	26 Jan 2005 13:39:07 -0000	1.80
+++ foreign1.lisp	29 Jan 2005 15:06:56 -0000	1.81
@@ -172,21 +172,28 @@
                            ,ivar)))))))))))
 
 (defmacro with-name/options ((name options name+options) &body body)
-  (let ((no (gensym "NAME+OPTIONS-")))
-    `(let ((,no ,name+options))
-       (multiple-value-bind (,name ,options)
-           (if (consp ,no) (values (first ,no) (rest ,no)) (values ,no nil))
-         (declare (ignorable ,name ,options))
-         ,@body))))
+  (multiple-value-bind (body-rest declarations) (system::parse-body body)
+    (let ((no (gensym "NAME+OPTIONS-")))
+      `(LET ((,no ,name+options))
+         (MULTIPLE-VALUE-BIND (,name ,options)
+             (IF (CONSP ,no) (VALUES (FIRST ,no) (REST ,no)) (VALUES ,no NIL))
+           (DECLARE (IGNORABLE ,name ,options) ,@declarations)
+           ,@body-rest)))))
 
 (defmacro with-defining-c-type ((name c-type len) &body body)
-  `(let ((,c-type (make-array ,len)))
-    (unwind-protect
-         (progn (when ,name (setf (gethash ,name *c-type-table*) ,c-type))
-                ,@body)
-      (when ,name (setf (gethash ,name *c-type-table*) nil)))
-    (when ,name (setf (gethash ,name *c-type-table*) ,c-type))
-    ,c-type))
+  (multiple-value-bind (body-rest declarations) (system::parse-body body)
+    `(LET ((,c-type (MAKE-ARRAY ,len)))
+       ,@(if declarations `((DECLARE ,@declarations)))
+       (UNWIND-PROTECT
+           (PROGN
+             (WHEN ,name
+               (SETF (GETHASH ,name *C-TYPE-TABLE*) ,c-type))
+             ,@body-rest)
+         (WHEN ,name
+           (SETF (GETHASH ,name *C-TYPE-TABLE*) NIL)))
+       (WHEN ,name
+         (SETF (GETHASH ,name *C-TYPE-TABLE*) ,c-type))
+       ,c-type)))
 
 ;; Parse a C type specification.
 ;; If name is non-NIL, it will be assigned to name.

Index: ChangeLog
===================================================================
RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v
retrieving revision 1.4176
retrieving revision 1.4177
diff -u -d -r1.4176 -r1.4177
--- ChangeLog	29 Jan 2005 15:04:41 -0000	1.4176
+++ ChangeLog	29 Jan 2005 15:06:56 -0000	1.4177
@@ -1,5 +1,10 @@
 2005-01-23  Bruno Haible  <br...@cl...>
 
+	* foreign1.lisp (with-defining-c-type): Put the declarations from
+	the body at the right place, so they can affect the c-type binding.
+
+2005-01-23  Bruno Haible  <br...@cl...>
+
 	* macros2.lisp (with-output-to-string): Evaluate the element-type
 	form outside, not inside, the scope of the declarations.
 	Found by Paul Dietz's ansi-tests test suite.




--__--__--

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


End of clisp-cvs Digest