*** empty log message ***
This commit is contained in:
parent
29929437a3
commit
0b030df78b
4 changed files with 99 additions and 60 deletions
84
lisp/cl.el
84
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."
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Add table
Reference in a new issue