-
-
-) ;; end of ad-execute-defadvices
-
-;; Only run this once we are compiled. Expanding the defadvices
-;; with only interpreted advice functions available takes forever:
-(if (ad-compiled-p (symbol-function 'ad-execute-defadvices))
- (ad-execute-defadvices))
-
-
-;; @@ Forward advice support for jwz's byte-compiler (M-x serious-HACK-mode-on)
-;; ============================================================================
-;; Jamie Zawinski's optimizing byte-compiler used in v19 (and by some daring
-;; folks in v18) produces compiled files that do not define functions via
-;; explicit calls to `defun/defmacro', it rather uses `fset' for functions with
-;; documentation strings, and hunks of byte-code for sets of functions without
-;; any documentation. In Jamie's byte-compiler a series of compiled functions
-;; without docstrings get hunked as
-;; (progn (fset 'f1 <code1>) (fset 'f2 <code2>) ...).
-;; The resulting progn will be compiled and the compiled form will be written
-;; to the compiled file as `(byte-code [progn-code] [constants] [depth])'. To
-;; handle forward advice we have to know when functions get defined so we can
-;; activate any advice there might be. For standard v18 byte-compiled files
-;; we can do this by simply advising `defun/defmacro' because these subrs are
-;; evaluated explicitly when such a file is loaded. For Jamie's v19 compiler
-;; our only choice is to additionally advise `fset' and change the subr
-;; `byte-code' such that it analyzes its byte-code string looking for fset's
-;; when we are currently loading a file. In v19 the general overhead caused
-;; by the advice of `byte-code' shouldn't be too bad, because byte-compiled
-;; functions do not call byte-code explicitly (as done in v18). In v18 this
-;; is a problem because with the changed `byte-code' function function calls
-;; become more expensive.
-;;
-;; Wish-List:
-;; - special defining functions for use in byte-compiled files, e.g.,
-;; `byte-compile-fset' and `byte-code-tl' which do the same as their
-;; standard brothers, but which can be advised for forward advice without
-;; the problems that advising `byte-code' generates.
-;; - More generally, a symbol definition hook that could be used for
-;; forward advice and related purposes.
-;;
-;; Until then: For the analysis of the byte-code string we simply scan it for
-;; an `fset' opcode (M in ascii) that is preceded by two constant references,
-;; the first of which points to the function name and the second to its code.
-;; A constant reference can either be a simple one-byte one, or a three-byte
-;; one if the function has more than 64 constants. The scanning can pretty
-;; efficiently be done with a regular expression. Here it goes:
-
-;; Have to hardcode these opcodes if I don't
-;; want to require the byte-compiler:
-(defvar byte-constant 192)
-(defvar byte-constant-limit 64)
-(defvar byte-constant2 129)
-(defvar byte-fset 77)
-
-;; Matches a byte-compiled fset operation with two constant arguments:
-(defvar ad-byte-code-fset-regexp
- (let* ((constant-reference
- (format "[%s-%s]"
- (char-to-string byte-constant)
- (char-to-string (+ byte-constant (1- byte-constant-limit)))))
- (constant2-reference
- ;; \0 makes it necessary to use concat instead of format in 18.57:
- (concat (char-to-string byte-constant2) "[\0-\377][\0-\377]"))
- (fset-opcode (char-to-string byte-fset)))
- (concat "\\(" constant-reference "\\|" constant2-reference "\\)"
- "\\(" constant-reference "\\|" constant2-reference "\\)"
- fset-opcode)))
-
-(defun ad-find-fset-in-byte-code (code constants start)
- ;;"Finds the first two-constant fset operation in CODE after START.
- ;;Returns a three element list consisting of the name of the defined
- ;;function, its code (both taken from the CONSTANTS vector), and an
- ;;advanced start index."
- (let ((start
- ;; The odd case that this regexp matches something that isn't an
- ;; actual fset operation is handled by additional tests and a
- ;; condition handler in ad-scan-byte-code-for-fsets:
- (string-match ad-byte-code-fset-regexp code start))
- name-index code-index)
- (cond (start
- (cond ((= (aref code start) byte-constant2)
- (setq name-index
- (+ (aref code (setq start (1+ start)))
- (* (aref code (setq start (1+ start))) 256)))
- (setq start (1+ start)))
- (t (setq name-index (- (aref code start) byte-constant))
- (setq start (1+ start))))
- (cond ((= (aref code start) byte-constant2)
- (setq code-index
- (+ (aref code (setq start (1+ start)))
- (* (aref code (setq start (1+ start))) 256)))
- (setq start (1+ start)))
- (t (setq code-index (- (aref code start) byte-constant))
- (setq start (1+ start))))
- (list (aref constants name-index)
- (aref constants code-index)
- ;; start points to fset opcode:
- start))
- (t nil))))
-
-(defun ad-scan-byte-code-for-fsets (ad-code ad-constants)
- ;; In case anything in here goes wrong we reset `byte-code' to its real
- ;; identity. In particular, the handler of the condition-case uses
- ;; `byte-code', so it better be the real one if we have an error:
- (ad-real-fset 'byte-code (symbol-function 'ad-real-byte-code))
- (condition-case ignore-errors
- (let ((fset-args '(0 0 0)))
- (while (setq fset-args (ad-find-fset-in-byte-code
- ad-code ad-constants
- (car (cdr (cdr fset-args)))))
- (if (and (symbolp (car fset-args))
- (fboundp (car fset-args))
- (eq (symbol-function (car fset-args))
- (car (cdr fset-args))))
- ;; We've found an fset that was executed during this call
- ;; to byte-code, and whose definition is still eq to the
- ;; current definition of the defined function:
- (let ((ad-defined-function (car fset-args)))
- (run-hooks 'ad-definition-hooks))))
- ;; Everything worked fine, readvise `byte-code':
- (ad-real-fset 'byte-code (symbol-function 'ad-advised-byte-code)))
- (error nil)))
-
-;; CAUTION: Don't try this at home!! Changing `byte-code' is a
-;; pretty suicidal activity.
-;; To allow v19 forward advice we cannot advise `byte-code' as a subr as
-;; we did for `defun' etc., because `ad-subr-args' of the advised
-;; `byte-code' would shield references to `ad-subr-args' in the body of
-;; v18 compiled advised subrs such as `defun', and, more importantly, the
-;; changed version of `byte-code' has to be as small and efficient as
-;; possible because it is used in every call to a compiled function.
-;; Hence, we previously saved its original definition and redefine it as
-;; the following function - yuck:
-
-;; The arguments will scope around the body of every byte-compiled
-;; function, hence they have to be obscure enough to not be equal to any
-;; global or argument variable referenced by any compiled function:
-(defun ad-advised-byte-code-definition (ad-cOdE ad-cOnStAnTs ad-dEpTh)
- "Modified version of `byte-code' subr used by the advice package.
-`byte-code' has been modified to allow automatic activation of forward
-advice for functions that are defined in byte-compiled files generated
-by jwz's byte-compiler (as standardly used in v19s).
-See `ad-real-byte-code' for original documentation."
- (prog1 (ad-real-byte-code ad-cOdE ad-cOnStAnTs ad-dEpTh)
- (if load-in-progress
- (ad-scan-byte-code-for-fsets ad-cOdE ad-cOnStAnTs))))
-
-(ad-real-byte-codify 'ad-advised-byte-code-definition)
-
-;; ad-advised-byte-code cannot be defined with `defun', because that would
-;; use `byte-code' for its body --> major disaster if forward advice is
-;; enabled and this file gets loaded:
-(ad-real-fset
- 'ad-advised-byte-code (symbol-function 'ad-advised-byte-code-definition))
-
-(defun ad-recover-byte-code ()
- "Recovers the real `byte-code' functionality."
- (interactive)
- (ad-real-fset 'byte-code (symbol-function 'ad-real-byte-code)))
-
-;; Make sure this is usable even if `byte-code' is screwed up:
-(ad-real-byte-codify 'ad-recover-byte-code)
-
-;; Store original stack sizes because we might have to change them:
-(defvar ad-orig-max-lisp-eval-depth max-lisp-eval-depth)
-(defvar ad-orig-max-specpdl-size max-specpdl-size)
-
-(defun ad-adjust-stack-sizes (&optional reset)
- "Increases stack sizes for the advised `byte-code' function.
-When called with a prefix argument the stack sizes will be reset
-to their original values. Calling this function should only be necessary
-if you get stack overflows because you run highly recursive v18 compiled
-code in a v19 Emacs with definition hooks enabled."
- (interactive "P")
- (cond (reset
- (setq max-lisp-eval-depth ad-orig-max-lisp-eval-depth)
- (setq max-specpdl-size ad-orig-max-specpdl-size))
- (t ;; The redefined `byte-code' needs more execution stack
- ;; (5 cells per function invocation) and variable stack
- ;; (3 vars per function invocation):
- (setq max-lisp-eval-depth (* ad-orig-max-lisp-eval-depth 3))
- (setq max-specpdl-size
- (+ ad-orig-max-specpdl-size (* (/ max-lisp-eval-depth 5) 3))))))
-
-(defun ad-enable-definition-hooks ()
- ;;"Enables definition hooks by redefining definition primitives.
- ;;Activates the advice of defun/defmacro/fset and possibly redefines
- ;;`byte-code' if a v19 byte-compiler is used. Redefining these primitives
- ;;might lead to problems. Use `ad-disable-definition-hooks' or
- ;;`ad-stop-advice' in such a case to establish a safe state."
- (ad-dolist (definer '(defun defmacro fset defalias define-function))
- (ad-enable-advice definer 'after 'ad-definition-hooks)
- (ad-activate definer 'compile))
- (cond (ad-use-jwz-byte-compiler
- (ad-real-byte-codify 'ad-advised-byte-code)
- (ad-real-byte-codify 'ad-scan-byte-code-for-fsets)
- ;; Now redefine byte-code...
- (ad-real-fset 'byte-code (symbol-function 'ad-advised-byte-code))
- ;; Only increase stack sizes in v18s, even though old-fashioned
- ;; v18 byte-code might be run in a v19, in which case one can call
- ;; `ad-adjust-stack-sizes' interactively if stacks become too small:
- (if (not ad-emacs19-p)
- (ad-adjust-stack-sizes)))))
-
-(defun ad-disable-definition-hooks ()
- ;;"Disables definition hooks by resetting definition primitives."
- (ad-recover-byte-code)
- (ad-dolist (definer '(defun defmacro fset defalias define-function))
- (ad-disable-advice definer 'after 'ad-definition-hooks)
- (ad-update definer))
- (if (not ad-emacs19-p)
- (ad-adjust-stack-sizes 'reset)))
-
-(ad-real-byte-codify 'ad-disable-definition-hooks)