xemacs-beta: lisp/bytecomp.el comparison

comparison 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

comparison

equal deleted inserted replaced

-:34f3776fcf0e
+:1ccc32a20af4
 (defvar byte-compile-free-references)
 (defvar byte-compile-free-assignments)
 (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
 expanded by the compiler as when expanded by the interpreter.")
 ;; Compile those primitive ordinary functions
 ;; which have special byte codes just for speed.
 (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
+;; 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
+;; 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,
 ;; 0-1+1, 1-2+1, 2-3+1, 0+2, or 1+2.  If it is nil, then the handler is
 ;; "byte-compile-SYMBOL."
 (byte-defop-compiler aset		3)
 (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)
 ;; As of GNU Emacs 19.18 and Lucid Emacs 19.8, mod and % are different: `%'
 ;; `byte-compile-subr-wrong-args' also converts the call to non-inlined.
 (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)
 (case (length (cdr form))
 (0     (byte-compile-no-args form))
 (byte-compile-constant nil))
 (defun byte-compile-discard ()
 (byte-compile-out 'byte-discard 0))
-;; Compile a function that accepts one or more args and is right-associative.
+(defun byte-compile-max (form)
-;; We do it by left-associativity so that the operations
+(let ((args (cdr form)))
-;; 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)))
 (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))
+	 (dolist (elt (cdr args))
-	   (byte-compile-form arg)
+	   (byte-compile-form elt)
-	   (byte-compile-out opcode 0))))))
+	   (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
 (byte-defop-compiler list)
 (byte-defop-compiler concat)
 (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 max)
-(byte-defop-compiler (/ byte-quo) byte-compile-quo)
+(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)
 (byte-defop-compiler (=  byte-eqlsign)	byte-compile-arithcompare)
 (byte-defop-compiler (<  byte-lss)	byte-compile-arithcompare)
 ((< nargs 256)
 (mapcar 'byte-compile-form args)
 (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)
 (0 (byte-compile-subr-wrong-args form "1 or more"))
 (1 (byte-compile-form (car args))
 	 (byte-compile-out 'byte-negate 0))
 (t (byte-compile-form (car args))
 	 (dolist (elt (cdr args))
-	   (byte-compile-form elt)
+	   (case elt
-	   (byte-compile-out 'byte-diff 0))))))
+	     (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)))
 (case (length args)
 (0 (byte-compile-subr-wrong-args form "1 or more"))
 (1 (byte-compile-constant 1)
 	 (byte-compile-form (car args))
 	 (byte-compile-out 'byte-quo 0))
 (t (byte-compile-form (car args))
 	 (dolist (elt (cdr args))
-	   (byte-compile-form elt)
+	   (case elt
-	   (byte-compile-out 'byte-quo 0))))))
+	     (+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)))
 (case (length args)
 (0 (byte-compile-constant nil))

Mercurial > hg > xemacs-beta

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