+2011-02-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * subr.el (with-output-to-temp-buffer): New macro.
+
+ * simple.el (count-words-region): Don't use interactive-p.
+
+ * minibuffer.el: Use lexical-binding. Replace all uses of lexical-let.
+
+ * emacs-lisp/eieio.el (eieio-defgeneric-form-primary-only-one):
+ Call byte-compile rather than byte-compile-lambda.
+
+ * emacs-lisp/eieio-comp.el (eieio-byte-compile-file-form-defmethod):
+ Rename from byte-compile-file-form-defmethod.
+ Don't byte-compile-lambda.
+ (eieio-byte-compile-defmethod-param-convert): Rename from
+ byte-compile-defmethod-param-convert.
+
+ * emacs-lisp/cl-extra.el (cl-macroexpand-all): Don't assume that the
+ value of (function (lambda ...)) is self-quoting.
+
+ * emacs-lisp/cconv.el: Use lexical-binding.
+ (cconv--lookup-let): Rename from cconv-lookup-let.
+ (cconv-closure-convert-rec): Fix handling of captured+mutated
+ arguments in defun/defmacro.
+
+ * emacs-lisp/bytecomp.el (byte-compile-lapcode):
+ Turn stack-ref-0 into dup.
+ (byte-compile-form): Don't indirect-function since it can signal
+ errors.
+ (byte-compile-stack-ref, byte-compile-stack-set): Adjust to stack-refs
+ being relative to top rather than to bottom in the byte-code.
+ (with-output-to-temp-buffer): Remove.
+ (byte-compile-with-output-to-temp-buffer): Remove.
+
+ * emacs-lisp/byte-opt.el (byte-compile-side-effect-and-error-free-ops):
+ Remove interactive-p.
+ (byte-optimize-lapcode): Update optimizations now that stack-refs are
+ relative to the top rather than to the bottom.
+
2011-02-19 Stefan Monnier <monnier@iro.umontreal.ca>
* subr.el (save-window-excursion): New macro, moved from C.
byte-cdr-safe byte-cons byte-list1 byte-list2 byte-point byte-point-max
byte-point-min byte-following-char byte-preceding-char
byte-current-column byte-eolp byte-eobp byte-bolp byte-bobp
- byte-current-buffer byte-interactive-p byte-stack-ref))
+ byte-current-buffer byte-stack-ref))
(defconst byte-compile-side-effect-free-ops
(nconc
;; const/dup varbind-X varref-X --> const/dup varbind-X const/dup
;; The latter two can enable other optimizations.
;;
- ((or (and (eq 'byte-varref (car lap2))
- (eq (cdr lap1) (cdr lap2))
- (memq (car lap1) '(byte-varset byte-varbind)))
- (and (eq (car lap2) 'byte-stack-ref)
- (eq (car lap1) 'byte-stack-set)
- (eq (cdr lap1) (cdr lap2))))
- (if (and (eq 'byte-varref (car lap2))
- (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
+ ;; For lexical variables, we could do the same
+ ;; stack-set-X+1 stack-ref-X --> dup stack-set-X+2
+ ;; but this is a very minor gain, since dup is stack-ref-0,
+ ;; i.e. it's only better if X>5, and even then it comes
+ ;; at the cost cost of an extra stack slot. Let's not bother.
+ ((and (eq 'byte-varref (car lap2))
+ (eq (cdr lap1) (cdr lap2))
+ (memq (car lap1) '(byte-varset byte-varbind)))
+ (if (and (setq tmp (memq (car (cdr lap2)) byte-boolean-vars))
(not (eq (car lap0) 'byte-constant)))
nil
(setq keep-going t)
;;
;; dup varset-X discard --> varset-X
;; dup varbind-X discard --> varbind-X
+ ;; dup stack-set-X discard --> stack-set-X-1
;; (the varbind variant can emerge from other optimizations)
;;
((and (eq 'byte-dup (car lap0))
(eq 'byte-discard (car lap2))
- (memq (car lap1) '(byte-varset byte-varbind byte-stack-set)))
+ (memq (car lap1) '(byte-varset byte-varbind
+ byte-stack-set)))
(byte-compile-log-lap " dup %s discard\t-->\t%s" lap1 lap1)
(setq keep-going t
rest (cdr rest)
stack-adjust -1)
+ (if (eq 'byte-stack-set (car lap1)) (decf (cdr lap1)))
(setq lap (delq lap0 (delq lap2 lap))))
;;
;; not goto-X-if-nil --> goto-X-if-non-nil
;;
;; varref-X varref-X --> varref-X dup
;; varref-X [dup ...] varref-X --> varref-X [dup ...] dup
+ ;; stackref-X [dup ...] stackref-X+N --> stackref-X [dup ...] dup
;; We don't optimize the const-X variations on this here,
;; because that would inhibit some goto optimizations; we
;; optimize the const-X case after all other optimizations.
;;
((and (memq (car lap0) '(byte-varref byte-stack-ref))
(progn
- (setq tmp (cdr rest) tmp2 0)
+ (setq tmp (cdr rest))
+ (setq tmp2 0)
(while (eq (car (car tmp)) 'byte-dup)
- (setq tmp (cdr tmp) tmp2 (1+ tmp2)))
+ (setq tmp2 (1+ tmp2))
+ (setq tmp (cdr tmp)))
t)
- (eq (car lap0) (car (car tmp)))
- (eq (cdr lap0) (cdr (car tmp))))
+ (eq (if (eq 'byte-stack-ref (car lap0))
+ (+ tmp2 1 (cdr lap0))
+ (cdr lap0))
+ (cdr (car tmp)))
+ (eq (car lap0) (car (car tmp))))
(if (memq byte-optimize-log '(t byte))
(let ((str ""))
(setq tmp2 (cdr rest))
""))
(setq keep-going t))
;;
- ;; stack-ref-N --> dup ; where N is TOS
- ;;
- ((and stack-depth (eq (car lap0) 'byte-stack-ref)
- (= (cdr lap0) (1- stack-depth)))
- (setcar lap0 'byte-dup)
- (setcdr lap0 nil)
- (setq keep-going t))
- ;;
;; goto*-X ... X: goto-Y --> goto*-Y
;; goto-X ... X: return --> return
;;
;; X: varref-Y Z: ... dup varset-Y goto-Z
;; (varset-X goto-BACK, BACK: varref-X --> copy the varref down.)
;; (This is so usual for while loops that it is worth handling).
+ ;;
+ ;; Here again, we could do it for stack-ref/stack-set, but
+ ;; that's replacing a stack-ref-Y with a stack-ref-0, which
+ ;; is a very minor improvement (if any), at the cost of
+ ;; more stack use and more byte-code. Let's not do it.
;;
- ((and (memq (car lap1) '(byte-varset byte-stack-set))
+ ((and (eq (car lap1) 'byte-varset)
(eq (car lap2) 'byte-goto)
(not (memq (cdr lap2) rest)) ;Backwards jump
(eq (car (car (setq tmp (cdr (memq (cdr lap2) lap)))))
- (if (eq (car lap1) 'byte-varset) 'byte-varref 'byte-stack-ref))
+ (if (eq (car lap1) 'byte-varset) 'byte-varref
+ ;; 'byte-stack-ref
+ ))
(eq (cdr (car tmp)) (cdr lap1))
(not (and (eq (car lap1) 'byte-varref)
(memq (car (cdr lap1)) byte-boolean-vars))))
;; Rebuild byte-compile-constants / byte-compile-variables.
;; Simple optimizations that would inhibit other optimizations if they
;; were done in the optimizing loop, and optimizations which there is no
- ;; need to do more than once.
+ ;; need to do more than once.
(setq byte-compile-constants nil
byte-compile-variables nil)
(setq rest lap
;; stack-set-M [discard/discardN ...] --> discardN-preserve-tos
;; stack-set-M [discard/discardN ...] --> discardN
;;
- ((and stack-depth ;Make sure we know the stack depth.
- (eq (car lap0) 'byte-stack-set)
- (memq (car lap1) '(byte-discard byte-discardN))
- (progn
- ;; See if enough discard operations follow to expose or
- ;; destroy the value stored by the stack-set.
- (setq tmp (cdr rest))
- (setq tmp2 (- stack-depth 2 (cdr lap0)))
- (setq tmp3 0)
- (while (memq (car (car tmp)) '(byte-discard byte-discardN))
- (if (eq (car (car tmp)) 'byte-discard)
- (setq tmp3 (1+ tmp3))
- (setq tmp3 (+ tmp3 (cdr (car tmp)))))
- (setq tmp (cdr tmp)))
- (>= tmp3 tmp2)))
- ;; Do the optimization
+ ((and (eq (car lap0) 'byte-stack-set)
+ (memq (car lap1) '(byte-discard byte-discardN))
+ (progn
+ ;; See if enough discard operations follow to expose or
+ ;; destroy the value stored by the stack-set.
+ (setq tmp (cdr rest))
+ (setq tmp2 (1- (cdr lap0)))
+ (setq tmp3 0)
+ (while (memq (car (car tmp)) '(byte-discard byte-discardN))
+ (setq tmp3
+ (+ tmp3 (if (eq (car (car tmp)) 'byte-discard)
+ 1
+ (cdr (car tmp)))))
+ (setq tmp (cdr tmp)))
+ (>= tmp3 tmp2)))
+ ;; Do the optimization.
(setq lap (delq lap0 lap))
- (cond ((= tmp2 tmp3)
- ;; The value stored is the new TOS, so pop one more value
- ;; (to get rid of the old value) using the TOS-preserving
- ;; discard operator.
- (setcar lap1 'byte-discardN-preserve-tos)
- (setcdr lap1 (1+ tmp3)))
- (t
- ;; Otherwise, the value stored is lost, so just use a
- ;; normal discard.
- (setcar lap1 'byte-discardN)
- (setcdr lap1 tmp3)))
+ (setcar lap1
+ (if (= tmp2 tmp3)
+ ;; The value stored is the new TOS, so pop
+ ;; one more value (to get rid of the old
+ ;; value) using the TOS-preserving
+ ;; discard operator.
+ 'byte-discardN-preserve-tos
+ ;; Otherwise, the value stored is lost, so just use a
+ ;; normal discard.
+ 'byte-discardN))
+ (setcdr lap1 (1+ tmp3))
(setcdr (cdr rest) tmp)
(setq stack-adjust 0)
(byte-compile-log-lap " %s [discard/discardN]...\t-->\t%s"
- lap0 lap1))
+ lap0 lap1))
;;
;; discard/discardN/discardN-preserve-tos-X discard/discardN-Y -->
;; dup return --> return
;; stack-set-N return --> return ; where N is TOS-1
;;
- ((and stack-depth ;Make sure we know the stack depth.
- (eq (car lap1) 'byte-return)
- (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
- (and (eq (car lap0) 'byte-stack-set)
- (= (cdr lap0) (- stack-depth 2)))))
- ;; the byte-code interpreter will pop the stack for us, so
- ;; we can just leave stuff on it
+ ((and (eq (car lap1) 'byte-return)
+ (or (memq (car lap0) '(byte-discardN-preserve-tos byte-dup))
+ (and (eq (car lap0) 'byte-stack-set)
+ (= (cdr lap0) 1))))
+ ;; The byte-code interpreter will pop the stack for us, so
+ ;; we can just leave stuff on it.
(setq lap (delq lap0 lap))
(setq stack-adjust 0)
(byte-compile-log-lap " %s %s\t-->\t%s" lap0 lap1 lap1))
-
- ;;
- ;; dup stack-set-N return --> return ; where N is TOS
- ;;
- ((and stack-depth ;Make sure we know the stack depth.
- (eq (car lap0) 'byte-dup)
- (eq (car lap1) 'byte-stack-set)
- (eq (car (car (cdr (cdr rest)))) 'byte-return)
- (= (cdr lap1) (1- stack-depth)))
- (setq lap (delq lap0 (delq lap1 lap)))
- (setq rest (cdr rest))
- (setq stack-adjust 0)
- (byte-compile-log-lap " dup %s return\t-->\treturn" lap1))
- )
+ )
(setq stack-depth
(and stack-depth stack-adjust (+ stack-depth stack-adjust)))
;; 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
((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.
(if macro
(setq fun (cdr fun)))
(cond ((eq (car-safe fun) 'lambda)
- ;; expand macros
+ ;; 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
+ ;; 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-nogroup-warn form))
(byte-compile-callargs-warn form))
(if (and (fboundp (car form))
- (eq (car-safe (indirect-function (car form))) 'macro))
+ (eq (car-safe (symbol-function (car form))) 'macro))
(byte-compile-report-error
(format "Forgot to expand macro %s" (car form))))
(if (and bytecomp-handler
(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."
- (if (= byte-compile-depth (1+ stack-pos))
- ;; A simple optimization
- (byte-compile-out 'byte-dup)
- ;; normal case
- (byte-compile-out 'byte-stack-ref stack-pos)))
+ (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 stack-pos))
+ (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.
(byte-defop-compiler-1 save-excursion)
(byte-defop-compiler-1 save-current-buffer)
(byte-defop-compiler-1 save-restriction)
-(byte-defop-compiler-1 with-output-to-temp-buffer)
(byte-defop-compiler-1 track-mouse)
(defun byte-compile-catch (form)
(byte-compile-out 'byte-save-current-buffer 0)
(byte-compile-body-do-effect (cdr form))
(byte-compile-out 'byte-unbind 1))
-
-(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))
\f
;;; top-level forms elsewhere
-;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: nil -*-
+;;; cconv.el --- Closure conversion for statically scoped Emacs lisp. -*- lexical-binding: t -*-
;; Copyright (C) 2011 Free Software Foundation, Inc.
;;; Code:
;;; TODO:
+;; - Change new byte-code representation, so it directly gives the
+;; number of mandatory and optional arguments as well as whether or
+;; not there's a &rest arg.
;; - Use abstract `make-closure' and `closure-ref' expressions, which bytecomp
;; should turn into building corresponding byte-code function.
;; - don't use `curry', instead build a new compiled-byte-code object
;; (merge the closure env into the static constants pool).
-;; - use relative addresses for byte-code-stack-ref.
;; - warn about unused lexical vars.
;; - clean up cconv-closure-convert-rec, especially the `let' binding part.
+;; - new byte codes for unwind-protect, catch, and condition-case so that
+;; closures aren't needed at all.
(eval-when-compile (require 'cl))
'()
)))
-(defun cconv-lookup-let (table var binder form)
+(defun cconv--lookup-let (table var binder form)
(let ((res nil))
(dolist (elem table)
(when (and (eq (nth 2 elem) binder)
(new-val
(cond
;; Check if var is a candidate for lambda lifting.
- ((cconv-lookup-let cconv-lambda-candidates var binder form)
+ ((cconv--lookup-let cconv-lambda-candidates var binder form)
(let* ((fv (delete-dups (cconv-freevars value '())))
(funargs (cadr (cadr value)))
,(reverse funcbodies-new))))))))
;; Check if it needs to be turned into a "ref-cell".
- ((cconv-lookup-let cconv-captured+mutated var binder form)
+ ((cconv--lookup-let cconv-captured+mutated var binder form)
;; Declared variable is mutated and captured.
(prog1
`(list ,(cconv-closure-convert-rec
(cons 'cond
(reverse cond-forms-new))))
- (`(quote . ,_) form) ; quote form
+ (`(quote . ,_) form)
- (`(function . ((lambda ,vars . ,body-forms))) ; function form
+ (`(function (lambda ,vars . ,body-forms)) ; function form
(let* ((fvrs-new (cconv--set-diff fvrs vars)) ; Remove vars from fvrs.
(fv (delete-dups (cconv-freevars form '())))
(leave fvrs-new) ; leave=non-nil if we should leave env unchanged.
;; If outer closure contains all
;; free variables of this function(and nothing else)
;; then we use the same environment vector as for outer closure,
- ;; i.e. we leave the environment vector unchanged
- ;; otherwise we build a new environmet vector
+ ;; i.e. we leave the environment vector unchanged,
+ ;; otherwise we build a new environment vector.
(if (eq (length envs) (length fv))
(let ((fv-temp fv))
(while (and fv-temp leave)
(function (lambda (,cconv--env-var . ,vars) . ,body-forms-new))
(vector . ,envector))))))
- (`(function . ,_) form) ; same as quote
+ (`(function . ,_) form) ; Same as quote.
;defconst, defvar
(`(,(and sym (or `defconst `defvar)) ,definedsymbol . ,body-forms)
;defun, defmacro
(`(,(and sym (or `defun `defmacro))
,func ,vars . ,body-forms)
- (let ((body-new '()) ; the whole body
- (body-forms-new '()) ; body w\o docstring and interactive
+ (let ((body-new '()) ; The whole body.
+ (body-forms-new '()) ; Body w\o docstring and interactive.
(letbind '()))
- ; find mutable arguments
- (let ((lmutated cconv-captured+mutated) ismutated)
- (dolist (elm vars)
- (setq ismutated nil)
+ ; Find mutable arguments.
+ (dolist (elm vars)
+ (let ((lmutated cconv-captured+mutated)
+ (ismutated nil))
(while (and lmutated (not ismutated))
(when (and (eq (caar lmutated) elm)
- (eq (cadar lmutated) form))
+ (eq (caddar lmutated) form))
(setq ismutated t))
(setq lmutated (cdr lmutated)))
(when ismutated
(push elm letbind)
(push elm emvrs))))
- ;transform body-forms
- (when (stringp (car body-forms)) ; treat docstring well
+ ;Transform body-forms.
+ (when (stringp (car body-forms)) ; Treat docstring well.
(push (car body-forms) body-new)
(setq body-forms (cdr body-forms)))
(when (eq (car-safe (car body-forms)) 'interactive)
(setq body-forms-new (reverse body-forms-new))
(if letbind
- ; letbind mutable arguments
+ ; Letbind mutable arguments.
(let ((binders-new '()))
(dolist (elm letbind) (push `(,elm (list ,elm))
binders-new))
(push `(setcar ,sym-new ,value) prognlist)
(if (symbolp sym-new)
(push `(setq ,sym-new ,value) prognlist)
+ (debug) ;FIXME: When can this be right?
(push `(set ,sym-new ,value) prognlist)))
(setq forms (cddr forms)))
(if (cdr prognlist)
)
;; This teaches the byte compiler how to do this sort of thing.
-(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
+(put 'defmethod 'byte-hunk-handler 'eieio-byte-compile-file-form-defmethod)
-(defun byte-compile-file-form-defmethod (form)
+(defun eieio-byte-compile-file-form-defmethod (form)
"Mumble about the method we are compiling.
This function is mostly ripped from `byte-compile-file-form-defun',
but it's been modified to handle the special syntax of the `defmethod'
":static ")
(t ""))))
(params (car form))
- (lamparams (byte-compile-defmethod-param-convert params))
+ (lamparams (eieio-byte-compile-defmethod-param-convert params))
(arg1 (car params))
(class (if (listp arg1) (nth 1 arg1) nil))
(my-outbuffer (if (eval-when-compile (featurep 'xemacs))
;; Byte compile the body. For the byte compiled forms, add the
;; rest arguments, which will get ignored by the engine which will
;; add them later (I hope)
+ ;; FIXME: This relies on compiler's internal. Make sure it still
+ ;; works with lexical-binding code. Maybe calling `byte-compile'
+ ;; would be preferable.
(let* ((new-one (byte-compile-lambda
(append (list 'lambda lamparams)
(cdr form))))
;; nil prevents cruft from appearing in the output buffer.
nil))
-(defun byte-compile-defmethod-param-convert (paramlist)
+(defun eieio-byte-compile-defmethod-param-convert (paramlist)
"Convert method params into the params used by the `defmethod' thingy.
Argument PARAMLIST is the parameter list to convert."
(let ((argfix nil))
))
;; How to specialty compile stuff.
-(autoload 'byte-compile-file-form-defmethod "eieio-comp"
+(autoload 'eieio-byte-compile-file-form-defmethod "eieio-comp"
"This function is used to byte compile methods in a nice way.")
-(put 'defmethod 'byte-hunk-handler 'byte-compile-file-form-defmethod)
+(put 'defmethod 'byte-hunk-handler 'eieio-byte-compile-file-form-defmethod)
\f
;;; Important macros used in eieio.
;;
;; is faster to execute this for not byte-compiled. ie, install this,
;; then measure calls going through here. I wonder why.
(require 'bytecomp)
- (let ((byte-compile-free-references nil)
- (byte-compile-warnings nil)
- )
- (byte-compile-lambda
+ (let ((byte-compile-warnings nil))
+ (byte-compile
`(lambda (&rest local-args)
,doc-string
;; This is a cool cheat. Usually we need to look up in the
;; of that one implementation, then clearly, there is no method def.
(if (not (eieio-object-p (car local-args)))
;; Not an object. Just signal.
- (signal 'no-method-definition (list ,(list 'quote method) local-args))
+ (signal 'no-method-definition
+ (list ,(list 'quote method) local-args))
;; We do have an object. Make sure it is the right type.
(if ,(if (eq class eieio-default-superclass)
)
(apply ,(list 'quote impl) local-args)
;(,impl local-args)
- ))))
- )
- ))
+ )))))))
(defsubst eieio-defgeneric-reset-generic-form-primary-only-one (method)
"Setup METHOD to call the generic form."
(goto-char (point-min))
(while (forward-word 1)
(setq count (1+ count)))))
- (if (interactive-p)
+ (if (called-interactively-p 'interactive)
(message "Region has %d words" count))
count))
\f
;; Partial application of functions (similar to "currying").
;; This function is here rather than in subr.el because it uses CL.
+;; (defalias 'apply-partially #'curry)
(defun apply-partially (fun &rest args)
"Return a function that is a partial application of FUN to ARGS.
ARGS is a list of the first N arguments to pass to FUN.
(setq list (cdr list)))
list)
-;; Remove this since we don't know how to handle it in the byte-compiler yet.
-;; (defmacro with-lexical-binding (&rest body)
-;; "Execute the statements in BODY using lexical binding."
-;; `(let ((internal-interpreter-environment '(t)))
-;; ,@body))
-
(defun assq-delete-all (key alist)
"Delete from ALIST all elements whose car is `eq' to KEY.
Return the modified alist.
(unwind-protect (progn ,@body)
(set-window-configuration ,c)))))
+(defmacro with-output-to-temp-buffer (bufname &rest body)
+ "Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
+
+This construct makes buffer BUFNAME empty before running BODY.
+It does not make the buffer current for BODY.
+Instead it binds `standard-output' to that buffer, so that output
+generated with `prin1' and similar functions in BODY goes into
+the buffer.
+
+At the end of BODY, this marks buffer BUFNAME unmodifed and displays
+it in a window, but does not select it. The normal way to do this is
+by calling `display-buffer', then running `temp-buffer-show-hook'.
+However, if `temp-buffer-show-function' is non-nil, it calls that
+function instead (and does not run `temp-buffer-show-hook'). The
+function gets one argument, the buffer to display.
+
+The return value of `with-output-to-temp-buffer' is the value of the
+last form in BODY. If BODY does not finish normally, the buffer
+BUFNAME is not displayed.
+
+This runs the hook `temp-buffer-setup-hook' before BODY,
+with the buffer BUFNAME temporarily current. It runs the hook
+`temp-buffer-show-hook' after displaying buffer BUFNAME, with that
+buffer temporarily current, and the window that was used to display it
+temporarily selected. But it doesn't run `temp-buffer-show-hook'
+if it uses `temp-buffer-show-function'."
+ (let ((old-dir (make-symbol "old-dir"))
+ (buf (make-symbol "buf")))
+ `(let ((,old-dir default-directory))
+ (with-current-buffer (get-buffer-create ,bufname)
+ (kill-all-local-variables)
+ ;; FIXME: delete_all_overlays
+ (setq default-directory ,old-dir)
+ (setq buffer-read-only nil)
+ (setq buffer-file-name nil)
+ (setq buffer-undo-list t)
+ (let ((,buf (current-buffer)))
+ (let ((inhibit-read-only t)
+ (inhibit-modification-hooks t))
+ (erase-buffer)
+ (run-hooks 'temp-buffer-setup-hook))
+ (let ((standard-output ,buf))
+ (prog1 (progn ,@body)
+ (internal-temp-output-buffer-show ,buf))))))))
+
(defmacro with-temp-file (file &rest body)
"Create a new buffer, evaluate BODY there, and write the buffer to FILE.
The value returned is the value of the last form in BODY.
+2011-02-21 Stefan Monnier <monnier@iro.umontreal.ca>
+
+ * bytecode.c (exec_byte_code): Change stack_ref and stack_set to use
+ offsets relative to top rather than to bottom.
+
+ * alloc.c (Fgarbage_collect): Don't mark the byte-stack redundantly.
+
2011-02-19 Stefan Monnier <monnier@iro.umontreal.ca>
* window.c (Fsave_window_excursion): Remove. Moved to Lisp.
for (i = 0; i < tail->nvars; i++)
mark_object (tail->var[i]);
}
+ mark_byte_stack ();
#endif
- mark_byte_stack ();
for (catch = catchlist; catch; catch = catch->next)
{
mark_object (catch->tag);
*
* define BYTE_CODE_METER to enable generation of a byte-op usage histogram.
*/
-/* #define BYTE_CODE_SAFE */
+#define BYTE_CODE_SAFE
/* #define BYTE_CODE_METER */
\f
/* Byte codes: */
-#define Bstack_ref 0
+#define Bstack_ref 0 /* Actually, Bstack_ref+0 is not implemented: use dup. */
#define Bvarref 010
#define Bvarset 020
#define Bvarbind 030
#define Bunwind_protect 0216
#define Bcondition_case 0217
-#define Btemp_output_buffer_setup 0220
-#define Btemp_output_buffer_show 0221
+#define Btemp_output_buffer_setup 0220 /* Obsolete. */
+#define Btemp_output_buffer_show 0221 /* Obsolete. */
#define Bunbind_all 0222 /* Obsolete. */
case Bsave_window_excursion: /* Obsolete. */
{
- register Lisp_Object val;
register int count = SPECPDL_INDEX ();
-
record_unwind_protect (Fset_window_configuration,
Fcurrent_window_configuration (Qnil));
BEFORE_POTENTIAL_GC ();
break;
}
- case Btemp_output_buffer_setup:
+ case Btemp_output_buffer_setup: /* Obsolete. */
BEFORE_POTENTIAL_GC ();
CHECK_STRING (TOP);
temp_output_buffer_setup (SSDATA (TOP));
TOP = Vstandard_output;
break;
- case Btemp_output_buffer_show:
+ case Btemp_output_buffer_show: /* Obsolete. */
{
Lisp_Object v1;
BEFORE_POTENTIAL_GC ();
#endif
/* Handy byte-codes for lexical binding. */
- case Bstack_ref:
+ /* case Bstack_ref: */ /* Use `dup' instead. */
case Bstack_ref+1:
case Bstack_ref+2:
case Bstack_ref+3:
case Bstack_ref+4:
case Bstack_ref+5:
- PUSH (stack.bottom[op - Bstack_ref]);
- break;
+ {
+ Lisp_Object *ptr = top - (op - Bstack_ref);
+ PUSH (*ptr);
+ break;
+ }
case Bstack_ref+6:
- PUSH (stack.bottom[FETCH]);
- break;
+ {
+ Lisp_Object *ptr = top - (FETCH);
+ PUSH (*ptr);
+ break;
+ }
case Bstack_ref+7:
- PUSH (stack.bottom[FETCH2]);
- break;
+ {
+ Lisp_Object *ptr = top - (FETCH2);
+ PUSH (*ptr);
+ break;
+ }
+ /* stack-set-0 = discard; stack-set-1 = discard-1-preserve-tos. */
case Bstack_set:
- stack.bottom[FETCH] = POP;
- break;
+ {
+ Lisp_Object *ptr = top - (FETCH);
+ *ptr = POP;
+ break;
+ }
case Bstack_set2:
- stack.bottom[FETCH2] = POP;
- break;
+ {
+ Lisp_Object *ptr = top - (FETCH2);
+ *ptr = POP;
+ break;
+ }
case BdiscardN:
op = FETCH;
if (op & 0x80)
specbind (Qstandard_output, buf);
}
+/* FIXME: Use Lisp's with-output-to-temp-buffer instead! */
Lisp_Object
internal_with_output_to_temp_buffer (const char *bufname, Lisp_Object (*function) (Lisp_Object), Lisp_Object args)
{
return unbind_to (count, val);
}
-
-DEFUN ("with-output-to-temp-buffer",
- Fwith_output_to_temp_buffer, Swith_output_to_temp_buffer,
- 1, UNEVALLED, 0,
- doc: /* Bind `standard-output' to buffer BUFNAME, eval BODY, then show that buffer.
-
-This construct makes buffer BUFNAME empty before running BODY.
-It does not make the buffer current for BODY.
-Instead it binds `standard-output' to that buffer, so that output
-generated with `prin1' and similar functions in BODY goes into
-the buffer.
-
-At the end of BODY, this marks buffer BUFNAME unmodifed and displays
-it in a window, but does not select it. The normal way to do this is
-by calling `display-buffer', then running `temp-buffer-show-hook'.
-However, if `temp-buffer-show-function' is non-nil, it calls that
-function instead (and does not run `temp-buffer-show-hook'). The
-function gets one argument, the buffer to display.
-
-The return value of `with-output-to-temp-buffer' is the value of the
-last form in BODY. If BODY does not finish normally, the buffer
-BUFNAME is not displayed.
-
-This runs the hook `temp-buffer-setup-hook' before BODY,
-with the buffer BUFNAME temporarily current. It runs the hook
-`temp-buffer-show-hook' after displaying buffer BUFNAME, with that
-buffer temporarily current, and the window that was used to display it
-temporarily selected. But it doesn't run `temp-buffer-show-hook'
-if it uses `temp-buffer-show-function'.
-
-usage: (with-output-to-temp-buffer BUFNAME BODY...) */)
- (Lisp_Object args)
-{
- struct gcpro gcpro1;
- Lisp_Object name;
- int count = SPECPDL_INDEX ();
- Lisp_Object buf, val;
-
- GCPRO1(args);
- name = eval_sub (Fcar (args));
- CHECK_STRING (name);
- temp_output_buffer_setup (SSDATA (name));
- buf = Vstandard_output;
- UNGCPRO;
-
- val = Fprogn (XCDR (args));
-
- GCPRO1 (val);
- temp_output_buffer_show (buf);
- UNGCPRO;
-
- return unbind_to (count, val);
-}
-
\f
static void print (Lisp_Object obj, register Lisp_Object printcharfun, int escapeflag);
static void print_preprocess (Lisp_Object obj);
print_prune_charset_plist = Qnil;
staticpro (&print_prune_charset_plist);
-
- defsubr (&Swith_output_to_temp_buffer);
}
return Qnil;
}
-
void
temp_output_buffer_show (register Lisp_Object buf)
{
}
}
}
+
+DEFUN ("internal-temp-output-buffer-show",
+ Ftemp_output_buffer_show, Stemp_output_buffer_show,
+ 1, 1, 0,
+ doc: /* Internal function for `with-output-to-temp-buffer''. */)
+ (Lisp_Object buf)
+{
+ temp_output_buffer_show (buf);
+ return Qnil;
+}
\f
static void
make_dummy_parent (Lisp_Object window)
defsubr (&Sset_window_buffer);
defsubr (&Sselect_window);
defsubr (&Sforce_window_update);
+ defsubr (&Stemp_output_buffer_show);
defsubr (&Ssplit_window);
defsubr (&Senlarge_window);
defsubr (&Sshrink_window);
HCoop / bpt / emacs.git / commitdiff