Mercurial > hg > xemacs-beta

changeset 5328:dae3d95cf319

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 02 Jan 2011 02:32:59 +0000
parents 60ba780f9078 (diff) d1b17a33450b (current diff)
children 7b391d07b334
files lisp/ChangeLog src/ChangeLog
diffstat 5 files changed, 108 insertions(+), 75 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Thu Dec 30 01:59:52 2010 +0000
+++ b/lisp/ChangeLog	Sun Jan 02 02:32:59 2011 +0000
@@ -1,3 +1,19 @@
+2011-01-01  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* cl-macs.el (dolist, dotimes, do-symbols, macrolet)
+	(symbol-macrolet):
+	Define these macros with defmacro* instead of parsing the argument
+	list by hand, for the sake of style and readability; use backquote
+	where appropriate, instead of calling #'list and and friends, for
+	the same reason.
+
+2010-12-30  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* x-misc.el (device-x-display):
+	Provide this function, documented in the Lispref for years, but
+	not existing previously.  Thank you Julian Bradfield, thank you
+	Jeff Mincy.
+
 2010-12-30  Aidan Kehoe  <kehoea@parhasard.net>
 
 	* cl-seq.el:
--- a/lisp/cl-macs.el	Thu Dec 30 01:59:52 2010 +0000
+++ b/lisp/cl-macs.el	Sun Jan 02 02:32:59 2011 +0000
@@ -1679,51 +1679,42 @@
 	       (or (cdr endtest) '(nil)))))
 
 ;;;###autoload
-(defmacro dolist (spec &rest body)
+(defmacro* dolist ((var list &optional result) &body body)
   "Loop over a list.
 Evaluate BODY with VAR bound to each `car' from LIST, in turn.
-Then evaluate RESULT to get return value, default nil.
-
-arguments: ((VAR LIST &optional RESULT) &body BODY)"
-  (let ((temp (gensym "--dolist-temp--")))
-    (list 'block nil
-	  (list* 'let (list (list temp (nth 1 spec)) (car spec))
-		 (list* 'while temp (list 'setq (car spec) (list 'car temp))
-			(append body (list (list 'setq temp
-						 (list 'cdr temp)))))
-		 (if (cdr (cdr spec))
-		     (cons (list 'setq (car spec) nil) (cdr (cdr spec)))
-		   '(nil))))))
+Then evaluate RESULT to get return value, default nil."
+  (let ((gensym (gensym)))
+    `(block nil
+      (let ((,gensym ,list) ,var)
+        (while ,gensym
+          (setq ,var (car ,gensym))
+          ,@body
+          (setq ,gensym (cdr ,gensym)))
+        ,@(if result `((setq ,var nil) ,result))))))
 
 ;;;###autoload
-(defmacro dotimes (spec &rest body)
+(defmacro* dotimes ((var count &optional result) &body body)
   "Loop a certain number of times.
 Evaluate BODY with VAR bound to successive integers from 0, inclusive,
 to COUNT, exclusive.  Then evaluate RESULT to get return value, default
-nil.
-
-arguments: ((VAR COUNT &optional RESULT) &body BODY)"
-  (let ((temp (gensym "--dotimes-temp--")))
-    (list 'block nil
-	  (list* 'let (list (list temp (nth 1 spec)) (list (car spec) 0))
-		 (list* 'while (list '< (car spec) temp)
-			(append body (list (list 'incf (car spec)))))
-		 (or (cdr (cdr spec)) '(nil))))))
+nil."
+  (let* ((limit (if (cl-const-expr-p count) count (gensym)))
+         (bind (if (cl-const-expr-p count) nil `((,limit ,count)))))
+    `(block nil
+      (let ((,var 0) ,@bind)
+        (while (< ,var ,limit)
+          ,@body
+          (setq ,var (1+ ,var)))
+        ,@(if result (list result))))))
 
 ;;;###autoload
-(defmacro do-symbols (spec &rest body)
-  "Loop over all symbols.
+(defmacro* do-symbols ((var &optional obarray result) &rest body)
+  "Loop over all interned symbols.
 Evaluate BODY with VAR bound to each interned symbol, or to each symbol
-from OBARRAY.
-
-arguments: ((VAR &optional OBARRAY RESULT) &body BODY)"
-  ;; Apparently this doesn't have an implicit block.
-  (list 'block nil
-	(list 'let (list (car spec))
-	      (list* 'mapatoms
-		     (list 'function (list* 'lambda (list (car spec)) body))
-		     (and (cadr spec) (list (cadr spec))))
-	      (caddr spec))))
+from OBARRAY."
+  `(block nil
+    (mapatoms #'(lambda (,var) ,@body) ,@(and obarray (list obarray)))
+    ,@(if result `((let (,var) ,result)))))
 
 ;;;###autoload
 (defmacro do-all-symbols (spec &rest body)
@@ -1806,37 +1797,34 @@
 ;; The following ought to have a better definition for use with newer
 ;; byte compilers.
 ;;;###autoload
-(defmacro macrolet (bindings &rest body)
+(defmacro* macrolet (((name arglist &optional docstring &body body)
+                       &rest macros) &body form)
   "Make temporary macro definitions.
-This is like `flet', but for macros instead of functions.
-
-arguments: (((NAME ARGLIST &optional DOCSTRING &body body) &rest MACROS) &body FORM)"
-  (if (cdr bindings)
-      (list 'macrolet
-	    (list (car bindings)) (list* 'macrolet (cdr bindings) body))
-    (if (null bindings) (cons 'progn body)
-      (let* ((name (caar bindings))
-	     (res (cl-transform-lambda (cdar bindings) name)))
-	(eval (car res))
-	(cl-macroexpand-all (cons 'progn body)
-			    (cons (list* name 'lambda (cdr res))
-				  cl-macro-environment))))))
+This is like `flet', but for macros instead of functions."
+  (cl-macroexpand-all (cons 'progn form)
+                      (nconc
+                       (loop
+                         for (name . details)
+                         in (cons (list* name arglist docstring body) macros)
+                         collect
+                         (list* name 'lambda
+                                (prog1
+                                    (cdr (setq details (cl-transform-lambda
+                                                        details name)))
+                                  (eval (car details)))))
+                       cl-macro-environment)))
 
 ;;;###autoload
-(defmacro symbol-macrolet (bindings &rest body)
+(defmacro* symbol-macrolet (((name expansion) &rest symbol-macros) &body form)
   "Make symbol macro definitions.
 Within the body FORMs, references to the variable NAME will be replaced
-by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...).
-
-arguments: (((NAME EXPANSION) &rest SYMBOL-MACROS) &body FORM)"
-  (if (cdr bindings)
-      (list 'symbol-macrolet
-	    (list (car bindings)) (list* 'symbol-macrolet (cdr bindings) body))
-    (if (null bindings) (cons 'progn body)
-      (cl-macroexpand-all (cons 'progn body)
-			  (cons (list (symbol-name (caar bindings))
-				      (cadar bindings))
-				cl-macro-environment)))))
+by EXPANSION, and (setq NAME ...) will act like (setf EXPANSION ...)."
+  (cl-macroexpand-all (cons 'progn form)
+                      (append (list (list (symbol-name name) expansion))
+                              (loop
+                                for (name expansion) in symbol-macros
+                                collect (list (symbol-name name) expansion))
+                              cl-macro-environment)))
 
 (defvar cl-closure-vars nil)
 ;;;###autoload
--- a/lisp/x-misc.el	Thu Dec 30 01:59:52 2010 +0000
+++ b/lisp/x-misc.el	Sun Jan 02 02:32:59 2011 +0000
@@ -86,4 +86,10 @@
       (x-bogosity-check-resource name class type))
   (x-get-resource name class type locale nil 'warn))
 
+(defun device-x-display (&optional device)
+  "If DEVICE is an X11 device, return its DISPLAY.
+
+DEVICE defaults to the selected device."
+  (and (eq 'x (device-type device)) (device-connection device)))
+
 ;;; x-misc.el ends here
--- a/src/ChangeLog	Thu Dec 30 01:59:52 2010 +0000
+++ b/src/ChangeLog	Sun Jan 02 02:32:59 2011 +0000
@@ -1,3 +1,9 @@
+2011-01-01  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* data.c (print_ephemeron, print_weak_list, print_weak_box):
+	Be more helpful in printing these structures; show their contents,
+	print their UIDs so it's possible to distinguish between them.
+
 2010-12-30  Aidan Kehoe  <kehoea@parhasard.net>
 
 	Move the heavy lifting from cl-seq.el to C, finally making those
--- a/src/data.c	Thu Dec 30 01:59:52 2010 +0000
+++ b/src/data.c	Sun Jan 02 02:32:59 2011 +0000
@@ -2612,14 +2612,19 @@
 
 static void
 print_weak_list (Lisp_Object obj, Lisp_Object printcharfun,
-		 int UNUSED (escapeflag))
+		 int escapeflag)
 {
   if (print_readably)
-    printing_unreadable_lisp_object (obj, 0);
-
-  write_fmt_string_lisp (printcharfun, "#<weak-list %s %S>", 2,
-			 encode_weak_list_type (XWEAK_LIST (obj)->type),
-			 XWEAK_LIST (obj)->list);
+    {
+      printing_unreadable_lisp_object (obj, 0);
+    }
+
+  write_ascstring (printcharfun, "#<weak-list :type ");
+  print_internal (encode_weak_list_type (XWEAK_LIST (obj)->type),
+                  printcharfun, escapeflag);
+  write_ascstring (printcharfun, " :list ");
+  print_internal (XWEAK_LIST (obj)->list, printcharfun, escapeflag);
+  write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj));
 }
 
 static int
@@ -3087,12 +3092,16 @@
 }
 
 static void
-print_weak_box (Lisp_Object obj, Lisp_Object printcharfun,
-		int UNUSED (escapeflag))
+print_weak_box (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
   if (print_readably)
-    printing_unreadable_lisp_object (obj, 0);
-  write_fmt_string (printcharfun, "#<weak-box>"); /* #### fix */
+    {
+      printing_unreadable_lisp_object (obj, 0);
+    }
+
+  write_ascstring (printcharfun, "#<weak-box ");
+  print_internal (XWEAK_BOX (obj)->value, printcharfun, escapeflag);
+  write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj));
 }
 
 static int
@@ -3309,12 +3318,20 @@
 }
 
 static void
-print_ephemeron (Lisp_Object obj, Lisp_Object printcharfun,
-		 int UNUSED (escapeflag))
+print_ephemeron (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
 {
   if (print_readably)
-    printing_unreadable_lisp_object (obj, 0);
-  write_fmt_string (printcharfun, "#<ephemeron>"); /* #### fix */
+    {
+      printing_unreadable_lisp_object (obj, 0);
+    }
+
+  write_ascstring (printcharfun, "#<ephemeron :key ");
+  print_internal (XEPHEMERON (obj)->key, printcharfun, escapeflag);
+  write_ascstring (printcharfun, " :value ");
+  print_internal (XEPHEMERON (obj)->value, printcharfun, escapeflag);
+  write_ascstring (printcharfun, " :finalizer ");
+  print_internal (XEPHEMERON_FINALIZER (obj), printcharfun, escapeflag);
+  write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj));
 }
 
 static int