Mercurial > hg > xemacs-beta

changeset 5391:f9dc75bdbdc4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Implement #'load-time-value less hackishly, by modifying the byte compiler. 2011-04-02 Aidan Kehoe <kehoea@parhasard.net> * 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.
author Aidan Kehoe <kehoea@parhasard.net>
date Sat, 02 Apr 2011 16:13:20 +0100
parents 593d9f73a7e8
children 25c10648ffba
files lisp/ChangeLog lisp/bytecomp.el lisp/cl-macs.el
diffstat 3 files changed, 78 insertions(+), 37 deletions(-) [+]
line wrap: on
line diff
--- 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@parhasard.net>
+
+	* 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@parhasard.net>
 
 	* cl-extra.el (cl-finite-do, cl-float-limits):
--- 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
--- 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.