diff options
| -rw-r--r-- | lisp/cl.el | 84 | ||||
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 69 | ||||
| -rw-r--r-- | lisp/lpr.el | 4 | ||||
| -rw-r--r-- | lisp/progmodes/hideif.el | 2 |
4 files changed, 99 insertions, 60 deletions
diff --git a/lisp/cl.el b/lisp/cl.el index c86b24ffe2..b675d926fb 100644 --- a/lisp/cl.el +++ b/lisp/cl.el @@ -691,25 +691,34 @@ list accessors: first, second, ..., tenth, rest." (arg (cadr form)) (valid *cl-valid-named-list-accessors*) (offsets *cl-valid-nth-offsets*)) - (if (or (null (cdr form)) (cddr form)) - (error "%s needs exactly one argument, seen `%s'" - fun (prin1-to-string form))) - (if (not (memq fun valid)) - (error "`%s' not in {first, ..., tenth, rest}" fun)) - (cond ((eq fun 'first) - (byte-compile-form arg) - (setq byte-compile-depth (1- byte-compile-depth)) - (byte-compile-out byte-car 0)) - ((eq fun 'rest) - (byte-compile-form arg) - (setq byte-compile-depth (1- byte-compile-depth)) - (byte-compile-out byte-cdr 0)) - (t ;one of the others - (byte-compile-constant (cdr (assoc fun offsets))) - (byte-compile-form arg) - (setq byte-compile-depth (1- byte-compile-depth)) - (byte-compile-out byte-nth 0) - )))) + (cond + + ;; Check that it's a form we're prepared to handle. + ((not (memq fun valid)) + (error + "cl.el internal bug: `%s' not in {first, ..., tenth, rest}" + fun)) + + ;; Check the number of arguments. + ((not (= (length form) 2)) + (byte-compile-subr-wrong-args form 1)) + + ;; If the result will simply be tossed, don't generate any code for + ;; it, and indicate that we have already discarded the value. + (for-effect + (setq for-effect nil)) + + ;; Generate code for the call. + ((eq fun 'first) + (byte-compile-form arg) + (byte-compile-out 'byte-car 0)) + ((eq fun 'rest) + (byte-compile-form arg) + (byte-compile-out 'byte-cdr 0)) + (t ;one of the others + (byte-compile-constant (cdr (assq fun offsets))) + (byte-compile-form arg) + (byte-compile-out 'byte-nth 0))))) ;;; Synonyms for list functions (defun first (x) @@ -851,18 +860,31 @@ To use this functionality for a given function,just give its name a 'byte-car 'byte-cdr))) (cdr (nreverse (cdr (append (symbol-name fun) nil))))))) ;; SEQ is a list of byte-car and byte-cdr in the correct order. - (if (null seq) - (error "internal: `%s' cannot be compiled by byte-compile-ca*d*r" - (prin1-to-string form))) - (if (or (null (cdr form)) (cddr form)) - (error "%s needs exactly one argument, seen `%s'" - fun (prin1-to-string form))) - (byte-compile-form arg) - (setq byte-compile-depth (1- byte-compile-depth)) - ;; the rest of this code doesn't change the stack depth! - (while seq - (byte-compile-out (car seq) 0) - (setq seq (cdr seq))))) + (cond + + ;; Is this a function we can handle? + ((null seq) + (error + "cl.el internal bug: `%s' cannot be compiled by byte-compile-ca*d*r" + (prin1-to-string form))) + + ;; Are we passing this function the correct number of arguments? + ((or (null (cdr form)) (cddr form)) + (byte-compile-subr-wrong-args form 1)) + + ;; Are we evaluating this expression for effect only? + (for-effect + + ;; We needn't generate any actual code, as long as we tell the rest + ;; of the compiler that we didn't push anything on the stack. + (setq for-effect nil)) + + ;; Generate code for the function. + (t + (byte-compile-form arg) + (while seq + (byte-compile-out (car seq) 0) + (setq seq (cdr seq))))))) (defun caar (X) "Return the car of the car of X." diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 344abcb5d1..f9bbf4d646 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -242,7 +242,8 @@ If it is 'byte, then only byte-level optimizations will be logged.") of `message.'") (defconst byte-compile-warning-types '(redefine callargs free-vars unresolved)) -(defvar byte-compile-warnings (not noninteractive) +(defvar byte-compile-warnings (if noninteractive nil + (delq 'free-vars byte-compile-warning-types)) "*List of warnings that the byte-compiler should issue (t for all). Valid elements of this list are: `free-vars' (references to variables not in the @@ -734,6 +735,14 @@ otherwise pop it") ;;; (message "Warning: %s" format)) )) +;;; This function should be used to report errors that have halted +;;; compilation of the current file. +(defun byte-compile-report-error (error-info) + (setq format (format (if (cdr error-info) "%s (%s)" "%s") + (get (car error-info) 'error-message) + (prin1-to-string (cdr error-info)))) + (byte-compile-log-1 (concat "!! " format))) + ;;; Used by make-obsolete. (defun byte-compile-obsolete (form) (let ((new (get (car form) 'byte-obsolete-info))) @@ -1004,7 +1013,11 @@ otherwise pop it") (save-excursion (set-buffer (get-buffer-create "*Compile-Log*")) (point-max))))) - (list 'unwind-protect (cons 'progn body) + (list 'unwind-protect + (list 'condition-case 'error-info + (cons 'progn body) + '(error + (byte-compile-report-error error-info))) '(save-excursion ;; If there were compilation warnings, display them. (set-buffer "*Compile-Log*") @@ -1090,28 +1103,31 @@ With prefix arg (noninteractively: 2nd arg), load the file after compiling." (set-auto-mode) (setq filename buffer-file-name)) (kill-buffer (prog1 (current-buffer) - (set-buffer (byte-compile-from-buffer (current-buffer))))) + (set-buffer + (byte-compile-from-buffer (current-buffer))))) (goto-char (point-max)) - (insert "\n") ; aaah, unix. + (insert "\n") ; aaah, unix. (let ((vms-stmlf-recfm t)) (setq target-file (byte-compile-dest-file filename)) -;; (or byte-compile-overwrite-file -;; (condition-case () -;; (delete-file target-file) -;; (error nil))) +;; (or byte-compile-overwrite-file +;; (condition-case () +;; (delete-file target-file) +;; (error nil))) (if (file-writable-p target-file) - (let ((kanji-flag nil)) ; for nemacs, from Nakagawa Takayuki + (let ((kanji-flag nil)) ; for nemacs, from Nakagawa Takayuki (write-region 1 (point-max) target-file)) - ;; This is just to give a better error message than write-region - (signal 'file-error (list "Opening output file" - (if (file-exists-p target-file) - "cannot overwrite file" - "directory not writable or nonexistent") - target-file))) -;; (or byte-compile-overwrite-file -;; (condition-case () -;; (set-file-modes target-file (file-modes filename)) -;; (error nil))) + ;; This is just to give a better error message than + ;; write-region + (signal 'file-error + (list "Opening output file" + (if (file-exists-p target-file) + "cannot overwrite file" + "directory not writable or nonexistent") + target-file))) +;; (or byte-compile-overwrite-file +;; (condition-case () +;; (set-file-modes target-file (file-modes filename)) +;; (error nil))) ) (kill-buffer (current-buffer))) (if (and byte-compile-generate-call-tree @@ -1180,17 +1196,17 @@ With argument, insert value in current buffer after the form." (byte-compile-depth 0) (byte-compile-maxdepth 0) (byte-compile-output nil) - ;; #### This is bound in b-c-close-variables. - ;;(byte-compile-warnings (if (eq byte-compile-warnings t) - ;; byte-compile-warning-types - ;; byte-compile-warnings)) +;; #### This is bound in b-c-close-variables. +;; (byte-compile-warnings (if (eq byte-compile-warnings t) +;; byte-compile-warning-types +;; byte-compile-warnings)) ) (byte-compile-close-variables (save-excursion (setq outbuffer (set-buffer (get-buffer-create " *Compiler Output*"))) (erase-buffer) -;; (emacs-lisp-mode) + ;; (emacs-lisp-mode) (setq case-fold-search nil)) (displaying-byte-compile-warnings (save-excursion @@ -1206,8 +1222,9 @@ With argument, insert value in current buffer after the form." (byte-compile-flush-pending) (and (not eval) (byte-compile-insert-header)) (byte-compile-warn-about-unresolved-functions) - ;; always do this? When calling multiple files, it would be useful - ;; to delay this warning until all have been compiled. + ;; always do this? When calling multiple files, it + ;; would be useful to delay this warning until all have + ;; been compiled. (setq byte-compile-unresolved-functions nil))) (save-excursion (set-buffer outbuffer) diff --git a/lisp/lpr.el b/lisp/lpr.el index 5dad2f86c0..52f5abc522 100644 --- a/lisp/lpr.el +++ b/lisp/lpr.el @@ -76,7 +76,7 @@ See definition of `print-region-1' for calling conventions.") (if page-headers (if (eq system-type 'usg-unix-v) (progn - (print-region-new-buffer) + (print-region-new-buffer start end) (call-process-region start end "pr" t t nil)) ;; On BSD, use an option to get page headers. (setq switches (cons "-p" switches)))) @@ -92,7 +92,7 @@ See definition of `print-region-1' for calling conventions.") ;; into a new buffer, makes that buffer current, ;; and sets start and end to the buffer bounds. ;; start and end are used free. -(defun print-region-new-buffer () +(defun print-region-new-buffer (start end) (or (string= (buffer-name) " *spool temp*") (let ((oldbuf (current-buffer))) (set-buffer (get-buffer-create " *spool temp*")) diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index b29ebe6bf5..16178c018e 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -582,7 +582,7 @@ NOT including one on this line." (hif-endif-to-ifdef)) ((hif-looking-at-ifX) 'done) - (t ; never gets here))) + (t))) ; never gets here (defun forward-ifdef (&optional arg) |