comparison lisp/bytecomp.el @ 5473:ac37a5f7e5be

Merge with trunk.
author Mats Lidell <matsl@xemacs.org>
date Thu, 17 Mar 2011 23:42:59 +0100
parents e79980ee5efe d967d96ca043
children 4dee0387b9de
comparison
equal deleted inserted replaced
5472:e79980ee5efe 5473:ac37a5f7e5be
3157 (byte-defop-compiler numberp 1) 3157 (byte-defop-compiler numberp 1)
3158 (byte-defop-compiler fixnump 1) 3158 (byte-defop-compiler fixnump 1)
3159 (byte-defop-compiler skip-chars-forward 1-2+1) 3159 (byte-defop-compiler skip-chars-forward 1-2+1)
3160 (byte-defop-compiler skip-chars-backward 1-2+1) 3160 (byte-defop-compiler skip-chars-backward 1-2+1)
3161 (byte-defop-compiler eq 2) 3161 (byte-defop-compiler eq 2)
3162 (byte-defop-compiler20 old-eq 2) 3162 ; (byte-defop-compiler20 old-eq 2)
3163 (byte-defop-compiler20 old-memq 2) 3163 ; (byte-defop-compiler20 old-memq 2)
3164 (byte-defop-compiler cons 2) 3164 (byte-defop-compiler cons 2)
3165 (byte-defop-compiler aref 2) 3165 (byte-defop-compiler aref 2)
3166 (byte-defop-compiler get 2+1) 3166 (byte-defop-compiler get 2+1)
3167 (byte-defop-compiler nth 2) 3167 (byte-defop-compiler nth 2)
3168 (byte-defop-compiler subseq byte-compile-subseq) 3168 (byte-defop-compiler subseq byte-compile-subseq)
3175 (byte-defop-compiler downcase 1+1) 3175 (byte-defop-compiler downcase 1+1)
3176 (byte-defop-compiler string= 2) 3176 (byte-defop-compiler string= 2)
3177 (byte-defop-compiler string< 2) 3177 (byte-defop-compiler string< 2)
3178 (byte-defop-compiler (string-equal byte-string=) 2) 3178 (byte-defop-compiler (string-equal byte-string=) 2)
3179 (byte-defop-compiler (string-lessp byte-string<) 2) 3179 (byte-defop-compiler (string-lessp byte-string<) 2)
3180 (byte-defop-compiler20 old-equal 2) 3180 ; (byte-defop-compiler20 old-equal 2)
3181 (byte-defop-compiler nthcdr 2) 3181 (byte-defop-compiler nthcdr 2)
3182 (byte-defop-compiler elt 2) 3182 (byte-defop-compiler elt 2)
3183 (byte-defop-compiler20 old-member 2) 3183 (byte-defop-compiler20 old-member 2)
3184 (byte-defop-compiler20 old-assq 2) 3184 (byte-defop-compiler20 old-assq 2)
3185 (byte-defop-compiler (rplaca byte-setcar) 2) 3185 (byte-defop-compiler (rplaca byte-setcar) 2)
3216 3216
3217 (defun byte-compile-warn-wrong-args (form n) 3217 (defun byte-compile-warn-wrong-args (form n)
3218 (when (memq 'subr-callargs byte-compile-warnings) 3218 (when (memq 'subr-callargs byte-compile-warnings)
3219 (byte-compile-warn "%s called with %d arg%s, but requires %s" 3219 (byte-compile-warn "%s called with %d arg%s, but requires %s"
3220 (car form) (length (cdr form)) 3220 (car form) (length (cdr form))
3221 (if (= 1 (length (cdr form))) "" "s") n))) 3221 (if (eql 1 (length (cdr form))) "" "s") n)))
3222 3222
3223 (defun byte-compile-subr-wrong-args (form n) 3223 (defun byte-compile-subr-wrong-args (form n)
3224 (byte-compile-warn-wrong-args form n) 3224 (byte-compile-warn-wrong-args form n)
3225 ;; get run-time wrong-number-of-args error. 3225 ;; get run-time wrong-number-of-args error.
3226 (byte-compile-normal-call form)) 3226 (byte-compile-normal-call form))
3341 (t (byte-compile-subr-wrong-args form "1-3")))) 3341 (t (byte-compile-subr-wrong-args form "1-3"))))
3342 3342
3343 ;; XEmacs: used for functions that have a different opcode in v19 than v20. 3343 ;; XEmacs: used for functions that have a different opcode in v19 than v20.
3344 ;; this includes `eq', `equal', and other old-ified functions. 3344 ;; this includes `eq', `equal', and other old-ified functions.
3345 (defun byte-compile-two-args-19->20 (form) 3345 (defun byte-compile-two-args-19->20 (form)
3346 (if (not (= (length form) 3)) 3346 (if (not (eql (length form) 3))
3347 (byte-compile-subr-wrong-args form 2) 3347 (byte-compile-subr-wrong-args form 2)
3348 (byte-compile-form (car (cdr form))) ;; Push the arguments 3348 (byte-compile-form (car (cdr form))) ;; Push the arguments
3349 (byte-compile-form (nth 2 form)) 3349 (byte-compile-form (nth 2 form))
3350 (if (byte-compile-version-cond byte-compile-emacs19-compatibility) 3350 (if (byte-compile-version-cond byte-compile-emacs19-compatibility)
3351 (byte-compile-out (get (car form) 'byte-opcode19) 0) 3351 (byte-compile-out (get (car form) 'byte-opcode19) 0)
3442 3442
3443 (defun byte-compile-list (form) 3443 (defun byte-compile-list (form)
3444 (let* ((args (cdr form)) 3444 (let* ((args (cdr form))
3445 (nargs (length args))) 3445 (nargs (length args)))
3446 (cond 3446 (cond
3447 ((= nargs 0) 3447 ((eql nargs 0)
3448 (byte-compile-constant nil)) 3448 (byte-compile-constant nil))
3449 ((< nargs 5) 3449 ((< nargs 5)
3450 (mapc 'byte-compile-form args) 3450 (mapc 'byte-compile-form args)
3451 (byte-compile-out 3451 (byte-compile-out
3452 (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- nargs)) 3452 (aref [byte-list1 byte-list2 byte-list3 byte-list4] (1- nargs))
3692 3692
3693 (defun byte-compile-beginning-of-line (form) 3693 (defun byte-compile-beginning-of-line (form)
3694 (let ((len (length form))) 3694 (let ((len (length form)))
3695 (cond ((> len 3) 3695 (cond ((> len 3)
3696 (byte-compile-subr-wrong-args form "0-2")) 3696 (byte-compile-subr-wrong-args form "0-2"))
3697 ((or (= len 3) (not (byte-compile-constp (nth 1 form)))) 3697 ((or (eql len 3) (not (byte-compile-constp (nth 1 form))))
3698 (byte-compile-normal-call form)) 3698 (byte-compile-normal-call form))
3699 (t 3699 (t
3700 (byte-compile-form 3700 (byte-compile-form
3701 (list 'forward-line 3701 (list 'forward-line
3702 (if (integerp (setq form (or (eval (nth 1 form)) 1))) 3702 (if (integerp (setq form (or (eval (nth 1 form)) 1)))
3762 3762
3763 (defun byte-compile-set-default (form) 3763 (defun byte-compile-set-default (form)
3764 (let* ((args (cdr form)) 3764 (let* ((args (cdr form))
3765 (nargs (length args)) 3765 (nargs (length args))
3766 (var (car args))) 3766 (var (car args)))
3767 (when (and (= (safe-length var) 2) 3767 (when (and (eql (safe-length var) 2) (eq (car var) 'quote))
3768 (eq (car var) 'quote))
3769 (let ((sym (nth 1 var))) 3768 (let ((sym (nth 1 var)))
3770 (cond 3769 (cond
3771 ((not (symbolp sym)) 3770 ((not (symbolp sym))
3772 (byte-compile-warn "Attempt to set-globally non-symbol %s" sym)) 3771 (byte-compile-warn "Attempt to set-globally non-symbol %s" sym))
3773 ((byte-compile-constant-symbol-p sym) 3772 ((byte-compile-constant-symbol-p sym)
3782 ((not (memq 'free-vars byte-compile-warnings))) ; warnings suppressed? 3781 ((not (memq 'free-vars byte-compile-warnings))) ; warnings suppressed?
3783 ((memq sym byte-compile-free-assignments)) ; already warned about sym 3782 ((memq sym byte-compile-free-assignments)) ; already warned about sym
3784 (t 3783 (t
3785 (byte-compile-warn "assignment to free variable %s" sym) 3784 (byte-compile-warn "assignment to free variable %s" sym)
3786 (push sym byte-compile-free-assignments))))) 3785 (push sym byte-compile-free-assignments)))))
3787 (if (= nargs 2) 3786 (if (eql nargs 2)
3788 ;; now emit a normal call to set-default 3787 ;; now emit a normal call to set-default
3789 (byte-compile-normal-call form) 3788 (byte-compile-normal-call form)
3790 (byte-compile-subr-wrong-args form 2)))) 3789 (byte-compile-subr-wrong-args form 2))))
3791 3790
3792 3791
3919 (setq form (cdr form)) 3918 (setq form (cdr form))
3920 (byte-compile-form-do-effect (pop form)) 3919 (byte-compile-form-do-effect (pop form))
3921 (byte-compile-body form t)) 3920 (byte-compile-body form t))
3922 3921
3923 (defun byte-compile-values (form) 3922 (defun byte-compile-values (form)
3924 (if (= 2 (length form)) 3923 (if (eql 2 (length form))
3925 (if (byte-compile-constp (second form)) 3924 (if (byte-compile-constp (second form))
3926 (byte-compile-form-do-effect (second form)) 3925 (byte-compile-form-do-effect (second form))
3927 ;; #'or compiles to bytecode, #'values doesn't: 3926 ;; #'or compiles to bytecode, #'values doesn't:
3928 (byte-compile-form-do-effect `(or ,(second form) nil))) 3927 (byte-compile-form-do-effect `(or ,(second form) nil)))
3929 (byte-compile-normal-call form))) 3928 (byte-compile-normal-call form)))
3930 3929
3931 (defun byte-compile-values-list (form) 3930 (defun byte-compile-values-list (form)
3932 (if (and (= 2 (length form)) 3931 (if (and (eql 2 (length form))
3933 (or (null (second form)) 3932 (or (null (second form))
3934 (and (consp (second form)) 3933 (and (consp (second form))
3935 (eq (car (second form)) 3934 (eq (car (second form))
3936 'quote) 3935 'quote)
3937 (not (symbolp (car-safe (cdr (second form)))))))) 3936 (not (symbolp (car-safe (cdr (second form))))))))
4106 ;; (except that earlier 21.5 with bignum support will confuse Bfixnump and 4105 ;; (except that earlier 21.5 with bignum support will confuse Bfixnump and
4107 ;; Bintegerp; which it did in dealing with byte-compiled code from 21.4 4106 ;; Bintegerp; which it did in dealing with byte-compiled code from 21.4
4108 ;; anyway). 4107 ;; anyway).
4109 4108
4110 (defun byte-compile-integerp (form) 4109 (defun byte-compile-integerp (form)
4111 (if (/= 2 (length form)) 4110 (if (not (eql (length form) 2))
4112 (byte-compile-subr-wrong-args form 1) 4111 (byte-compile-subr-wrong-args form 1)
4113 (let ((donetag (byte-compile-make-tag)) 4112 (let ((donetag (byte-compile-make-tag))
4114 (wintag (byte-compile-make-tag)) 4113 (wintag (byte-compile-make-tag))
4115 (failtag (byte-compile-make-tag))) 4114 (failtag (byte-compile-make-tag)))
4116 (byte-compile-constant 'integerp) 4115 (byte-compile-constant 'integerp)
4334 (pushnew '(subrp (symbol-function 'multiple-value-call)) 4333 (pushnew '(subrp (symbol-function 'multiple-value-call))
4335 byte-compile-checks-on-load 4334 byte-compile-checks-on-load
4336 :test #'equal))) 4335 :test #'equal)))
4337 4336
4338 (defun byte-compile-multiple-value-list-internal (form) 4337 (defun byte-compile-multiple-value-list-internal (form)
4339 (if (/= 4 (length form)) 4338 (if (not (eql 4 (length form)))
4340 (progn 4339 (progn
4341 (byte-compile-warn-wrong-args form 3) 4340 (byte-compile-warn-wrong-args form 3)
4342 (byte-compile-normal-call 4341 (byte-compile-normal-call
4343 `(signal 'wrong-number-of-arguments '(,(car form) 4342 `(signal 'wrong-number-of-arguments '(,(car form)
4344 ,(length (cdr form)))))) 4343 ,(length (cdr form))))))
4356 ;; the form does not have two args, it tries to #'funcall it expecting a 4355 ;; the form does not have two args, it tries to #'funcall it expecting a
4357 ;; runtime wrong-number-of-arguments error. Now that #'throw is a special 4356 ;; runtime wrong-number-of-arguments error. Now that #'throw is a special
4358 ;; form, it provokes an invalid-function error instead (or at least it 4357 ;; form, it provokes an invalid-function error instead (or at least it
4359 ;; should; there's a kludge around for the moment in eval.c that avoids 4358 ;; should; there's a kludge around for the moment in eval.c that avoids
4360 ;; that, but this file should not assume that that will always be there). 4359 ;; that, but this file should not assume that that will always be there).
4361 (if (/= 2 (length (cdr form))) 4360 (if (not (eql 2 (length (cdr form))))
4362 (progn 4361 (progn
4363 (byte-compile-warn-wrong-args form 2) 4362 (byte-compile-warn-wrong-args form 2)
4364 (byte-compile-normal-call 4363 (byte-compile-normal-call
4365 `(signal 'wrong-number-of-arguments '(,(car form) 4364 `(signal 'wrong-number-of-arguments '(,(car form)
4366 ,(length (cdr form)))))) 4365 ,(length (cdr form))))))