Commit 0b030df7 authored by Jim Blandy's avatar Jim Blandy
Browse files

*** empty log message ***

parent 29929437
......@@ -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."
......
......@@ -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)
......
......@@ -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*"))
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment