diff lisp/subr.el @ 5125:b5df3737028a ben-lisp-object

merge
author Ben Wing <ben@xemacs.org>
date Wed, 24 Feb 2010 01:58:04 -0600
parents 788c38f20376
children 99f8ebc082d9
line wrap: on
line diff
--- a/lisp/subr.el	Wed Jan 20 07:05:57 2010 -0600
+++ b/lisp/subr.el	Wed Feb 24 01:58:04 2010 -0600
@@ -218,6 +218,7 @@
 (define-function 'remove-directory 'delete-directory)
 (define-function 'set-match-data 'store-match-data)
 (define-function 'send-string-to-terminal 'external-debugging-output)
+(define-function 'special-form-p 'special-operator-p)
 
 ;; XEmacs:
 (defun local-variable-if-set-p (sym buffer)
@@ -1118,14 +1119,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 +1477,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 +1488,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 +1505,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.
@@ -1749,17 +1764,32 @@
 SUBR must be a built-in function (not just a symbol that refers to one).
 The returned value is a pair (MIN . MAX).  MIN is the minimum number
 of args.  MAX is the maximum number or the symbol `many', for a
-function with `&rest' args, or `unevalled' for a special form.
+function with `&rest' args, or `unevalled' for a special operator.
 
-See also `special-form-p', `subr-min-args', `subr-max-args',
+See also `special-operator-p', `subr-min-args', `subr-max-args',
 `function-allows-args'. "
   (check-argument-type #'subrp subr)
   (cons (subr-min-args subr)
         (cond
-         ((special-form-p subr)
+         ((special-operator-p subr)
           'unevalled)
          ((null (subr-max-args subr))
           'many)
          (t (subr-max-args subr)))))
 
+;; XEmacs; move these here from C. Would be nice to drop them entirely, but
+;; they're used reasonably often, since they've been around for a long time
+;; and they're portable to GNU.
+
+;; Used in fileio.c if format-annotate-function has a function binding
+;; (which it won't have before this file is loaded):
+(defun car-less-than-car (a b)
+  "Return t if the car of A is numerically less than the car of B."
+  (< (car a) (car b)))
+
+;; Used in packages.
+(defun cdr-less-than-cdr (a b)
+  "Return t if (cdr A) is numerically less than (cdr B)."
+  (< (cdr a) (cdr b)))
+
 ;;; subr.el ends here