diff lisp/bytecomp.el @ 446:1ccc32a20af4 r21-2-38

Import from CVS: tag r21-2-38
author cvs
date Mon, 13 Aug 2007 11:37:21 +0200
parents 576fb035e263
children 7039e6323819
line wrap: on
line diff
--- a/lisp/bytecomp.el	Mon Aug 13 11:36:20 2007 +0200
+++ b/lisp/bytecomp.el	Mon Aug 13 11:37:21 2007 +0200
@@ -443,13 +443,32 @@
 
 (defvar byte-compiler-error-flag)
 
+;;; A form of eval that includes the currently defined macro definitions.
+;;; This helps implement the promise made in the Lispref:
+;;;
+;;; "If a file being compiled contains a `defmacro' form, the macro is
+;;; defined temporarily for the rest of the compilation of that file."
+(defun byte-compile-eval (form)
+  (let ((save-macro-environment nil))
+    (unwind-protect
+	(loop for (sym . def) in byte-compile-macro-environment do
+	  (push
+	   (if (fboundp sym) (cons sym (symbol-function sym)) sym)
+	   save-macro-environment)
+	  (fset sym (cons 'macro def))
+	  finally return (eval form))
+      (dolist (elt save-macro-environment)
+	(if (symbolp elt)
+	    (fmakunbound elt)
+	  (fset (car elt) (cdr elt)))))))
+
 (defconst byte-compile-initial-macro-environment
   '((byte-compiler-options . (lambda (&rest forms)
 			       (apply 'byte-compiler-options-handler forms)))
     (eval-when-compile . (lambda (&rest body)
-			   (list 'quote (eval (cons 'progn body)))))
+			   (list 'quote (byte-compile-eval (cons 'progn body)))))
     (eval-and-compile . (lambda (&rest body)
-			  (eval (cons 'progn body))
+			  (byte-compile-eval (cons 'progn body))
 			  (cons 'progn body))))
   "The default macro-environment passed to macroexpand by the compiler.
 Placing a macro here will cause a macro to have different semantics when
@@ -2725,8 +2744,8 @@
 
 (defmacro byte-defop-compiler (function &optional compile-handler)
   ;; add a compiler-form for FUNCTION.
-  ;; If function is a symbol, then the variable "byte-SYMBOL" must name
-  ;; the opcode to be used.  If function is a list, the first element
+  ;; If FUNCTION is a symbol, then the variable "byte-SYMBOL" must name
+  ;; the opcode to be used.  If is a list, the first element
   ;; is the function and the second element is the bytecode-symbol.
   ;; COMPILE-HANDLER is the function to use to compile this byte-op, or
   ;; may be the abbreviations 0, 1, 2, 3, 0-1, 1-2, 2-3, 0+1, 1+1, 2+1,
@@ -2916,11 +2935,6 @@
 (byte-defop-compiler-rmsfun member	2)
 (byte-defop-compiler-rmsfun assq	2)
 
-(byte-defop-compiler max		byte-compile-associative)
-(byte-defop-compiler min		byte-compile-associative)
-(byte-defop-compiler (+ byte-plus)	byte-compile-associative)
-(byte-defop-compiler (* byte-mult)	byte-compile-associative)
-
 ;;####(byte-defop-compiler move-to-column	1)
 (byte-defop-compiler-1 interactive byte-compile-noop)
 (byte-defop-compiler-1 domain byte-compile-domain)
@@ -2999,40 +3013,52 @@
 (defun byte-compile-no-args-with-one-extra (form)
   (case (length (cdr form))
     (0 (byte-compile-no-args form))
-    (1 (byte-compile-normal-call form))
+    (1 (if (eq nil (nth 1 form))
+	   (byte-compile-no-args (butlast form))
+	 (byte-compile-normal-call form)))
     (t (byte-compile-subr-wrong-args form "0-1"))))
 
 (defun byte-compile-one-arg-with-one-extra (form)
   (case (length (cdr form))
     (1 (byte-compile-one-arg form))
-    (2 (byte-compile-normal-call form))
+    (2 (if (eq nil (nth 2 form))
+	   (byte-compile-one-arg (butlast form))
+	 (byte-compile-normal-call form)))
     (t (byte-compile-subr-wrong-args form "1-2"))))
 
 (defun byte-compile-two-args-with-one-extra (form)
   (case (length (cdr form))
     (2 (byte-compile-two-args form))
-    (3 (byte-compile-normal-call form))
+    (3 (if (eq nil (nth 3 form))
+	   (byte-compile-two-args (butlast form))
+	 (byte-compile-normal-call form)))
     (t (byte-compile-subr-wrong-args form "2-3"))))
 
 (defun byte-compile-zero-or-one-arg-with-one-extra (form)
   (case (length (cdr form))
     (0 (byte-compile-one-arg (append form '(nil))))
     (1 (byte-compile-one-arg form))
-    (2 (byte-compile-normal-call form))
+    (2 (if (eq nil (nth 2 form))
+	   (byte-compile-one-arg (butlast form))
+	 (byte-compile-normal-call form)))
     (t (byte-compile-subr-wrong-args form "0-2"))))
 
 (defun byte-compile-one-or-two-args-with-one-extra (form)
   (case (length (cdr form))
     (1 (byte-compile-two-args (append form '(nil))))
     (2 (byte-compile-two-args form))
-    (3 (byte-compile-normal-call form))
+    (3 (if (eq nil (nth 3 form))
+	   (byte-compile-two-args (butlast form))
+	 (byte-compile-normal-call form)))
     (t (byte-compile-subr-wrong-args form "1-3"))))
 
 (defun byte-compile-two-or-three-args-with-one-extra (form)
   (case (length (cdr form))
     (2 (byte-compile-three-args (append form '(nil))))
     (3 (byte-compile-three-args form))
-    (4 (byte-compile-normal-call form))
+    (4 (if (eq nil (nth 4 form))
+	   (byte-compile-three-args (butlast form))
+	 (byte-compile-normal-call form)))
     (t (byte-compile-subr-wrong-args form "2-4"))))
 
 (defun byte-compile-no-args-with-two-extra (form)
@@ -3064,33 +3090,31 @@
 (defun byte-compile-discard ()
   (byte-compile-out 'byte-discard 0))
 
-;; Compile a function that accepts one or more args and is right-associative.
-;; We do it by left-associativity so that the operations
-;; are done in the same order as in interpreted code.
-;(defun byte-compile-associative (form)
-;  (if (cdr form)
-;      (let ((opcode (get (car form) 'byte-opcode))
-;	    (args (copy-sequence (cdr form))))
-;	(byte-compile-form (car args))
-;	(setq args (cdr args))
-;	(while args
-;	  (byte-compile-form (car args))
-;	  (byte-compile-out opcode 0)
-;	  (setq args (cdr args))))
-;    (byte-compile-constant (eval form))))
-
-;; Compile a function that accepts one or more args and is right-associative.
-;; We do it by left-associativity so that the operations
-;; are done in the same order as in interpreted code.
-(defun byte-compile-associative (form)
-  (let ((args (cdr form))
-	(opcode (get (car form) 'byte-opcode)))
+(defun byte-compile-max (form)
+  (let ((args (cdr form)))
     (case (length args)
-      (0 (byte-compile-constant (eval form)))
+      (0 (byte-compile-subr-wrong-args form "1 or more"))
+      (1 (byte-compile-form (car args))
+	 (when (not byte-compile-delete-errors)
+	   (byte-compile-out 'byte-dup 0)
+	   (byte-compile-out 'byte-max 0)))
       (t (byte-compile-form (car args))
-	 (dolist (arg (cdr args))
-	   (byte-compile-form arg)
-	   (byte-compile-out opcode 0))))))
+	 (dolist (elt (cdr args))
+	   (byte-compile-form elt)
+	   (byte-compile-out 'byte-max 0))))))
+
+(defun byte-compile-min (form)
+  (let ((args (cdr form)))
+    (case (length args)
+      (0 (byte-compile-subr-wrong-args form "1 or more"))
+      (1 (byte-compile-form (car args))
+	 (when (not byte-compile-delete-errors)
+	   (byte-compile-out 'byte-dup 0)
+	   (byte-compile-out 'byte-min 0)))
+      (t (byte-compile-form (car args))
+	 (dolist (elt (cdr args))
+	   (byte-compile-form elt)
+	   (byte-compile-out 'byte-min 0))))))
 
 
 ;; more complicated compiler macros
@@ -3100,8 +3124,12 @@
 (byte-defop-compiler fset)
 (byte-defop-compiler insert)
 (byte-defop-compiler-1 function byte-compile-function-form)
-(byte-defop-compiler-1 - byte-compile-minus)
-(byte-defop-compiler (/ byte-quo) byte-compile-quo)
+(byte-defop-compiler max)
+(byte-defop-compiler min)
+(byte-defop-compiler (+ byte-plus)	byte-compile-plus)
+(byte-defop-compiler-1 -		byte-compile-minus)
+(byte-defop-compiler (* byte-mult)	byte-compile-mult)
+(byte-defop-compiler (/ byte-quo)	byte-compile-quo)
 (byte-defop-compiler nconc)
 (byte-defop-compiler-1 beginning-of-line)
 
@@ -3176,6 +3204,23 @@
       (byte-compile-out 'byte-concatN nargs))
      ((byte-compile-normal-call form)))))
 
+(defun byte-compile-plus (form)
+  (let ((args (cdr form)))
+    (case (length args)
+      (0 (byte-compile-constant 0))
+      (1 (byte-compile-plus (append form '(0))))
+      (t (byte-compile-form (car args))
+	 (dolist (elt (cdr args))
+	   (case elt
+	     (0  (when (not byte-compile-delete-errors)
+		   (byte-compile-constant 0)
+		   (byte-compile-out 'byte-plus 0)))
+	     (+1 (byte-compile-out 'byte-add1 0))
+	     (-1 (byte-compile-out 'byte-sub1 0))
+	     (t
+	      (byte-compile-form elt)
+	      (byte-compile-out 'byte-plus 0))))))))
+
 (defun byte-compile-minus (form)
   (let ((args (cdr form)))
     (case (length args)
@@ -3184,8 +3229,33 @@
 	 (byte-compile-out 'byte-negate 0))
       (t (byte-compile-form (car args))
 	 (dolist (elt (cdr args))
-	   (byte-compile-form elt)
-	   (byte-compile-out 'byte-diff 0))))))
+	   (case elt
+	     (0  (when (not byte-compile-delete-errors)
+		   (byte-compile-constant 0)
+		   (byte-compile-out 'byte-diff 0)))
+	     (+1 (byte-compile-out 'byte-sub1 0))
+	     (-1 (byte-compile-out 'byte-add1 0))
+	     (t
+	      (byte-compile-form elt)
+	      (byte-compile-out 'byte-diff 0))))))))
+
+(defun byte-compile-mult (form)
+  (let ((args (cdr form)))
+    (case (length args)
+      (0 (byte-compile-constant 1))
+      (1 (byte-compile-mult (append form '(1))))
+      (t (byte-compile-form (car args))
+	 (dolist (elt (cdr args))
+	   (case elt
+	     (1  (when (not byte-compile-delete-errors)
+		   (byte-compile-constant 1)
+		   (byte-compile-out 'byte-mult 0)))
+	     (-1 (byte-compile-out 'byte-negate 0))
+	     (2  (byte-compile-out 'byte-dup 0)
+		 (byte-compile-out 'byte-plus 0))
+	     (t
+	      (byte-compile-form elt)
+	      (byte-compile-out 'byte-mult 0))))))))
 
 (defun byte-compile-quo (form)
   (let ((args (cdr form)))
@@ -3196,8 +3266,16 @@
 	 (byte-compile-out 'byte-quo 0))
       (t (byte-compile-form (car args))
 	 (dolist (elt (cdr args))
-	   (byte-compile-form elt)
-	   (byte-compile-out 'byte-quo 0))))))
+	   (case elt
+	     (+1 (when (not byte-compile-delete-errors)
+		   (byte-compile-constant 1)
+		   (byte-compile-out 'byte-quo 0)))
+	     (-1 (byte-compile-out 'byte-negate 0))
+	     (t
+	      (when (and (numberp elt) (= elt 0))
+		(byte-compile-warn "Attempt to divide by zero: %s" form))
+	      (byte-compile-form elt)
+	      (byte-compile-out 'byte-quo 0))))))))
 
 (defun byte-compile-nconc (form)
   (let ((args (cdr form)))