diff options
Diffstat (limited to 'lisp/emacs-lisp/bytecomp.el')
| -rw-r--r-- | lisp/emacs-lisp/bytecomp.el | 969 |
1 files changed, 632 insertions, 337 deletions
diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 199927d536e..8892a27b29c 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -118,12 +118,20 @@ ;; Some versions of `file' can be customized to recognize that. (require 'backquote) +(require 'macroexp) +(require 'cconv) (eval-when-compile (require 'cl)) (or (fboundp 'defsubst) ;; This really ought to be loaded already! (load "byte-run")) +;; The feature of compiling in a specific target Emacs version +;; has been turned off because compile time options are a bad idea. +(defmacro byte-compile-single-version () nil) +(defmacro byte-compile-version-cond (cond) cond) + + (defgroup bytecomp nil "Emacs Lisp byte-compiler." :group 'lisp) @@ -395,13 +403,15 @@ specify different fields to sort on." :type '(choice (const name) (const callers) (const calls) (const calls+callers) (const nil))) -(defvar byte-compile-debug nil) +(defvar byte-compile-debug t) +(setq debug-on-error t) + (defvar byte-compile-constants nil "List of all constants encountered during compilation of this form.") (defvar byte-compile-variables nil "List of all variables encountered during compilation of this form.") (defvar byte-compile-bound-variables nil - "List of variables bound in the context of the current form. + "List of dynamic variables bound in the context of the current form. This list lives partly on the stack.") (defvar byte-compile-const-variables nil "List of variables declared as constants during compilation of this file.") @@ -415,9 +425,13 @@ This list lives partly on the stack.") ;; (byte-compiler-options . (lambda (&rest forms) ;; (apply 'byte-compiler-options-handler forms))) (eval-when-compile . (lambda (&rest body) - (list 'quote - (byte-compile-eval (byte-compile-top-level - (cons 'progn body)))))) + (list + 'quote + (byte-compile-eval + (byte-compile-top-level + (macroexpand-all + (cons 'progn body) + byte-compile-initial-macro-environment)))))) (eval-and-compile . (lambda (&rest body) (byte-compile-eval-before-compile (cons 'progn body)) (cons 'progn body)))) @@ -450,6 +464,10 @@ defined with incorrect args.") Used for warnings about calling a function that is defined during compilation but won't necessarily be defined when the compiled file is loaded.") +;; Variables for lexical binding +(defvar byte-compile-lexical-environment nil + "The current lexical environment.") + (defvar byte-compile-tag-number 0) (defvar byte-compile-output nil "Alist describing contents to put in byte code string. @@ -495,11 +513,10 @@ Each element is (INDEX . VALUE)") (put 'byte-stack+-info 'tmp-compile-time-value nil))) -;; unused: 0-7 - ;; These opcodes are special in that they pack their argument into the ;; opcode word. ;; +(byte-defop 0 1 byte-stack-ref "for stack reference") (byte-defop 8 1 byte-varref "for variable reference") (byte-defop 16 -1 byte-varset "for setting a variable") (byte-defop 24 -1 byte-varbind "for binding a variable") @@ -569,7 +586,6 @@ Each element is (INDEX . VALUE)") (byte-defop 114 0 byte-save-current-buffer "To make a binding to record the current buffer") (byte-defop 115 0 byte-set-mark-OBSOLETE) -(byte-defop 116 1 byte-interactive-p) ;; These ops are new to v19 (byte-defop 117 0 byte-forward-char) @@ -605,8 +621,6 @@ otherwise pop it") (byte-defop 138 0 byte-save-excursion "to make a binding to record the buffer, point and mark") -(byte-defop 139 0 byte-save-window-excursion - "to make a binding to record entire window configuration") (byte-defop 140 0 byte-save-restriction "to make a binding to record the current buffer clipping restrictions") (byte-defop 141 -1 byte-catch @@ -622,13 +636,13 @@ otherwise pop it") ;; Takes, on stack, the buffer name. ;; Binds standard-output and does some other things. ;; Returns with temp buffer on the stack in place of buffer name. -(byte-defop 144 0 byte-temp-output-buffer-setup) +;; (byte-defop 144 0 byte-temp-output-buffer-setup) ;; For exit from with-output-to-temp-buffer. ;; Expects the temp buffer on the stack underneath value to return. ;; Pops them both, then pushes the value back on. ;; Unbinds standard-output and makes the temp buffer visible. -(byte-defop 145 -1 byte-temp-output-buffer-show) +;; (byte-defop 145 -1 byte-temp-output-buffer-show) ;; these ops are new to v19 @@ -661,11 +675,26 @@ otherwise pop it") (byte-defop 168 0 byte-integerp) ;; unused: 169-174 + (byte-defop 175 nil byte-listN) (byte-defop 176 nil byte-concatN) (byte-defop 177 nil byte-insertN) -;; unused: 178-191 +(byte-defop 178 -1 byte-stack-set) ; stack offset in following one byte +(byte-defop 179 -1 byte-stack-set2) ; stack offset in following two bytes + +;; if (following one byte & 0x80) == 0 +;; discard (following one byte & 0x7F) stack entries +;; else +;; discard (following one byte & 0x7F) stack entries _underneath_ the top of stack +;; (that is, if the operand = 0x83, ... X Y Z T => ... T) +(byte-defop 182 nil byte-discardN) +;; `byte-discardN-preserve-tos' is a pseudo-op that gets turned into +;; `byte-discardN' with the high bit in the operand set (by +;; `byte-compile-lapcode'). +(defconst byte-discardN-preserve-tos byte-discardN) + +;; unused: 182-191 (byte-defop 192 1 byte-constant "for reference to a constant") ;; codes 193-255 are consumed by byte-constant. @@ -712,71 +741,116 @@ otherwise pop it") ;; front of the constants-vector than the constant-referencing instructions. ;; Also, this lets us notice references to free variables. +(defmacro byte-compile-push-bytecodes (&rest args) + "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed. +ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names. +BYTES and PC are updated after evaluating all the arguments." + (let ((byte-exprs (butlast args 2)) + (bytes-var (car (last args 2))) + (pc-var (car (last args)))) + `(setq ,bytes-var ,(if (null (cdr byte-exprs)) + `(progn (assert (<= 0 ,(car byte-exprs))) + (cons ,@byte-exprs ,bytes-var)) + `(nconc (list ,@(reverse byte-exprs)) ,bytes-var)) + ,pc-var (+ ,(length byte-exprs) ,pc-var)))) + +(defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc) + "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC. +CONST2 may be evaulated multiple times." + `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8) + ,bytes ,pc)) + (defun byte-compile-lapcode (lap) "Turns lapcode into bytecode. The lapcode is destroyed." ;; Lapcode modifications: changes the ID of a tag to be the tag's PC. (let ((pc 0) ; Program counter op off ; Operation & offset + opcode ; numeric value of OP (bytes '()) ; Put the output bytes here - (patchlist nil)) ; List of tags and goto's to patch - (while lap - (setq op (car (car lap)) - off (cdr (car lap))) - (cond ((not (symbolp op)) - (error "Non-symbolic opcode `%s'" op)) - ((eq op 'TAG) - (setcar off pc) - (setq patchlist (cons off patchlist))) - ((memq op byte-goto-ops) - (setq pc (+ pc 3)) - (setq bytes (cons (cons pc (cdr off)) - (cons nil - (cons (symbol-value op) bytes)))) - (setq patchlist (cons bytes patchlist))) - (t - (setq bytes - (cond ((cond ((consp off) - ;; Variable or constant reference - (setq off (cdr off)) - (eq op 'byte-constant))) - (cond ((< off byte-constant-limit) - (setq pc (1+ pc)) - (cons (+ byte-constant off) bytes)) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons byte-constant2 bytes)))))) - ((<= byte-listN (symbol-value op)) - (setq pc (+ 2 pc)) - (cons off (cons (symbol-value op) bytes))) - ((< off 6) - (setq pc (1+ pc)) - (cons (+ (symbol-value op) off) bytes)) - ((< off 256) - (setq pc (+ 2 pc)) - (cons off (cons (+ (symbol-value op) 6) bytes))) - (t - (setq pc (+ 3 pc)) - (cons (lsh off -8) - (cons (logand off 255) - (cons (+ (symbol-value op) 7) - bytes)))))))) - (setq lap (cdr lap))) + (patchlist nil)) ; List of gotos to patch + (dolist (lap-entry lap) + (setq op (car lap-entry) + off (cdr lap-entry)) + (cond + ((not (symbolp op)) + (error "Non-symbolic opcode `%s'" op)) + ((eq op 'TAG) + (setcar off pc)) + ((null op) + ;; a no-op added by `byte-compile-delay-out' + (unless (zerop off) + (error + "Placeholder added by `byte-compile-delay-out' not filled in.") + )) + (t + (setq opcode + (if (eq op 'byte-discardN-preserve-tos) + ;; byte-discardN-preserve-tos is a pseudo op, which + ;; is actually the same as byte-discardN + ;; with a modified argument. + byte-discardN + (symbol-value op))) + (cond ((memq op byte-goto-ops) + ;; goto + (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc) + (push bytes patchlist)) + ((and (consp off) + ;; Variable or constant reference + (progn (setq off (cdr off)) + (eq op 'byte-constant))) + ;; constant ref + (if (< off byte-constant-limit) + (byte-compile-push-bytecodes (+ byte-constant off) + bytes pc) + (byte-compile-push-bytecode-const2 byte-constant2 off + bytes pc))) + ((and (= opcode byte-stack-set) + (> off 255)) + ;; Use the two-byte version of byte-stack-set if the + ;; offset is too large for the normal version. + (byte-compile-push-bytecode-const2 byte-stack-set2 off + bytes pc)) + ((and (>= opcode byte-listN) + (< opcode byte-discardN)) + ;; These insns all put their operand into one extra byte. + (byte-compile-push-bytecodes opcode off bytes pc)) + ((= opcode byte-discardN) + ;; byte-discardN is weird in that it encodes a flag in the + ;; top bit of its one-byte argument. If the argument is + ;; too large to fit in 7 bits, the opcode can be repeated. + (let ((flag (if (eq op 'byte-discardN-preserve-tos) #x80 0))) + (while (> off #x7f) + (byte-compile-push-bytecodes opcode (logior #x7f flag) bytes pc) + (setq off (- off #x7f))) + (byte-compile-push-bytecodes opcode (logior off flag) bytes pc))) + ((null off) + ;; opcode that doesn't use OFF + (byte-compile-push-bytecodes opcode bytes pc)) + ((and (eq opcode byte-stack-ref) (eq off 0)) + ;; (stack-ref 0) is really just another name for `dup'. + (debug) ;FIXME: When would this happen? + (byte-compile-push-bytecodes byte-dup bytes pc)) + ;; The following three cases are for the special + ;; insns that encode their operand into 0, 1, or 2 + ;; extra bytes depending on its magnitude. + ((< off 6) + (byte-compile-push-bytecodes (+ opcode off) bytes pc)) + ((< off 256) + (byte-compile-push-bytecodes (+ opcode 6) off bytes pc)) + (t + (byte-compile-push-bytecode-const2 (+ opcode 7) off + bytes pc)))))) ;;(if (not (= pc (length bytes))) ;; (error "Compiler error: pc mismatch - %s %s" pc (length bytes))) - ;; Patch PC into jumps - (let (bytes) - (while patchlist - (setq bytes (car patchlist)) - (cond ((atom (car bytes))) ; Tag - (t ; Absolute jump - (setq pc (car (cdr (car bytes)))) ; Pick PC from tag - (setcar (cdr bytes) (logand pc 255)) - (setcar bytes (lsh pc -8)) - ;; FIXME: Replace this by some workaround. - (if (> (car bytes) 255) (error "Bytecode overflow")))) - (setq patchlist (cdr patchlist)))) + + ;; Patch tag PCs into absolute jumps + (dolist (bytes-tail patchlist) + (setq pc (caar bytes-tail)) ; Pick PC from goto's tag + (setcar (cdr bytes-tail) (logand pc 255)) + (setcar bytes-tail (lsh pc -8)) + ;; FIXME: Replace this by some workaround. + (if (> (car bytes) 255) (error "Bytecode overflow"))) + (apply 'unibyte-string (nreverse bytes)))) @@ -1258,11 +1332,11 @@ extra args." (eq 'lambda (car-safe (cdr-safe old))) (setq old (cdr old))) (let ((sig1 (byte-compile-arglist-signature - (if (eq 'lambda (car-safe old)) - (nth 1 old) - (if (byte-code-function-p old) - (aref old 0) - '(&rest def))))) + (pcase old + (`(lambda ,args . ,_) args) + (`(closure ,_ ,_ ,args . ,_) args) + ((pred byte-code-function-p) (aref old 0)) + (t '(&rest def))))) (sig2 (byte-compile-arglist-signature (nth 2 form)))) (unless (byte-compile-arglist-signatures-congruent-p sig1 sig2) (byte-compile-set-symbol-position (nth 1 form)) @@ -1330,14 +1404,7 @@ extra args." ;; but such warnings are never useful, ;; so don't warn about them. macroexpand cl-macroexpand-all - cl-compiling-file))) - ;; Avoid warnings for things which are safe because they - ;; have suitable compiler macros, but those aren't - ;; expanded at this stage. There should probably be more - ;; here than caaar and friends. - (not (and (eq (get func 'byte-compile) - 'cl-byte-compile-compiler-macro) - (string-match "\\`c[ad]+r\\'" (symbol-name func))))) + cl-compiling-file)))) (byte-compile-warn "function `%s' from cl package called at runtime" func))) form) @@ -1574,7 +1641,7 @@ that already has a `.elc' file." "Non-nil to prevent byte-compiling of Emacs Lisp code. This is normally set in local file variables at the end of the elisp file: -;; Local Variables:\n;; no-byte-compile: t\n;; End: ") +\;; Local Variables:\n;; no-byte-compile: t\n;; End: ") ;Backslash for compile-main. ;;;###autoload(put 'no-byte-compile 'safe-local-variable 'booleanp) (defun byte-recompile-file (bytecomp-filename &optional bytecomp-force bytecomp-arg load) @@ -2118,18 +2185,18 @@ list that represents a doc string reference. (defun byte-compile-file-form (form) (let ((byte-compile-current-form nil) ; close over this for warnings. bytecomp-handler) - (cond - ((not (consp form)) - (byte-compile-keep-pending form)) - ((and (symbolp (car form)) - (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) - (cond ((setq form (funcall bytecomp-handler form)) - (byte-compile-flush-pending) - (byte-compile-output-file-form form)))) - ((eq form (setq form (macroexpand form byte-compile-macro-environment))) - (byte-compile-keep-pending form)) - (t - (byte-compile-file-form form))))) + (setq form (macroexpand-all form byte-compile-macro-environment)) + (if lexical-binding + (setq form (cconv-closure-convert form))) + (cond ((not (consp form)) + (byte-compile-keep-pending form)) + ((and (symbolp (car form)) + (setq bytecomp-handler (get (car form) 'byte-hunk-handler))) + (cond ((setq form (funcall bytecomp-handler form)) + (byte-compile-flush-pending) + (byte-compile-output-file-form form)))) + (t + (byte-compile-keep-pending form))))) ;; Functions and variables with doc strings must be output separately, ;; so make-docfile can recognise them. Most other things can be output @@ -2141,8 +2208,7 @@ list that represents a doc string reference. (setq byte-compile-current-form (nth 1 form)) (byte-compile-warn "defsubst `%s' was used before it was defined" (nth 1 form))) - (byte-compile-file-form - (macroexpand form byte-compile-macro-environment)) + (byte-compile-file-form form) ;; Return nil so the form is not output twice. nil) @@ -2468,6 +2534,14 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if macro (setq fun (cdr fun))) (cond ((eq (car-safe fun) 'lambda) + ;; Expand macros. + (setq fun + (macroexpand-all fun + byte-compile-initial-macro-environment)) + (if lexical-binding + (setq fun (cconv-closure-convert fun))) + ;; Get rid of the `function' quote added by the `lambda' macro. + (setq fun (cadr fun)) (setq fun (if macro (cons 'macro (byte-compile-lambda fun)) (byte-compile-lambda fun))) @@ -2555,6 +2629,24 @@ If FORM is a lambda or a macro, byte-compile it as a function." (setq list (cdr list))))) +(defun byte-compile-arglist-vars (arglist) + "Return a list of the variables in the lambda argument list ARGLIST." + (remq '&rest (remq '&optional arglist))) + +(defun byte-compile-make-lambda-lexenv (form) + "Return a new lexical environment for a lambda expression FORM." + ;; See if this is a closure or not + (let ((args (byte-compile-arglist-vars (cadr form)))) + (let ((lexenv nil)) + ;; Fill in the initial stack contents + (let ((stackpos 0)) + ;; Add entries for each argument + (dolist (arg args) + (push (cons arg stackpos) lexenv) + (setq stackpos (1+ stackpos))) + ;; Return the new lexical environment + lexenv)))) + ;; Byte-compile a lambda-expression and return a valid function. ;; The value is usually a compiled function but may be the original ;; lambda-expression. @@ -2571,17 +2663,16 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-check-lambda-list (nth 1 bytecomp-fun)) (let* ((bytecomp-arglist (nth 1 bytecomp-fun)) (byte-compile-bound-variables - (nconc (and (byte-compile-warning-enabled-p 'free-vars) - (delq '&rest - (delq '&optional (copy-sequence bytecomp-arglist)))) - byte-compile-bound-variables)) + (append (and (not lexical-binding) + (byte-compile-arglist-vars bytecomp-arglist)) + byte-compile-bound-variables)) (bytecomp-body (cdr (cdr bytecomp-fun))) (bytecomp-doc (if (stringp (car bytecomp-body)) - (prog1 (car bytecomp-body) - ;; Discard the doc string - ;; unless it is the last element of the body. - (if (cdr bytecomp-body) - (setq bytecomp-body (cdr bytecomp-body)))))) + (prog1 (car bytecomp-body) + ;; Discard the doc string + ;; unless it is the last element of the body. + (if (cdr bytecomp-body) + (setq bytecomp-body (cdr bytecomp-body)))))) (bytecomp-int (assq 'interactive bytecomp-body))) ;; Process the interactive spec. (when bytecomp-int @@ -2605,26 +2696,35 @@ If FORM is a lambda or a macro, byte-compile it as a function." (if (eq (car-safe form) 'list) (byte-compile-top-level (nth 1 bytecomp-int)) (setq bytecomp-int (list 'interactive - (byte-compile-top-level - (nth 1 bytecomp-int))))))) + (byte-compile-top-level + (nth 1 bytecomp-int))))))) ((cdr bytecomp-int) (byte-compile-warn "malformed interactive spec: %s" (prin1-to-string bytecomp-int))))) ;; Process the body. - (let ((compiled (byte-compile-top-level - (cons 'progn bytecomp-body) nil 'lambda))) + (let* ((byte-compile-lexical-environment + ;; If doing lexical binding, push a new lexical environment + ;; containing just the args (since lambda expressions + ;; should be closed by now). + (and lexical-binding + (byte-compile-make-lambda-lexenv bytecomp-fun))) + (compiled + (byte-compile-top-level (cons 'progn bytecomp-body) nil 'lambda))) ;; Build the actual byte-coded function. (if (eq 'byte-code (car-safe compiled)) - (apply 'make-byte-code - (append (list bytecomp-arglist) - ;; byte-string, constants-vector, stack depth - (cdr compiled) - ;; optionally, the doc string. - (if (or bytecomp-doc bytecomp-int) - (list bytecomp-doc)) - ;; optionally, the interactive spec. - (if bytecomp-int - (list (nth 1 bytecomp-int))))) + (apply 'make-byte-code + (append (list bytecomp-arglist) + ;; byte-string, constants-vector, stack depth + (cdr compiled) + ;; optionally, the doc string. + (if (or bytecomp-doc bytecomp-int + lexical-binding) + (list bytecomp-doc)) + ;; optionally, the interactive spec. + (if (or bytecomp-int lexical-binding) + (list (nth 1 bytecomp-int))) + (if lexical-binding + '(t)))) (setq compiled (nconc (if bytecomp-int (list bytecomp-int)) (cond ((eq (car-safe compiled) 'progn) (cdr compiled)) @@ -2635,6 +2735,11 @@ If FORM is a lambda or a macro, byte-compile it as a function." (bytecomp-body (list nil)))) compiled)))))) +(defun byte-compile-closure (form &optional add-lambda) + (let ((code (byte-compile-lambda form add-lambda))) + ;; A simple lambda is just a constant. + (byte-compile-constant code))) + (defun byte-compile-constants-vector () ;; Builds the constants-vector from the current variables and constants. ;; This modifies the constants from (const . nil) to (const . offset). @@ -2678,18 +2783,31 @@ If FORM is a lambda or a macro, byte-compile it as a function." (byte-compile-tag-number 0) (byte-compile-depth 0) (byte-compile-maxdepth 0) + (byte-compile-lexical-environment + (when (eq output-type 'lambda) + byte-compile-lexical-environment)) (byte-compile-output nil)) - (if (memq byte-optimize '(t source)) - (setq form (byte-optimize-form form for-effect))) - (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) - (setq form (nth 1 form))) - (if (and (eq 'byte-code (car-safe form)) - (not (memq byte-optimize '(t byte))) - (stringp (nth 1 form)) (vectorp (nth 2 form)) - (natnump (nth 3 form))) - form - (byte-compile-form form for-effect) - (byte-compile-out-toplevel for-effect output-type)))) + (if (memq byte-optimize '(t source)) + (setq form (byte-optimize-form form for-effect))) + (while (and (eq (car-safe form) 'progn) (null (cdr (cdr form)))) + (setq form (nth 1 form))) + (if (and (eq 'byte-code (car-safe form)) + (not (memq byte-optimize '(t byte))) + (stringp (nth 1 form)) (vectorp (nth 2 form)) + (natnump (nth 3 form))) + form + ;; Set up things for a lexically-bound function. + (when (and lexical-binding (eq output-type 'lambda)) + ;; See how many arguments there are, and set the current stack depth + ;; accordingly. + (setq byte-compile-depth (length byte-compile-lexical-environment)) + ;; If there are args, output a tag to record the initial + ;; stack-depth for the optimizer. + (when (> byte-compile-depth 0) + (byte-compile-out-tag (byte-compile-make-tag)))) + ;; Now compile FORM + (byte-compile-form form for-effect) + (byte-compile-out-toplevel for-effect output-type)))) (defun byte-compile-out-toplevel (&optional for-effect output-type) (if for-effect @@ -2778,6 +2896,7 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; Given BYTECOMP-BODY, compile it and return a new body. (defun byte-compile-top-level-body (bytecomp-body &optional for-effect) + ;; FIXME: lexbind. Check all callers! (setq bytecomp-body (byte-compile-top-level (cons 'progn bytecomp-body) for-effect t)) (cond ((eq (car-safe bytecomp-body) 'progn) @@ -2811,7 +2930,6 @@ If FORM is a lambda or a macro, byte-compile it as a function." ;; (Use byte-compile-form-do-effect to reset the for-effect flag too.) ;; (defun byte-compile-form (form &optional for-effect) - (setq form (macroexpand form byte-compile-macro-environment)) (cond ((not (consp form)) (cond ((or (not (symbolp form)) (byte-compile-const-symbol-p form)) (when (symbolp form) @@ -2821,7 +2939,8 @@ If FORM is a lambda or a macro, byte-compile it as a function." (when (symbolp form) (byte-compile-set-symbol-position form)) (setq for-effect nil)) - (t (byte-compile-variable-ref 'byte-varref form)))) + (t + (byte-compile-variable-ref form)))) ((symbolp (car form)) (let* ((bytecomp-fn (car form)) (bytecomp-handler (get bytecomp-fn 'byte-compile))) @@ -2835,16 +2954,21 @@ That command is designed for interactive use only" bytecomp-fn)) (if (memq bytecomp-fn '(custom-declare-group custom-declare-variable custom-declare-face)) - (byte-compile-nogroup-warn form)) + (byte-compile-nogroup-warn form)) (byte-compile-callargs-warn form)) + (if (and (fboundp (car form)) + (eq (car-safe (symbol-function (car form))) 'macro)) + (byte-compile-report-error + (format "Forgot to expand macro %s" (car form)))) (if (and bytecomp-handler ;; Make sure that function exists. This is important ;; for CL compiler macros since the symbol may be ;; `cl-byte-compile-compiler-macro' but if CL isn't ;; loaded, this function doesn't exist. - (or (not (memq bytecomp-handler - '(cl-byte-compile-compiler-macro))) - (functionp bytecomp-handler))) + (and (not (eq bytecomp-handler + ;; Already handled by macroexpand-all. + 'cl-byte-compile-compiler-macro)) + (functionp bytecomp-handler))) (funcall bytecomp-handler form) (byte-compile-normal-call form)) (if (byte-compile-warning-enabled-p 'cl-functions) @@ -2872,44 +2996,67 @@ That command is designed for interactive use only" bytecomp-fn)) (mapc 'byte-compile-form (cdr form)) ; wasteful, but faster. (byte-compile-out 'byte-call (length (cdr form)))) -(defun byte-compile-variable-ref (base-op bytecomp-var) - (when (symbolp bytecomp-var) - (byte-compile-set-symbol-position bytecomp-var)) - (if (or (not (symbolp bytecomp-var)) - (byte-compile-const-symbol-p bytecomp-var - (not (eq base-op 'byte-varref)))) - (if (byte-compile-warning-enabled-p 'constants) - (byte-compile-warn - (cond ((eq base-op 'byte-varbind) "attempt to let-bind %s `%s'") - ((eq base-op 'byte-varset) "variable assignment to %s `%s'") - (t "variable reference to %s `%s'")) - (if (symbolp bytecomp-var) "constant" "nonvariable") - (prin1-to-string bytecomp-var))) - (and (get bytecomp-var 'byte-obsolete-variable) - (not (memq bytecomp-var byte-compile-not-obsolete-vars)) - (byte-compile-warn-obsolete bytecomp-var)) - (if (eq base-op 'byte-varbind) - (push bytecomp-var byte-compile-bound-variables) - (or (not (byte-compile-warning-enabled-p 'free-vars)) - (boundp bytecomp-var) - (memq bytecomp-var byte-compile-bound-variables) - (if (eq base-op 'byte-varset) - (or (memq bytecomp-var byte-compile-free-assignments) - (progn - (byte-compile-warn "assignment to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-assignments))) - (or (memq bytecomp-var byte-compile-free-references) - (progn - (byte-compile-warn "reference to free variable `%s'" - bytecomp-var) - (push bytecomp-var byte-compile-free-references))))))) - (let ((tmp (assq bytecomp-var byte-compile-variables))) +(defun byte-compile-check-variable (var &optional binding) + "Do various error checks before a use of the variable VAR. +If BINDING is non-nil, VAR is being bound." + (when (symbolp var) + (byte-compile-set-symbol-position var)) + (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var)) + (when (byte-compile-warning-enabled-p 'constants) + (byte-compile-warn (if binding + "attempt to let-bind %s `%s`" + "variable reference to %s `%s'") + (if (symbolp var) "constant" "nonvariable") + (prin1-to-string var)))) + ((and (get var 'byte-obsolete-variable) + (not (memq var byte-compile-not-obsolete-vars))) + (byte-compile-warn-obsolete var)))) + +(defsubst byte-compile-dynamic-variable-op (base-op var) + (let ((tmp (assq var byte-compile-variables))) (unless tmp - (setq tmp (list bytecomp-var)) + (setq tmp (list var)) (push tmp byte-compile-variables)) (byte-compile-out base-op tmp))) +(defun byte-compile-dynamic-variable-bind (var) + "Generate code to bind the lexical variable VAR to the top-of-stack value." + (byte-compile-check-variable var t) + (push var byte-compile-bound-variables) + (byte-compile-dynamic-variable-op 'byte-varbind var)) + +(defun byte-compile-variable-ref (var) + "Generate code to push the value of the variable VAR on the stack." + (byte-compile-check-variable var) + (let ((lex-binding (assq var byte-compile-lexical-environment))) + (if lex-binding + ;; VAR is lexically bound + (byte-compile-stack-ref (cdr lex-binding)) + ;; VAR is dynamically bound + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-references)) + (byte-compile-warn "reference to free variable `%s'" var) + (push var byte-compile-free-references)) + (byte-compile-dynamic-variable-op 'byte-varref var)))) + +(defun byte-compile-variable-set (var) + "Generate code to set the variable VAR from the top-of-stack value." + (byte-compile-check-variable var) + (let ((lex-binding (assq var byte-compile-lexical-environment))) + (if lex-binding + ;; VAR is lexically bound + (byte-compile-stack-set (cdr lex-binding)) + ;; VAR is dynamically bound + (unless (or (not (byte-compile-warning-enabled-p 'free-vars)) + (boundp var) + (memq var byte-compile-bound-variables) + (memq var byte-compile-free-assignments)) + (byte-compile-warn "assignment to free variable `%s'" var) + (push var byte-compile-free-assignments)) + (byte-compile-dynamic-variable-op 'byte-varset var)))) + (defmacro byte-compile-get-constant (const) `(or (if (stringp ,const) ;; In a string constant, treat properties as significant. @@ -2936,6 +3083,25 @@ That command is designed for interactive use only" bytecomp-fn)) (let ((for-effect nil)) (inline (byte-compile-constant const)))) +(defun byte-compile-push-unknown-constant (&optional id) + "Generate code to push a `constant' who's value isn't known yet. +A tag is returned which may then later be passed to +`byte-compile-resolve-unknown-constant' to finalize the value. +The optional argument ID is a tag returned by an earlier call to +`byte-compile-push-unknown-constant', in which case the same constant is +pushed again." + (unless id + (setq id (list (make-symbol "unknown"))) + (push id byte-compile-constants)) + (byte-compile-out 'byte-constant id) + id) + +(defun byte-compile-resolve-unknown-constant (id value) + "Give an `unknown constant' a value. +ID is the tag returned by `byte-compile-push-unknown-constant'. and VALUE +is the value it should have." + (setcar id value)) + ;; Compile those primitive ordinary functions ;; which have special byte codes just for speed. @@ -3006,7 +3172,6 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler bobp 0) (byte-defop-compiler current-buffer 0) ;;(byte-defop-compiler read-char 0) ;; obsolete -(byte-defop-compiler interactive-p 0) (byte-defop-compiler widen 0) (byte-defop-compiler end-of-line 0-1) (byte-defop-compiler forward-char 0-1) @@ -3139,8 +3304,40 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (defun byte-compile-noop (form) (byte-compile-constant nil)) -(defun byte-compile-discard () - (byte-compile-out 'byte-discard 0)) +(defun byte-compile-discard (&optional num preserve-tos) + "Output byte codes to discard the NUM entries at the top of the stack (NUM defaults to 1). +If PRESERVE-TOS is non-nil, preserve the top-of-stack value, as if it were +popped before discarding the num values, and then pushed back again after +discarding." + (if (and (null num) (not preserve-tos)) + ;; common case + (byte-compile-out 'byte-discard) + ;; general case + (unless num + (setq num 1)) + (when (and preserve-tos (> num 0)) + ;; Preserve the top-of-stack value by writing it directly to the stack + ;; location which will be at the top-of-stack after popping. + (byte-compile-stack-set (1- (- byte-compile-depth num))) + ;; Now we actually discard one less value, since we want to keep + ;; the eventual TOS + (setq num (1- num))) + (while (> num 0) + (byte-compile-out 'byte-discard) + (setq num (1- num))))) + +(defun byte-compile-stack-ref (stack-pos) + "Output byte codes to push the value at position STACK-POS in the stack, on the top of the stack." + (let ((dist (- byte-compile-depth (1+ stack-pos)))) + (if (zerop dist) + ;; A simple optimization + (byte-compile-out 'byte-dup) + ;; normal case + (byte-compile-out 'byte-stack-ref dist)))) + +(defun byte-compile-stack-set (stack-pos) + "Output byte codes to store the top-of-stack value at position STACK-POS in the stack." + (byte-compile-out 'byte-stack-set (- byte-compile-depth (1+ stack-pos)))) ;; Compile a function that accepts one or more args and is right-associative. @@ -3299,40 +3496,14 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" the syntax (function (lambda (...) ...)) instead."))))) (byte-compile-two-args form)) -(defun byte-compile-funarg (form) - ;; (mapcar '(lambda (x) ..) ..) ==> (mapcar (function (lambda (x) ..)) ..) - ;; for cases where it's guaranteed that first arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 1 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (cons 'function (cdr fn)) - (cdr (cdr form)))) - form)))) - -(defun byte-compile-funarg-2 (form) - ;; (sort ... '(lambda (x) ..)) ==> (sort ... (function (lambda (x) ..))) - ;; for cases where it's guaranteed that second arg will be used as a lambda. - (byte-compile-normal-call - (let ((fn (nth 2 form))) - (if (and (eq (car-safe fn) 'quote) - (eq (car-safe (nth 1 fn)) 'lambda)) - (cons (car form) - (cons (nth 1 form) - (cons (cons 'function (cdr fn)) - (cdr (cdr (cdr form)))))) - form)))) - ;; (function foo) must compile like 'foo, not like (symbol-function 'foo). ;; Otherwise it will be incompatible with the interpreter, ;; and (funcall (function foo)) will lose with autoloads. (defun byte-compile-function-form (form) - (byte-compile-constant - (cond ((symbolp (nth 1 form)) - (nth 1 form)) - ((byte-compile-lambda (nth 1 form)))))) + (if (symbolp (nth 1 form)) + (byte-compile-constant (nth 1 form)) + (byte-compile-closure (nth 1 form)))) (defun byte-compile-indent-to (form) (let ((len (length form))) @@ -3376,7 +3547,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-compile-form (car (cdr bytecomp-args))) (or for-effect (cdr (cdr bytecomp-args)) (byte-compile-out 'byte-dup 0)) - (byte-compile-variable-ref 'byte-varset (car bytecomp-args)) + (byte-compile-variable-set (car bytecomp-args)) (setq bytecomp-args (cdr (cdr bytecomp-args)))) ;; (setq), with no arguments. (byte-compile-form nil for-effect)) @@ -3442,18 +3613,8 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (byte-defop-compiler-1 or) (byte-defop-compiler-1 while) (byte-defop-compiler-1 funcall) -(byte-defop-compiler-1 apply byte-compile-funarg) -(byte-defop-compiler-1 mapcar byte-compile-funarg) -(byte-defop-compiler-1 mapatoms byte-compile-funarg) -(byte-defop-compiler-1 mapconcat byte-compile-funarg) -(byte-defop-compiler-1 mapc byte-compile-funarg) -(byte-defop-compiler-1 maphash byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg) -(byte-defop-compiler-1 map-char-table byte-compile-funarg-2) -;; map-charset-chars should be funarg but has optional third arg -(byte-defop-compiler-1 sort byte-compile-funarg-2) (byte-defop-compiler-1 let) -(byte-defop-compiler-1 let*) +(byte-defop-compiler-1 let* byte-compile-let) (defun byte-compile-progn (form) (byte-compile-body-do-effect (cdr form))) @@ -3518,9 +3679,7 @@ that suppresses all warnings during execution of BODY." ,condition (list 'boundp 'default-boundp))) ;; Maybe add to the bound list. (byte-compile-bound-variables - (if bound-list - (append bound-list byte-compile-bound-variables) - byte-compile-bound-variables))) + (append bound-list byte-compile-bound-variables))) (unwind-protect ;; If things not being bound at all is ok, so must them being obsolete. ;; Note that we add to the existing lists since Tramp (ab)uses @@ -3646,34 +3805,120 @@ that suppresses all warnings during execution of BODY." (mapc 'byte-compile-form (cdr form)) (byte-compile-out 'byte-call (length (cdr (cdr form))))) + +;; let binding + +(defun byte-compile-push-binding-init (clause) + "Emit byte-codes to push the initialization value for CLAUSE on the stack. +Return the offset in the form (VAR . OFFSET)." + (let* ((var (if (consp clause) (car clause) clause))) + ;; We record the stack position even of dynamic bindings and + ;; variables in non-stack lexical environments; we'll put + ;; them in the proper place below. + (prog1 (cons var byte-compile-depth) + (if (consp clause) + (byte-compile-form (cadr clause)) + (byte-compile-push-constant nil))))) + +(defun byte-compile-not-lexical-var-p (var) + (or (not (symbolp var)) + (special-variable-p var) + (memq var byte-compile-bound-variables) + (memq var '(nil t)) + (keywordp var))) + +(defun byte-compile-bind (var init-lexenv) + "Emit byte-codes to bind VAR and update `byte-compile-lexical-environment'. +INIT-LEXENV should be a lexical-environment alist describing the +positions of the init value that have been pushed on the stack. +Return non-nil if the TOS value was popped." + ;; The presence of lexical bindings mean that we may have to + ;; juggle things on the stack, to move them to TOS for + ;; dynamic binding. + (cond ((not (byte-compile-not-lexical-var-p var)) + ;; VAR is a simple stack-allocated lexical variable + (push (assq var init-lexenv) + byte-compile-lexical-environment) + nil) + ((eq var (caar init-lexenv)) + ;; VAR is dynamic and is on the top of the + ;; stack, so we can just bind it like usual + (byte-compile-dynamic-variable-bind var) + t) + (t + ;; VAR is dynamic, but we have to get its + ;; value out of the middle of the stack + (let ((stack-pos (cdr (assq var init-lexenv)))) + (byte-compile-stack-ref stack-pos) + (byte-compile-dynamic-variable-bind var) + ;; Now we have to store nil into its temporary + ;; stack position to avoid problems with GC + (byte-compile-push-constant nil) + (byte-compile-stack-set stack-pos)) + nil))) + +(defun byte-compile-unbind (clauses init-lexenv + &optional preserve-body-value) + "Emit byte-codes to unbind the variables bound by CLAUSES. +CLAUSES is a `let'-style variable binding list. INIT-LEXENV should be a +lexical-environment alist describing the positions of the init value that +have been pushed on the stack. If PRESERVE-BODY-VALUE is true, +then an additional value on the top of the stack, above any lexical binding +slots, is preserved, so it will be on the top of the stack after all +binding slots have been popped." + ;; Unbind dynamic variables + (let ((num-dynamic-bindings 0)) + (dolist (clause clauses) + (unless (assq (if (consp clause) (car clause) clause) + byte-compile-lexical-environment) + (setq num-dynamic-bindings (1+ num-dynamic-bindings)))) + (unless (zerop num-dynamic-bindings) + (byte-compile-out 'byte-unbind num-dynamic-bindings))) + ;; Pop lexical variables off the stack, possibly preserving the + ;; return value of the body. + (when init-lexenv + ;; INIT-LEXENV contains all init values left on the stack + (byte-compile-discard (length init-lexenv) preserve-body-value))) (defun byte-compile-let (form) - ;; First compute the binding values in the old scope. - (let ((varlist (car (cdr form)))) - (dolist (var varlist) - (if (consp var) - (byte-compile-form (car (cdr var))) - (byte-compile-push-constant nil)))) - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (reverse (car (cdr form))))) - (dolist (var varlist) - (byte-compile-variable-ref 'byte-varbind - (if (consp var) (car var) var))) - (byte-compile-body-do-effect (cdr (cdr form))) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) - -(defun byte-compile-let* (form) - (let ((byte-compile-bound-variables byte-compile-bound-variables) ;new scope - (varlist (copy-sequence (car (cdr form))))) - (dolist (var varlist) - (if (atom var) - (byte-compile-push-constant nil) - (byte-compile-form (car (cdr var))) - (setq var (car var))) - (byte-compile-variable-ref 'byte-varbind var)) - (byte-compile-body-do-effect (cdr (cdr form))) - (byte-compile-out 'byte-unbind (length (car (cdr form)))))) + "Generate code for the `let' form FORM." + (let ((clauses (cadr form)) + (init-lexenv nil)) + (when (eq (car form) 'let) + ;; First compute the binding values in the old scope. + (dolist (var clauses) + (push (byte-compile-push-binding-init var) init-lexenv))) + ;; New scope. + (let ((byte-compile-bound-variables byte-compile-bound-variables) + (byte-compile-lexical-environment byte-compile-lexical-environment)) + ;; Bind the variables. + ;; For `let', do it in reverse order, because it makes no + ;; semantic difference, but it is a lot more efficient since the + ;; values are now in reverse order on the stack. + (dolist (var (if (eq (car form) 'let) (reverse clauses) clauses)) + (unless (eq (car form) 'let) + (push (byte-compile-push-binding-init var) init-lexenv)) + (let ((var (if (consp var) (car var) var))) + (cond ((null lexical-binding) + ;; If there are no lexical bindings, we can do things simply. + (byte-compile-dynamic-variable-bind var)) + ((byte-compile-bind var init-lexenv) + (pop init-lexenv))))) + ;; Emit the body. + (let ((init-stack-depth byte-compile-depth)) + (byte-compile-body-do-effect (cdr (cdr form))) + ;; Unbind the variables. + (if lexical-binding + ;; Unbind both lexical and dynamic variables. + (progn + (assert (or (eq byte-compile-depth init-stack-depth) + (eq byte-compile-depth (1+ init-stack-depth)))) + (byte-compile-unbind clauses init-lexenv (> byte-compile-depth + init-stack-depth))) + ;; Unbind dynamic variables. + (byte-compile-out 'byte-unbind (length clauses))))))) + (byte-defop-compiler-1 /= byte-compile-negated) (byte-defop-compiler-1 atom byte-compile-negated) @@ -3696,6 +3941,7 @@ that suppresses all warnings during execution of BODY." "Compiler error: `%s' has no `byte-compile-negated-op' property" (car form))) (cdr form)))) + ;;; other tricky macro-like special-forms @@ -3705,70 +3951,84 @@ that suppresses all warnings during execution of BODY." (byte-defop-compiler-1 save-excursion) (byte-defop-compiler-1 save-current-buffer) (byte-defop-compiler-1 save-restriction) -(byte-defop-compiler-1 save-window-excursion) -(byte-defop-compiler-1 with-output-to-temp-buffer) (byte-defop-compiler-1 track-mouse) (defun byte-compile-catch (form) (byte-compile-form (car (cdr form))) - (byte-compile-push-constant - (byte-compile-top-level (cons 'progn (cdr (cdr form))) for-effect)) + (pcase (cddr form) + (`(:fun-body ,f) + (byte-compile-form `(list 'funcall ,f))) + (body + (byte-compile-push-constant + (byte-compile-top-level (cons 'progn body) for-effect)))) (byte-compile-out 'byte-catch 0)) (defun byte-compile-unwind-protect (form) - (byte-compile-push-constant - (byte-compile-top-level-body (cdr (cdr form)) t)) + (pcase (cddr form) + (`(:fun-body ,f) + (byte-compile-form `(list (list 'funcall ,f)))) + (handlers + (byte-compile-push-constant + (byte-compile-top-level-body handlers t)))) (byte-compile-out 'byte-unwind-protect 0) (byte-compile-form-do-effect (car (cdr form))) (byte-compile-out 'byte-unbind 1)) (defun byte-compile-track-mouse (form) (byte-compile-form - `(funcall '(lambda nil - (track-mouse ,@(byte-compile-top-level-body (cdr form))))))) + (pcase form + (`(,_ :fun-body ,f) `(eval (list 'track-mouse (list 'funcall ,f)))) + (_ `(eval '(track-mouse ,@(byte-compile-top-level-body (cdr form)))))))) (defun byte-compile-condition-case (form) (let* ((var (nth 1 form)) - (byte-compile-bound-variables - (if var (cons var byte-compile-bound-variables) + (fun-bodies (eq var :fun-body)) + (byte-compile-bound-variables + (if (and var (not fun-bodies)) + (cons var byte-compile-bound-variables) byte-compile-bound-variables))) (byte-compile-set-symbol-position 'condition-case) (unless (symbolp var) (byte-compile-warn "`%s' is not a variable-name or nil (in condition-case)" var)) + (if fun-bodies (setq var (make-symbol "err"))) (byte-compile-push-constant var) - (byte-compile-push-constant (byte-compile-top-level - (nth 2 form) for-effect)) - (let ((clauses (cdr (cdr (cdr form)))) - compiled-clauses) - (while clauses - (let* ((clause (car clauses)) - (condition (car clause))) - (cond ((not (or (symbolp condition) - (and (listp condition) - (let ((syms condition) (ok t)) - (while syms - (if (not (symbolp (car syms))) - (setq ok nil)) - (setq syms (cdr syms))) - ok)))) - (byte-compile-warn - "`%s' is not a condition name or list of such (in condition-case)" - (prin1-to-string condition))) -;; ((not (or (eq condition 't) -;; (and (stringp (get condition 'error-message)) -;; (consp (get condition 'error-conditions))))) -;; (byte-compile-warn -;; "`%s' is not a known condition name (in condition-case)" -;; condition)) - ) - (setq compiled-clauses - (cons (cons condition - (byte-compile-top-level-body - (cdr clause) for-effect)) - compiled-clauses))) - (setq clauses (cdr clauses))) - (byte-compile-push-constant (nreverse compiled-clauses))) + (if fun-bodies + (byte-compile-form `(list 'funcall ,(nth 2 form))) + (byte-compile-push-constant + (byte-compile-top-level (nth 2 form) for-effect))) + (let ((compiled-clauses + (mapcar + (lambda (clause) + (let ((condition (car clause))) + (cond ((not (or (symbolp condition) + (and (listp condition) + (let ((ok t)) + (dolist (sym condition) + (if (not (symbolp sym)) + (setq ok nil))) + ok)))) + (byte-compile-warn + "`%S' is not a condition name or list of such (in condition-case)" + condition)) + ;; (not (or (eq condition 't) + ;; (and (stringp (get condition 'error-message)) + ;; (consp (get condition + ;; 'error-conditions))))) + ;; (byte-compile-warn + ;; "`%s' is not a known condition name + ;; (in condition-case)" + ;; condition)) + ) + (if fun-bodies + `(list ',condition (list 'funcall ,(cadr clause) ',var)) + (cons condition + (byte-compile-top-level-body + (cdr clause) for-effect))))) + (cdr (cdr (cdr form)))))) + (if fun-bodies + (byte-compile-form `(list ,@compiled-clauses)) + (byte-compile-push-constant compiled-clauses))) (byte-compile-out 'byte-condition-case 0))) @@ -3789,17 +4049,6 @@ that suppresses all warnings during execution of BODY." (byte-compile-out 'byte-save-current-buffer 0) (byte-compile-body-do-effect (cdr form)) (byte-compile-out 'byte-unbind 1)) - -(defun byte-compile-save-window-excursion (form) - (byte-compile-push-constant - (byte-compile-top-level-body (cdr form) for-effect)) - (byte-compile-out 'byte-save-window-excursion 0)) - -(defun byte-compile-with-output-to-temp-buffer (form) - (byte-compile-form (car (cdr form))) - (byte-compile-out 'byte-temp-output-buffer-setup 0) - (byte-compile-body (cdr (cdr form))) - (byte-compile-out 'byte-temp-output-buffer-show 0)) ;;; top-level forms elsewhere @@ -3816,28 +4065,23 @@ that suppresses all warnings during execution of BODY." (byte-compile-set-symbol-position (car form)) (byte-compile-set-symbol-position 'defun) (error "defun name must be a symbol, not %s" (car form))) - ;; We prefer to generate a defalias form so it will record the function - ;; definition just like interpreting a defun. - (byte-compile-form - (list 'defalias - (list 'quote (nth 1 form)) - (byte-compile-byte-code-maker - (byte-compile-lambda (cdr (cdr form)) t))) - t) - (byte-compile-constant (nth 1 form))) + (let ((for-effect nil)) + (byte-compile-push-constant 'defalias) + (byte-compile-push-constant (nth 1 form)) + (byte-compile-closure (cdr (cdr form)) t)) + (byte-compile-out 'byte-call 2)) (defun byte-compile-defmacro (form) ;; This is not used for file-level defmacros with doc strings. - (byte-compile-body-do-effect - (let ((decls (byte-compile-defmacro-declaration form)) - (code (byte-compile-byte-code-maker - (byte-compile-lambda (cdr (cdr form)) t)))) - `((defalias ',(nth 1 form) - ,(if (eq (car-safe code) 'make-byte-code) - `(cons 'macro ,code) - `'(macro . ,(eval code)))) - ,@decls - ',(nth 1 form))))) + ;; FIXME handle decls, use defalias? + (let ((decls (byte-compile-defmacro-declaration form)) + (code (byte-compile-lambda (cdr (cdr form)) t)) + (for-effect nil)) + (byte-compile-push-constant (nth 1 form)) + (byte-compile-push-constant (cons 'macro code)) + (byte-compile-out 'byte-fset) + (byte-compile-discard)) + (byte-compile-constant (nth 1 form))) (defun byte-compile-defvar (form) ;; This is not used for file-level defvar/consts with doc strings. @@ -3868,7 +4112,7 @@ that suppresses all warnings during execution of BODY." ;; Put the defined variable in this library's load-history entry ;; just as a real defvar would, but only in top-level forms. (when (and (cddr form) (null byte-compile-current-form)) - `(push ',var current-load-list)) + `(setq current-load-list (cons ',var current-load-list))) (when (> (length form) 3) (when (and string (not (stringp string))) (byte-compile-warn "third arg to `%s %s' is not a string: %s" @@ -3885,7 +4129,7 @@ that suppresses all warnings during execution of BODY." `(if (not (default-boundp ',var)) (setq-default ,var ,value)))) (when (eq fun 'defconst) ;; This will signal an appropriate error at runtime. - `(eval ',form))) + `(eval ',form))) ;FIXME: lexbind `',var)))) (defun byte-compile-autoload (form) @@ -3977,8 +4221,8 @@ that suppresses all warnings during execution of BODY." (progn ;; ## remove this someday (and byte-compile-depth - (not (= (cdr (cdr tag)) byte-compile-depth)) - (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) + (not (= (cdr (cdr tag)) byte-compile-depth)) + (error "Compiler bug: depth conflict at tag %d" (car (cdr tag)))) (setq byte-compile-depth (cdr (cdr tag)))) (setcdr (cdr tag) byte-compile-depth))) @@ -3990,23 +4234,74 @@ that suppresses all warnings during execution of BODY." (setq byte-compile-depth (and (not (eq opcode 'byte-goto)) (1- byte-compile-depth)))) -(defun byte-compile-out (opcode offset) - (push (cons opcode offset) byte-compile-output) - (cond ((eq opcode 'byte-call) - (setq byte-compile-depth (- byte-compile-depth offset))) - ((eq opcode 'byte-return) - ;; This is actually an unnecessary case, because there should be - ;; no more opcodes behind byte-return. - (setq byte-compile-depth nil)) - (t - (setq byte-compile-depth (+ byte-compile-depth - (or (aref byte-stack+-info - (symbol-value opcode)) - (- (1- offset)))) - byte-compile-maxdepth (max byte-compile-depth - byte-compile-maxdepth)))) - ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) - ) +(defun byte-compile-stack-adjustment (op operand) + "Return the amount by which an operation adjusts the stack. +OP and OPERAND are as passed to `byte-compile-out'." + (if (memq op '(byte-call byte-discardN byte-discardN-preserve-tos)) + ;; For calls, OPERAND is the number of args, so we pop OPERAND + 1 + ;; elements, and the push the result, for a total of -OPERAND. + ;; For discardN*, of course, we just pop OPERAND elements. + (- operand) + (or (aref byte-stack+-info (symbol-value op)) + ;; Ops with a nil entry in `byte-stack+-info' are byte-codes + ;; that take OPERAND values off the stack and push a result, for + ;; a total of 1 - OPERAND + (- 1 operand)))) + +(defun byte-compile-out (op &optional operand) + (push (cons op operand) byte-compile-output) + (if (eq op 'byte-return) + ;; This is actually an unnecessary case, because there should be no + ;; more ops behind byte-return. + (setq byte-compile-depth nil) + (setq byte-compile-depth + (+ byte-compile-depth (byte-compile-stack-adjustment op operand))) + (setq byte-compile-maxdepth (max byte-compile-depth byte-compile-maxdepth)) + ;;(if (< byte-compile-depth 0) (error "Compiler error: stack underflow")) + )) + +(defun byte-compile-delay-out (&optional stack-used stack-adjust) + "Add a placeholder to the output, which can be used to later add byte-codes. +Return a position tag that can be passed to `byte-compile-delayed-out' +to add the delayed byte-codes. STACK-USED is the maximum amount of +stack-spaced used by the delayed byte-codes (defaulting to 0), and +STACK-ADJUST is the amount by which the later-added code will adjust the +stack (defaulting to 0); the byte-codes added later _must_ adjust the +stack by this amount! If STACK-ADJUST is 0, then it's not necessary to +actually add anything later; the effect as if nothing was added at all." + ;; We just add a no-op to `byte-compile-output', and return a pointer to + ;; the tail of the list; `byte-compile-delayed-out' uses list surgery + ;; to add the byte-codes. + (when stack-used + (setq byte-compile-maxdepth + (max byte-compile-depth (+ byte-compile-depth (or stack-used 0))))) + (when stack-adjust + (setq byte-compile-depth + (+ byte-compile-depth stack-adjust))) + (push (cons nil (or stack-adjust 0)) byte-compile-output)) + +(defun byte-compile-delayed-out (position op &optional operand) + "Add at POSITION the byte-operation OP, with optional numeric arg OPERAND. +POSITION should a position returned by `byte-compile-delay-out'. +Return a new position, which can be used to add further operations." + (unless (null (caar position)) + (error "Bad POSITION arg to `byte-compile-delayed-out'")) + ;; This is kind of like `byte-compile-out', but we splice into the list + ;; where POSITION is. We don't bother updating `byte-compile-maxdepth' + ;; because that was already done by `byte-compile-delay-out', but we do + ;; update the relative operand stored in the no-op marker currently at + ;; POSITION; since we insert before that marker, this means that if the + ;; caller doesn't insert a sequence of byte-codes that matches the expected + ;; operand passed to `byte-compile-delay-out', then the nop will still have + ;; a non-zero operand when `byte-compile-lapcode' is called, which will + ;; cause an error to be signaled. + + ;; Adjust the cumulative stack-adjustment stored in the cdr of the no-op + (setcdr (car position) + (- (cdar position) (byte-compile-stack-adjustment op operand))) + ;; Add the new operation onto the list tail at POSITION + (setcdr position (cons (cons op operand) (cdr position))) + position) ;;; call tree stuff |