[COMMIT] Implement #'load-time-value less hackishly, by modifying the byte compiler.

APPROVE COMMIT NOTE: This patch has been committed. # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # Date 1301757200 -3600 # Node ID f9dc75bdbdc4f757f86183ecf2b6eac8fe135919 # Parent 593d9f73a7e817ea765f164c0bd08853b4e02660 Implement #'load-time-value less hackishly, by modifying the byte compiler. 2011-04-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; * bytecomp.el (byte-compile-output-preface): New. * bytecomp.el (byte-compile-output-file-form): * bytecomp.el (byte-compile-output-docform): * bytecomp.el (byte-compile-file-form): * bytecomp.el (byte-compile-file-form-defmumble): * bytecomp.el (symbol-value): * bytecomp.el (byte-compile-symbol-value): New. * cl-macs.el (load-time-value): No longer implement load-time-value by very hackishly redefining #'byte-compile-file-form-defmumble, instead make the appropriate changes in #'byte-compile-file-form-defmumble and #'byte-compile-file-form instead. We also add a specific byte-compile method for #'symbol-value, using the add-properties-to-a-gensym approach that worked for #'block and #'return-from. diff -r 593d9f73a7e8 -r f9dc75bdbdc4 lisp/ChangeLog --- a/lisp/ChangeLog Sat Apr 02 17:04:38 2011 +0900 +++ b/lisp/ChangeLog Sat Apr 02 16:13:20 2011 +0100 ＠＠ -1,3 +1,20 ＠＠ +2011-04-02 Aidan Kehoe <kehoea(a)parhasard.net&gt; + + * bytecomp.el (byte-compile-output-preface): New. + * bytecomp.el (byte-compile-output-file-form): + * bytecomp.el (byte-compile-output-docform): + * bytecomp.el (byte-compile-file-form): + * bytecomp.el (byte-compile-file-form-defmumble): + * bytecomp.el (symbol-value): + * bytecomp.el (byte-compile-symbol-value): New. + * cl-macs.el (load-time-value): + No longer implement load-time-value by very hackishly redefining + #'byte-compile-file-form-defmumble, instead make the appropriate + changes in #'byte-compile-file-form-defmumble and + #'byte-compile-file-form instead. We also add a specific byte-compile + method for #'symbol-value, using the add-properties-to-a-gensym + approach that worked for #'block and #'return-from. + 2011-03-29 Aidan Kehoe <kehoea(a)parhasard.net&gt; * cl-extra.el (cl-finite-do, cl-float-limits): diff -r 593d9f73a7e8 -r f9dc75bdbdc4 lisp/bytecomp.el --- a/lisp/bytecomp.el Sat Apr 02 17:04:38 2011 +0900 +++ b/lisp/bytecomp.el Sat Apr 02 16:13:20 2011 +0100 ＠＠ -455,6 +455,9 ＠＠ "Alist of variables bound in the context of the current form, that is, the current lexical environment. This list lives partly on the specbind stack. The cdr of each cell is an integer bitmask.") +(defvar byte-compile-output-preface nil + "Form to output before current by `byte-compile-output-file-form' +This is used for implementing `load-time-value'.") (defvar byte-compile-force-escape-quoted nil "If t, `byte-compile-maybe-reset-coding' always chooses `escape-quoted' ＠＠ -1977,8 +1980,12 ＠＠ (not byte-compile-emacs19-compatibility)) '(t) nil)) print-gensym-alist) + (when byte-compile-output-preface + (princ "\n(progn " byte-compile-outbuffer) + (prin1 byte-compile-output-preface byte-compile-outbuffer)) (princ "\n" byte-compile-outbuffer) (prin1 form byte-compile-outbuffer) + (when byte-compile-output-preface (princ ")" byte-compile-outbuffer)) nil))) (defun byte-compile-output-docform (preface name info form specindex quoted) ＠＠ -2016,12 +2023,6 ＠＠ (> (length (nth (nth 1 info) form)) 0) (char= (aref (nth (nth 1 info) form) 0) ?*)) (setq position (- position))))) - - (if preface - (progn - (insert preface) - (prin1 name byte-compile-outbuffer))) - (insert (car info)) (let ((print-escape-newlines t) (print-readably t) ; print #[] for bytecode, 'x for (quote x) ;; Use a cons cell to say that we want ＠＠ -2032,6 +2033,15 ＠＠ '(t) nil)) print-gensym-alist (index 0)) + (when byte-compile-output-preface + (princ "\n(progn " byte-compile-outbuffer) + (prin1 byte-compile-output-preface byte-compile-outbuffer)) + (byte-compile-flush-pending) + (if preface + (progn + (insert preface) + (prin1 name byte-compile-outbuffer))) + (insert (car info)) (prin1 (car form) byte-compile-outbuffer) (while (setq form (cdr form)) (setq index (1+ index)) ＠＠ -2058,7 +2068,9 ＠＠ (goto-char (point-max))))) (t (prin1 (car form) byte-compile-outbuffer))))) - (insert (nth 2 info)))))) + (insert (nth 2 info)) + (when byte-compile-output-preface + (princ ")" byte-compile-outbuffer)))))) nil) (defvar for-effect) ; ## Kludge! This should be an arg, not a special. ＠＠ -2094,6 +2106,7 ＠＠ (defun byte-compile-file-form (form) (let ((byte-compile-current-form nil) ; close over this for warnings. + (byte-compile-output-preface nil) handler) (cond ((not (consp form)) ＠＠ -2329,11 +2342,11 ＠＠ (code (byte-compile-byte-code-maker new-one)) (docform-info (cond ((atom code) ; compiled-function-p - (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) + (if macrop '(" '(macro . #[" 4 "]))") '(" #[" 4 "])"))) ((eq (car code) 'quote) (setq code new-one) - (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")"))) - ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")")))))) + (if macrop '(" '(macro " 2 "))") '(" '(" 2 "))"))) + ((if macrop '(" (cons 'macro (" 5 ")))") '(" (" 5 "))")))))) (if this-one (setcdr this-one new-one) (set this-kind ＠＠ -2360,18 +2373,16 ＠＠ ;; printed to the file. (if (consp code) code - (nconc (list - (compiled-function-arglist code) - (compiled-function-instructions code) - (compiled-function-constants code) - (compiled-function-stack-depth code) - (compiled-function-doc-string code)) + (list* (compiled-function-arglist code) + (compiled-function-instructions code) + (compiled-function-constants code) + (compiled-function-stack-depth code) + (compiled-function-doc-string code) (if (commandp code) (list (nth 1 (compiled-function-interactive code)))))) (and (atom code) byte-compile-dynamic 1) nil)) - (princ ")" byte-compile-outbuffer) nil))) ;; Print Lisp object EXP in the output file, inside a comment, ＠＠ -3143,7 +3154,7 ＠＠ (byte-defop-compiler car 1) (byte-defop-compiler cdr 1) (byte-defop-compiler length 1) -(byte-defop-compiler symbol-value 1) +(byte-defop-compiler symbol-value) (byte-defop-compiler symbol-function 1) (byte-defop-compiler (1+ byte-add1) 1) (byte-defop-compiler (1- byte-sub1) 1) ＠＠ -4314,6 +4325,29 ＠＠ (byte-compile-body (cdr (cdr form))) (byte-compile-out 'byte-temp-output-buffer-show 0)) +(defun byte-compile-symbol-value (form) + (symbol-macrolet ((not-present '#:not-present)) + (let ((cl-load-time-value-form not-present) + (byte-compile-bound-variables byte-compile-bound-variables) gensym) + (and (consp (cadr form)) + (eq 'quote (caadr form)) + (setq gensym (cadadr form)) + (symbolp gensym) + (setq cl-load-time-value-form + (get gensym 'cl-load-time-value-form not-present))) + (unless (eq cl-load-time-value-form not-present) + (setq byte-compile-bound-variables + (acons gensym byte-compile-global-bit + byte-compile-bound-variables) + byte-compile-output-preface + (byte-compile-top-level + (if byte-compile-output-preface + `(progn (setq ,gensym ,cl-load-time-value-form) + ,byte-compile-output-preface) + `(setq ,gensym ,cl-load-time-value-form)) + t 'file))) + (byte-compile-one-arg form)))) + (defun byte-compile-multiple-value-call (form) (if (< (length form) 2) (progn diff -r 593d9f73a7e8 -r f9dc75bdbdc4 lisp/cl-macs.el --- a/lisp/cl-macs.el Sat Apr 02 17:04:38 2011 +0900 +++ b/lisp/cl-macs.el Sat Apr 02 16:13:20 2011 +0100 ＠＠ -621,25 +621,15 ＠＠ (defmacro load-time-value (form &optional read-only) "Like `progn', but evaluates the body at load time. The result of the body appears to the compiler as a quoted constant." - (if (cl-compiling-file) - (let* ((temp (gentemp "--cl-load-time--")) - (set (list 'set (list 'quote temp) form))) - (if (and (fboundp 'byte-compile-file-form-defmumble) - (boundp 'this-kind) (boundp 'that-one)) - (fset 'byte-compile-file-form - (list 'lambda '(form) - (list 'fset '(quote byte-compile-file-form) - (list 'quote - (symbol-function 'byte-compile-file-form))) - (list 'byte-compile-file-form (list 'quote set)) - '(byte-compile-file-form form))) - ;; XEmacs change - (print set (symbol-value ;;'outbuffer - 'byte-compile-output-buffer - ))) - (list 'symbol-value (list 'quote temp))) - (list 'quote (eval form)))) - + (let ((gensym (gensym))) + ;; The body of this macro really should be (cons 'progn form), with the + ;; hairier stuff in a shadowed version in + ;; byte-compile-initial-macro-environment. That doesn't work because + ;; cl-macs.el doesn't respect byte-compile-macro-environment, which is + ;; something we should change. + (put gensym 'cl-load-time-value-form form) + (set gensym (eval form)) + `(symbol-value ',gensym))) ;;; Conditional control structures. -- “Apart from the nine-banded armadillo, man is the only natural host of Mycobacterium leprae, although it can be grown in the footpads of mice.” -- Kumar & Clark, Clinical Medicine, summarising improbable leprosy research _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches