Commit 3e21b6a7 authored by Stefan Monnier's avatar Stefan Monnier
Browse files

Use offsets relative to top rather than bottom for stack refs

* lisp/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.
* lisp/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.
* lisp/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.
* lisp/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.
* lisp/emacs-lisp/eieio.el (eieio-defgeneric-form-primary-only-one):
Call byte-compile rather than byte-compile-lambda.
* src/alloc.c (Fgarbage_collect): Don't mark the byte-stack redundantly.
* src/bytecode.c (exec_byte_code): Change stack_ref and stack_set to use
offsets relative to top rather than to bottom.
* lisp/subr.el (with-output-to-temp-buffer): New macro.
* lisp/simple.el (count-words-region): Don't use interactive-p.
parent e0f57e65
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.
......
......@@ -1470,7 +1470,7 @@
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
......@@ -1628,14 +1628,15 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; 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)
......@@ -1663,15 +1664,18 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
;; 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
......@@ -1739,18 +1743,24 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;;
;; 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))
......@@ -1857,14 +1867,6 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
""))
(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
;;
......@@ -1948,12 +1950,19 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; 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))))
......@@ -2026,7 +2035,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; 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
......@@ -2089,38 +2098,38 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; 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 -->
......@@ -2158,30 +2167,16 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance."
;; 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)))
......
......@@ -636,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
......@@ -826,6 +826,10 @@ CONST2 may be evaulated multiple times."
((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.
......@@ -2530,13 +2534,13 @@ 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
;; 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))
......@@ -2953,7 +2957,7 @@ That command is designed for interactive use only" bytecomp-fn))
(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
......@@ -3324,15 +3328,16 @@ discarding."
(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.
......@@ -3946,7 +3951,6 @@ binding slots have been popped."
(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)
......@@ -4045,12 +4049,6 @@ binding slots have been popped."
(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))
;;; 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.
......@@ -71,13 +71,17 @@
;;; 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))
......@@ -215,7 +219,7 @@ Returns a form where all lambdas don't have any free variables."
'()
)))
(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)
......@@ -312,7 +316,7 @@ Returns a form where all lambdas don't have any free variables."
(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)))
......@@ -341,7 +345,7 @@ Returns a form where all lambdas don't have any free variables."
,(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
......@@ -478,9 +482,9 @@ Returns a form where all lambdas don't have any free variables."
(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.
......@@ -493,8 +497,8 @@ Returns a form where all lambdas don't have any free variables."
;; 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)
......@@ -552,7 +556,7 @@ Returns a form where all lambdas don't have any free variables."
(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)
......@@ -568,23 +572,23 @@ Returns a form where all lambdas don't have any free variables."
;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)
......@@ -601,7 +605,7 @@ Returns a form where all lambdas don't have any free variables."
(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))
......@@ -655,6 +659,7 @@ Returns a form where all lambdas don't have any free variables."
(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)
......
......@@ -45,9 +45,9 @@
)
;; 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'
......@@ -74,7 +74,7 @@ that is called but rarely. Argument FORM is the body of the method."
":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))
......@@ -98,6 +98,9 @@ that is called but rarely. Argument FORM is the body of the method."
;; 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))))
......@@ -125,7 +128,7 @@ that is called but rarely. Argument FORM is the body of the method."
;; 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))
......
......@@ -182,9 +182,9 @@ Stored outright without modifications or stripping.")
))
;; 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)
;;; Important macros used in eieio.
;;
......@@ -1192,10 +1192,8 @@ IMPL is the symbol holding the method implementation."
;; 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
......@@ -1205,7 +1203,8 @@ IMPL is the symbol holding the method implementation."
;; 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)
......@@ -1228,9 +1227,7 @@ IMPL is the symbol holding the method implementation."
)
(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."
......
......@@ -990,7 +990,7 @@ When called interactively, the word count is printed in echo area."
(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))
......@@ -6641,6 +6641,7 @@ saving the value of `buffer-invisibility-spec' and setting it to nil."
;; 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.
......
......@@ -426,12 +426,6 @@ Non-strings in LIST are ignored."
(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)