Mercurial > hg > xemacs-beta

changeset 4807:41852ee5f1b0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Merge.
author Aidan Kehoe <kehoea@parhasard.net>
date Thu, 07 Jan 2010 17:01:25 +0000
parents 980575c76541 (current diff) fd36a980d701 (diff)
children 53071486ff7a 6f84332672fb
files lisp/ChangeLog src/ChangeLog src/mule-charset.c
diffstat 9 files changed, 210 insertions(+), 152 deletions(-) [+]
line wrap: on
line diff
--- a/lisp/ChangeLog	Thu Jan 07 15:52:10 2010 +0000
+++ b/lisp/ChangeLog	Thu Jan 07 17:01:25 2010 +0000
@@ -110,6 +110,18 @@
 	that they are *that* fast, for most of the coding systems they're
 	used a minority of the time.
 
+2010-01-01  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* syntax.el (map-syntax-table):
+	* subr.el (map-plist):
+	* startup.el (load-init-file):
+	* minibuf.el (read-from-minbuffer):
+	* cus-edit.el (custom-load-custom-defines-1):
+	* cmdloop.el (execute-extended-command):
+	Replace symbol names using underscore, whether to avoid dynamic
+	scope problems or to ensure helpful arguments to
+	#'call-with-condition-handler, with uninterned symbols.
+
 2009-12-05  Stephen J. Turnbull  <stephen@xemacs.org>
 
 	* font.el (x-font-create-object): Check for Xft before using it.
--- a/lisp/cmdloop.el	Thu Jan 07 15:52:10 2010 +0000
+++ b/lisp/cmdloop.el	Thu Jan 07 17:01:25 2010 +0000
@@ -344,35 +344,36 @@
   (if (and teach-extended-commands-p
 	   (interactive-p))
       ;; Remember the keys, run the command, and show the keys (if
-      ;; any).  The funny variable names are a poor man's guarantee
-      ;; that we don't get tripped by this-command doing something
-      ;; funny.  Quoth our forefathers: "We want lexical scope!"
-      (let ((_execute_command_keys_ (where-is-internal this-command))
-	    (_execute_command_name_ this-command)) ; the name can change
-	(command-execute this-command t)
-	(when _execute_command_keys_
-	  ;; Normally the region is adjusted in post_command_hook;
-	  ;; however, it is not called until after we finish.  It
-	  ;; looks ugly for the region to get updated after the
-	  ;; delays, so we do it now.  The code below is a Lispified
-	  ;; copy of code in event-stream.c:post_command_hook().
-	  (if (and (not zmacs-region-stays)
-		   (or (not (eq (selected-window) (minibuffer-window)))
-		       (eq (zmacs-region-buffer) (current-buffer))))
-	      (zmacs-deactivate-region)
-	    (zmacs-update-region))
-	  ;; Wait for a while, so the user can see a message printed,
-	  ;; if any.
-	  (when (sit-for 1)
-	    (display-message
-		'no-log
-	      (format (if (cdr _execute_command_keys_)
-			  "Command `%s' is bound to keys: %s"
-			"Command `%s' is bound to key: %s")
-		      _execute_command_name_
-		      (sorted-key-descriptions _execute_command_keys_)))
-	    (sit-for teach-extended-commands-timeout)
-	    (clear-message 'no-log))))
+      ;; any).  The symbol-macrolet avoids some lexical-scope lossage.
+      (symbol-macrolet
+	  ((execute-command-keys #:execute-command-keys)
+	   (execute-command-name #:execute-command-name))
+	(let ((execute-command-keys (where-is-internal this-command))
+	      (execute-command-name this-command)) ; the name can change
+	  (command-execute this-command t)
+	  (when execute-command-keys
+	    ;; Normally the region is adjusted in post_command_hook;
+	    ;; however, it is not called until after we finish.  It
+	    ;; looks ugly for the region to get updated after the
+	    ;; delays, so we do it now.  The code below is a Lispified
+	    ;; copy of code in event-stream.c:post_command_hook().
+	    (if (and (not zmacs-region-stays)
+		     (or (not (eq (selected-window) (minibuffer-window)))
+			 (eq (zmacs-region-buffer) (current-buffer))))
+		(zmacs-deactivate-region)
+	      (zmacs-update-region))
+	    ;; Wait for a while, so the user can see a message printed,
+	    ;; if any.
+	    (when (sit-for 1)
+	      (display-message
+		  'no-log
+		(format (if (cdr execute-command-keys)
+			    "Command `%s' is bound to keys: %s"
+			  "Command `%s' is bound to key: %s")
+			execute-command-name
+			(sorted-key-descriptions execute-command-keys)))
+	      (sit-for teach-extended-commands-timeout)
+	      (clear-message 'no-log)))))
     ;; Else, just run the command.
     (command-execute this-command t)))
 
--- a/lisp/cus-edit.el	Thu Jan 07 15:52:10 2010 +0000
+++ b/lisp/cus-edit.el	Thu Jan 07 17:01:25 2010 +0000
@@ -1779,31 +1779,39 @@
 	   ;; Use call-with-condition-handler so the error can be seen
 	   ;; with the stack intact.
 	   (call-with-condition-handler
-	       #'(lambda (__custom_load_cd1__)
-		   (when (and
-			  custom-define-current-source-file
-			  (progn
-			    (setq source (expand-file-name
-					  custom-define-current-source-file
-					  dir))
-			    (let ((nondir (file-name-nondirectory source)))
-			      (and (file-exists-p source)
-				   (not (assoc source load-history))
-				   (not (assoc nondir load-history))
-				   (not (and (boundp 'preloaded-file-list)
-					     (member nondir
-						     preloaded-file-list)))))))
-		     (if custom-warn-when-reloading-necessary
-			 (lwarn 'custom-defines 'warning
-			   "Error while loading custom-defines, fetching source and reloading ...\n
+	       ((macro
+		 . (lambda (lambda-expression)
+		     ;; Be more serious about information hiding here:
+		     (nsublis
+		      '((custom-load-handler-arg . #:custom-load-g9JBHiZHD))
+		      lambda-expression)))
+		#'(lambda (custom-load-handler-arg)
+		    (when (and
+			   custom-define-current-source-file
+			   (progn
+			     (setq source (expand-file-name
+					   custom-define-current-source-file
+					   dir))
+			     (let ((nondir (file-name-nondirectory source)))
+			       (and (file-exists-p source)
+				    (not (assoc source load-history))
+				    (not (assoc nondir load-history))
+				    (not (and (boundp 'preloaded-file-list)
+					      (member nondir
+						      preloaded-file-list)))))))
+		      (if custom-warn-when-reloading-necessary
+			  (lwarn 'custom-defines 'warning
+			    "Error while loading custom-defines, fetching \
+source and reloading ...\n
 Error: %s\n
 Source file: %s\n\n
 Backtrace follows:\n\n%s"
-			   (error-message-string __custom_load_cd1__)
-			   source
-			   (backtrace-in-condition-handler-eliminating-handler
-			    '__custom_load_cd1__)))
-		     (return-from custom-load nil)))
+			    (error-message-string custom-load-handler-arg)
+			    source
+			    (backtrace-in-condition-handler-eliminating-handler
+			     'custom-load-handler-arg
+)))
+		      (return-from custom-load nil))))
 	       #'(lambda ()
 		   (load (expand-file-name "custom-defines" dir))))))
       ;; we get here only from the `return-from'; see above
--- a/lisp/minibuf.el	Thu Jan 07 15:52:10 2010 +0000
+++ b/lisp/minibuf.el	Thu Jan 07 17:01:25 2010 +0000
@@ -344,13 +344,16 @@
 
 (define-error 'input-error "Keyboard input error" 'io-error)
 
-(defun read-from-minibuffer (prompt &optional initial-contents
-                                    keymap
-                                    readp
-                                    history
-				    abbrev-table
-				    default)
-  "Read a string from the minibuffer, prompting with string PROMPT.
+((macro
+  . (lambda (read-from-minibuffer-definition)
+      (nsublis
+       ;; `M-x doctor' makes (the interned) history a local variable, use an
+       ;; uninterned symbol here so we don't interact with it.
+       '((history . #:history))
+       read-from-minibuffer-definition)))
+ (defun read-from-minibuffer (prompt &optional initial-contents keymap
+			      readp history abbrev-table default)
+   "Read a string from the minibuffer, prompting with string PROMPT.
 If optional second arg INITIAL-CONTENTS is non-nil, it is a string
   to be inserted into the minibuffer before reading input.
   If INITIAL-CONTENTS is (STRING . POSITION), the initial input
@@ -376,50 +379,45 @@
 
 See also the variable `completion-highlight-first-word-only' for
   control over completion display."
-  (if (and (not enable-recursive-minibuffers)
-           (> (minibuffer-depth) 0)
-           (eq (selected-window) (minibuffer-window)))
-      (error "Command attempted to use minibuffer while in minibuffer"))
+   (if (and (not enable-recursive-minibuffers)
+	    (> (minibuffer-depth) 0)
+	    (eq (selected-window) (minibuffer-window)))
+       (error "Command attempted to use minibuffer while in minibuffer"))
 
-  (if (and minibuffer-max-depth
-	   (> minibuffer-max-depth 0)
-           (>= (minibuffer-depth) minibuffer-max-depth))
-      (minibuffer-max-depth-exceeded))
+   (if (and minibuffer-max-depth
+	    (> minibuffer-max-depth 0)
+	    (>= (minibuffer-depth) minibuffer-max-depth))
+       (minibuffer-max-depth-exceeded))
 
-  ;; catch this error before the poor user has typed something...
-  (if history
-      (if (symbolp history)
-	  (or (boundp history)
-	      (error "History list %S is unbound" history))
-	(or (boundp (car history))
-	    (error "History list %S is unbound" (car history)))))
+   ;; catch this error before the poor user has typed something...
+   (if history
+       (if (symbolp history)
+	   (or (boundp history)
+	       (error "History list %S is unbound" history))
+	 (or (boundp (car history))
+	     (error "History list %S is unbound" (car history)))))
 
-  (if (noninteractive)
-      (progn
-        ;; XEmacs in -batch mode calls minibuffer: print the prompt.
-        (message "%s" (gettext prompt))
-        ;;#### force-output
+   (if (noninteractive)
+       (progn
+	 ;; XEmacs in -batch mode calls minibuffer: print the prompt.
+	 (message "%s" (gettext prompt))
+	 ;;#### force-output
 
-        ;;#### Should this even be falling though to the code below?
-        ;;#### How does this stuff work now, anyway?
-        ))
-  (let* ((dir default-directory)
-         (owindow (selected-window))
-	 (oframe (selected-frame))
-         (window (minibuffer-window))
-         (buffer (get-buffer-create (format " *Minibuf-%d*"
-					    (minibuffer-depth))))
-         (frame (window-frame window))
-         (mconfig (if (eq frame (selected-frame))
-                      nil (current-window-configuration frame)))
-         (oconfig (current-window-configuration))
-	 ;; dynamic scope sucks sucks sucks sucks sucks sucks.
-	 ;; `M-x doctor' makes history a local variable, and thus
-	 ;; our binding above is buffer-local and doesn't apply
-	 ;; once we switch buffers!!!!  We demand better scope!
-	 (_history_ history)
-	 (minibuffer-default default))
-    (unwind-protect
+	 ;;#### Should this even be falling though to the code below?
+	 ;;#### How does this stuff work now, anyway?
+	 ))
+   (let* ((dir default-directory)
+	  (owindow (selected-window))
+	  (oframe (selected-frame))
+	  (window (minibuffer-window))
+	  (buffer (get-buffer-create (format " *Minibuf-%d*"
+					     (minibuffer-depth))))
+	  (frame (window-frame window))
+	  (mconfig (if (eq frame (selected-frame))
+		       nil (current-window-configuration frame)))
+	  (oconfig (current-window-configuration))
+	  (minibuffer-default default))
+     (unwind-protect
          (progn
            (set-buffer (reset-buffer buffer))
            (setq default-directory dir)
@@ -462,14 +460,14 @@
 		       (current-buffer)))
                  (current-prefix-arg current-prefix-arg)
 ;;                 (help-form minibuffer-help-form)
-                 (minibuffer-history-variable (cond ((not _history_)
+                 (minibuffer-history-variable (cond ((not history)
                                                      'minibuffer-history)
-                                                    ((consp _history_)
-                                                     (car _history_))
+                                                    ((consp history)
+                                                     (car history))
                                                     (t
-                                                     _history_)))
-                 (minibuffer-history-position (cond ((consp _history_)
-                                                     (cdr _history_))
+                                                     history)))
+                 (minibuffer-history-position (cond ((consp history)
+                                                     (cdr history))
                                                     (t
                                                      0)))
                  (minibuffer-scroll-window owindow))
@@ -479,16 +477,16 @@
 		 (setq local-abbrev-table abbrev-table
 		       abbrev-mode t))
 	     ;; This is now run from read-minibuffer-internal
-             ;(if minibuffer-setup-hook
-             ;    (run-hooks 'minibuffer-setup-hook))
-             ;(message nil)
+					;(if minibuffer-setup-hook
+					;    (run-hooks 'minibuffer-setup-hook))
+					;(message nil)
              (if (eq 't
                      (catch 'exit
                        (if (> (recursion-depth) (minibuffer-depth))
                            (let ((standard-output t)
                                  (standard-input t))
                              (read-minibuffer-internal prompt))
-                           (read-minibuffer-internal prompt))))
+			 (read-minibuffer-internal prompt))))
                  ;; Translate an "abort" (throw 'exit 't)
                  ;;  into a real quit
                  (signal 'quit '())
@@ -538,21 +536,20 @@
 				  (cons histval list))))))
                  (if err (signal (car err) (cdr err)))
                  val))))
-      ;; stupid display code requires this for some reason
-      (set-buffer buffer)
-      (buffer-disable-undo buffer)
-      (setq buffer-read-only nil)
-      (erase-buffer)
+       ;; stupid display code requires this for some reason
+       (set-buffer buffer)
+       (buffer-disable-undo buffer)
+       (setq buffer-read-only nil)
+       (erase-buffer)
 
-      ;; restore frame configurations
-      (if (and mconfig (frame-live-p oframe)
-	       (eq frame (selected-frame)))
-	  ;; if we changed frames (due to surrogate minibuffer),
-	  ;; and we're still on the new frame, go back to the old one.
-	  (select-frame oframe))
-      (if mconfig (set-window-configuration mconfig))
-      (set-window-configuration oconfig))))
-
+       ;; restore frame configurations
+       (if (and mconfig (frame-live-p oframe)
+		(eq frame (selected-frame)))
+	   ;; if we changed frames (due to surrogate minibuffer),
+	   ;; and we're still on the new frame, go back to the old one.
+	   (select-frame oframe))
+       (if mconfig (set-window-configuration mconfig))
+       (set-window-configuration oconfig)))))
 
 (defun minibuffer-max-depth-exceeded ()
   ;;
--- a/lisp/startup.el	Thu Jan 07 15:52:10 2010 +0000
+++ b/lisp/startup.el	Thu Jan 07 17:01:25 2010 +0000
@@ -1046,9 +1046,15 @@
 	    (load-user-init-file))
 	(condition-case nil
 	    (call-with-condition-handler
-		#'(lambda (__load_init_file_arg__)
+	       ((macro
+		 . (lambda (lambda-expression)
+		     ;; Be serious about information hiding here:
+		     (nsublis
+		      '((load-init-handler-arg . #:load-init-gZK6A36gTed))
+		      lambda-expression)))
+		#'(lambda (load-init-handler-arg)
 		    (let ((errstr (error-message-string
-				   __load_init_file_arg__)))
+				   load-init-handler-arg)))
 		      (message "Error in init file: %s" errstr)
 		      (lwarn 'initialization 'error
 			"\
@@ -1066,8 +1072,8 @@
 exact problem."
 			user-init-file errstr
 			(backtrace-in-condition-handler-eliminating-handler
-			 '__load_init_file_arg__)))
-		    (setq init-file-had-error t))
+			 'load-init-handler-arg)))
+		    (setq init-file-had-error t)))
 		#'(lambda ()
 		    (if load-user-init-file-p
 			(load-user-init-file))
--- a/lisp/subr.el	Thu Jan 07 15:52:10 2010 +0000
+++ b/lisp/subr.el	Thu Jan 07 17:01:25 2010 +0000
@@ -1118,14 +1118,26 @@
       (setq plist (cddr plist)))
     (nreverse alist)))
 
-(defun map-plist (_mp_fun _mp_plist)
-  "Map _MP_FUN (a function of two args) over each key/value pair in _MP_PLIST.
+((macro
+  . (lambda (map-plist-definition)
+      "Replace the variable names in MAP-PLIST-DEFINITION with uninterned
+symbols, avoiding the risk of interference with variables in other functions
+introduced by dynamic scope."
+      (if-fboundp 'nsublis 
+	  (nsublis
+	   '((mp-function . #:function)
+	     (plist . #:plist)
+	     (result . #:result))
+	   map-plist-definition)
+	map-plist-definition)))
+ (defun map-plist (mp-function plist)
+   "Map FUNCTION (a function of two args) over each key/value pair in PLIST.
 Return a list of the results."
-  (let (_mp_result)
-    (while _mp_plist
-      (push (funcall _mp_fun (car _mp_plist) (cadr _mp_plist)) _mp_result)
-      (setq _mp_plist (cddr _mp_plist)))
-    (nreverse _mp_result)))
+   (let (result)
+     (while plist
+       (push (funcall mp-function (car plist) (cadr plist)) result)
+      (setq plist (cddr plist)))
+    (nreverse result))))
 
 (defun destructive-plist-to-alist (plist)
   "Convert property list PLIST into the equivalent association-list form.
@@ -1464,7 +1476,9 @@
 	(no-backtrace nil)
 	(class ''general)
 	(level ''warning)
-	(resignal nil))
+	(resignal nil)
+	(cte-cc-var '#:cte-cc-var)
+	(call-trapping-errors-arg '#:call-trapping-errors-Ldc9FC5Hr))
     (let* ((keys '(operation error-form no-backtrace class level resignal))
 	   (keys-with-colon
 	    (mapcar #'(lambda (sym)
@@ -1473,11 +1487,11 @@
 	(let* ((key-with-colon (pop keys-body))
 	       (key (intern (substring (symbol-name key-with-colon) 1))))
 	  (set key (pop keys-body)))))
-    `(condition-case ,(if resignal '__cte_cc_var__ nil)
+    `(condition-case ,(if resignal cte-cc-var nil)
 	 (call-with-condition-handler
-	     #'(lambda (__call_trapping_errors_arg__)
+	     #'(lambda (,call-trapping-errors-arg)
 		 (let ((errstr (error-message-string
-				__call_trapping_errors_arg__)))
+				,call-trapping-errors-arg)))
 		   ,(if no-backtrace
 			`(lwarn ,class ,level
 			   (if (warning-level-<
@@ -1490,12 +1504,12 @@
 			 "Error in %s: %s\n\nBacktrace follows:\n\n%s"
 			 ,operation errstr
 			 (backtrace-in-condition-handler-eliminating-handler
-			  '__call_trapping_errors_arg__)))))
+			  ',call-trapping-errors-arg)))))
 	     #'(lambda ()
 		 (progn ,@keys-body)))
        (error
 	,error-form
-	,@(if resignal '((signal (car __cte_cc_var__) (cdr __cte_cc_var__)))))
+	,@(if resignal '((signal (car ,cte-cc-var) (cdr ,cte-cc-var)))))
        )))
 
 ;;;; Miscellanea.
--- a/lisp/syntax.el	Thu Jan 07 15:52:10 2010 +0000
+++ b/lisp/syntax.el	Thu Jan 07 17:01:25 2010 +0000
@@ -205,21 +205,35 @@
 	  (wrong-type-argument 'syntax-table-p syntax-table))))
   nil)
 
-(defun map-syntax-table (__function __syntax_table &optional __range)
-  "Map FUNCTION over entries in SYNTAX-TABLE, collapsing inheritance.
+((macro
+  . (lambda (map-syntax-definition)
+      "Replace the variable names in MAP-SYNTAX-DEFINITION with uninterned
+symbols, at byte-compile time.  This avoids the risk of variable names
+within the functions called from MAP-SYNTAX-DEFINITION being shared with
+MAP-SYNTAX-DEFINITION, and as such subject to modification, one of the
+common downsides of dynamic scope."
+      (nsublis
+       '((syntax-table . #:syntax-table)
+	 (m-s-function . #:function)
+	 (range . #:range)
+	 (key . #:key)
+	 (value . #:value))
+       map-syntax-definition)))
+ (defun map-syntax-table (m-s-function syntax-table &optional range)
+   "Map FUNCTION over entries in SYNTAX-TABLE, collapsing inheritance.
 This is similar to `map-char-table', but works only on syntax tables, and
  collapses any entries that call for inheritance by invisibly substituting
  the inherited values from the standard syntax table."
-  (check-argument-type 'syntax-table-p __syntax_table)
-  (map-char-table #'(lambda (__key __value)
-		      (if (eq ?@ (char-syntax-from-code __value))
-			  (map-char-table #'(lambda (__key __value)
-					      (funcall __function
-						       __key __value))
-					  (standard-syntax-table)
-					  __key)
-			(funcall __function __key __value)))
-		  __syntax_table __range))
+   (check-argument-type 'syntax-table-p syntax-table)
+   (map-char-table #'(lambda (key value)
+		       (if (eq ?@ (char-syntax-from-code value))
+			   (map-char-table
+			    #'(lambda (key value)
+				(funcall m-s-function key value))
+			    (standard-syntax-table)
+			    key)
+			 (funcall m-s-function key value)))
+		   syntax-table range)))
 
 ;(defun test-xm ()
 ;  (let ((o (copy-syntax-table))
--- a/src/ChangeLog	Thu Jan 07 15:52:10 2010 +0000
+++ b/src/ChangeLog	Thu Jan 07 17:01:25 2010 +0000
@@ -151,6 +151,12 @@
 	* xmu.h: Ditto.
 	* depend: Regenerate.
 
+2010-01-01  Aidan Kehoe  <kehoea@parhasard.net>
+
+	* mule-charset.c (Fmake_charset):
+	Don't intern the symbols used to refer to temporary character
+	sets, that doesn't bring us anything.
+
 2009-12-05  Stephen J. Turnbull  <stephen@xemacs.org>
 
 	* faces.c (complex_vars_of_faces): Explain why "*" isn't rewritten
--- a/src/mule-charset.c	Thu Jan 07 15:52:10 2010 +0000
+++ b/src/mule-charset.c	Thu Jan 07 17:01:25 2010 +0000
@@ -627,7 +627,7 @@
       Ibyte tempname[80];
 
       qxesprintf (tempname, "___temporary___%d__", id);
-      name = intern_int (tempname);
+      name = Fmake_symbol (build_string (tempname)); /* Uninterned. */
     }
   if (NILP (doc_string))
     doc_string = build_string ("");