Mercurial > hg > xemacs-beta

comparison lisp/bytecomp.el @ 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 eac2e6bd5b2c
children 248176c74e6b
comparison
equal deleted inserted replaced
5390:593d9f73a7e8 5391:f9dc75bdbdc4
453 "list of all variables encountered during compilation of this form") 453 "list of all variables encountered during compilation of this form")
454 (defvar byte-compile-bound-variables nil 454 (defvar byte-compile-bound-variables nil
455 "Alist of variables bound in the context of the current form, 455 "Alist of variables bound in the context of the current form,
456 that is, the current lexical environment. This list lives partly 456 that is, the current lexical environment. This list lives partly
457 on the specbind stack. The cdr of each cell is an integer bitmask.") 457 on the specbind stack. The cdr of each cell is an integer bitmask.")
458 (defvar byte-compile-output-preface nil
459 "Form to output before current by `byte-compile-output-file-form'
460 This is used for implementing `load-time-value'.")
458 461
459 (defvar byte-compile-force-escape-quoted nil 462 (defvar byte-compile-force-escape-quoted nil
460 "If t, `byte-compile-maybe-reset-coding' always chooses `escape-quoted' 463 "If t, `byte-compile-maybe-reset-coding' always chooses `escape-quoted'
461 464
462 This is for situations where the byte compiler output file needs to be 465 This is for situations where the byte compiler output file needs to be
1975 (print-readably t) ; print #[] for bytecode, 'x for (quote x) 1978 (print-readably t) ; print #[] for bytecode, 'x for (quote x)
1976 (print-gensym (if (and byte-compile-print-gensym 1979 (print-gensym (if (and byte-compile-print-gensym
1977 (not byte-compile-emacs19-compatibility)) 1980 (not byte-compile-emacs19-compatibility))
1978 '(t) nil)) 1981 '(t) nil))
1979 print-gensym-alist) 1982 print-gensym-alist)
1983 (when byte-compile-output-preface
1984 (princ "\n(progn " byte-compile-outbuffer)
1985 (prin1 byte-compile-output-preface byte-compile-outbuffer))
1980 (princ "\n" byte-compile-outbuffer) 1986 (princ "\n" byte-compile-outbuffer)
1981 (prin1 form byte-compile-outbuffer) 1987 (prin1 form byte-compile-outbuffer)
1988 (when byte-compile-output-preface (princ ")" byte-compile-outbuffer))
1982 nil))) 1989 nil)))
1983 1990
1984 (defun byte-compile-output-docform (preface name info form specindex quoted) 1991 (defun byte-compile-output-docform (preface name info form specindex quoted)
1985 "Print a form with a doc string. INFO is (prefix doc-index postfix). 1992 "Print a form with a doc string. INFO is (prefix doc-index postfix).
1986 If PREFACE and NAME are non-nil, print them too, 1993 If PREFACE and NAME are non-nil, print them too,
2014 ;; negate POSITION. 2021 ;; negate POSITION.
2015 (if (and (stringp (nth (nth 1 info) form)) 2022 (if (and (stringp (nth (nth 1 info) form))
2016 (> (length (nth (nth 1 info) form)) 0) 2023 (> (length (nth (nth 1 info) form)) 0)
2017 (char= (aref (nth (nth 1 info) form) 0) ?*)) 2024 (char= (aref (nth (nth 1 info) form) 0) ?*))
2018 (setq position (- position))))) 2025 (setq position (- position)))))
2019
2020 (if preface
2021 (progn
2022 (insert preface)
2023 (prin1 name byte-compile-outbuffer)))
2024 (insert (car info))
2025 (let ((print-escape-newlines t) 2026 (let ((print-escape-newlines t)
2026 (print-readably t) ; print #[] for bytecode, 'x for (quote x) 2027 (print-readably t) ; print #[] for bytecode, 'x for (quote x)
2027 ;; Use a cons cell to say that we want 2028 ;; Use a cons cell to say that we want
2028 ;; print-gensym-alist not to be cleared between calls 2029 ;; print-gensym-alist not to be cleared between calls
2029 ;; to print functions. 2030 ;; to print functions.
2030 (print-gensym (if (and byte-compile-print-gensym 2031 (print-gensym (if (and byte-compile-print-gensym
2031 (not byte-compile-emacs19-compatibility)) 2032 (not byte-compile-emacs19-compatibility))
2032 '(t) nil)) 2033 '(t) nil))
2033 print-gensym-alist 2034 print-gensym-alist
2034 (index 0)) 2035 (index 0))
2036 (when byte-compile-output-preface
2037 (princ "\n(progn " byte-compile-outbuffer)
2038 (prin1 byte-compile-output-preface byte-compile-outbuffer))
2039 (byte-compile-flush-pending)
2040 (if preface
2041 (progn
2042 (insert preface)
2043 (prin1 name byte-compile-outbuffer)))
2044 (insert (car info))
2035 (prin1 (car form) byte-compile-outbuffer) 2045 (prin1 (car form) byte-compile-outbuffer)
2036 (while (setq form (cdr form)) 2046 (while (setq form (cdr form))
2037 (setq index (1+ index)) 2047 (setq index (1+ index))
2038 (insert " ") 2048 (insert " ")
2039 (cond ((and (numberp specindex) (= index specindex)) 2049 (cond ((and (numberp specindex) (= index specindex))
2056 byte-compile-outbuffer))) 2066 byte-compile-outbuffer)))
2057 (insert "\\\n") 2067 (insert "\\\n")
2058 (goto-char (point-max))))) 2068 (goto-char (point-max)))))
2059 (t 2069 (t
2060 (prin1 (car form) byte-compile-outbuffer))))) 2070 (prin1 (car form) byte-compile-outbuffer)))))
2061 (insert (nth 2 info)))))) 2071 (insert (nth 2 info))
2072 (when byte-compile-output-preface
2073 (princ ")" byte-compile-outbuffer))))))
2062 nil) 2074 nil)
2063 2075
2064 (defvar for-effect) ; ## Kludge! This should be an arg, not a special. 2076 (defvar for-effect) ; ## Kludge! This should be an arg, not a special.
2065 2077
2066 (defun byte-compile-keep-pending (form &optional handler) 2078 (defun byte-compile-keep-pending (form &optional handler)
2092 byte-compile-maxdepth 0 2104 byte-compile-maxdepth 0
2093 byte-compile-output nil)))) 2105 byte-compile-output nil))))
2094 2106
2095 (defun byte-compile-file-form (form) 2107 (defun byte-compile-file-form (form)
2096 (let ((byte-compile-current-form nil) ; close over this for warnings. 2108 (let ((byte-compile-current-form nil) ; close over this for warnings.
2109 (byte-compile-output-preface nil)
2097 handler) 2110 handler)
2098 (cond 2111 (cond
2099 ((not (consp form)) 2112 ((not (consp form))
2100 (byte-compile-keep-pending form)) 2113 (byte-compile-keep-pending form))
2101 ((and (symbolp (car form)) 2114 ((and (symbolp (car form))
2327 (nth 1 form)))) 2340 (nth 1 form))))
2328 (let* ((new-one (byte-compile-lambda (cons 'lambda (nthcdr 2 form)))) 2341 (let* ((new-one (byte-compile-lambda (cons 'lambda (nthcdr 2 form))))
2329 (code (byte-compile-byte-code-maker new-one)) 2342 (code (byte-compile-byte-code-maker new-one))
2330 (docform-info 2343 (docform-info
2331 (cond ((atom code) ; compiled-function-p 2344 (cond ((atom code) ; compiled-function-p
2332 (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) 2345 (if macrop '(" '(macro . #[" 4 "]))") '(" #[" 4 "])")))
2333 ((eq (car code) 'quote) 2346 ((eq (car code) 'quote)
2334 (setq code new-one) 2347 (setq code new-one)
2335 (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")"))) 2348 (if macrop '(" '(macro " 2 "))") '(" '(" 2 "))")))
2336 ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")")))))) 2349 ((if macrop '(" (cons 'macro (" 5 ")))") '(" (" 5 "))"))))))
2337 (if this-one 2350 (if this-one
2338 (setcdr this-one new-one) 2351 (setcdr this-one new-one)
2339 (set this-kind 2352 (set this-kind
2340 (cons (cons name new-one) (symbol-value this-kind)))) 2353 (cons (cons name new-one) (symbol-value this-kind))))
2341 (if (and (stringp (nth 3 form)) 2354 (if (and (stringp (nth 3 form))
2358 ;; compiled-function object, or a list of some kind. If it's not a 2371 ;; compiled-function object, or a list of some kind. If it's not a
2359 ;; cons, we must coerce it into a list of the elements to be 2372 ;; cons, we must coerce it into a list of the elements to be
2360 ;; printed to the file. 2373 ;; printed to the file.
2361 (if (consp code) 2374 (if (consp code)
2362 code 2375 code
2363 (nconc (list 2376 (list* (compiled-function-arglist code)
2364 (compiled-function-arglist code) 2377 (compiled-function-instructions code)
2365 (compiled-function-instructions code) 2378 (compiled-function-constants code)
2366 (compiled-function-constants code) 2379 (compiled-function-stack-depth code)
2367 (compiled-function-stack-depth code) 2380 (compiled-function-doc-string code)
2368 (compiled-function-doc-string code))
2369 (if (commandp code) 2381 (if (commandp code)
2370 (list (nth 1 (compiled-function-interactive code)))))) 2382 (list (nth 1 (compiled-function-interactive code))))))
2371 (and (atom code) byte-compile-dynamic 2383 (and (atom code) byte-compile-dynamic
2372 1) 2384 1)
2373 nil)) 2385 nil))
2374 (princ ")" byte-compile-outbuffer)
2375 nil))) 2386 nil)))
2376 2387
2377 ;; Print Lisp object EXP in the output file, inside a comment, 2388 ;; Print Lisp object EXP in the output file, inside a comment,
2378 ;; and return the file position it will have. 2389 ;; and return the file position it will have.
2379 ;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting. 2390 ;; If QUOTED is non-nil, print with quoting; otherwise, print without quoting.
3141 (byte-defop-compiler not 1) 3152 (byte-defop-compiler not 1)
3142 (byte-defop-compiler (null byte-not) 1) 3153 (byte-defop-compiler (null byte-not) 1)
3143 (byte-defop-compiler car 1) 3154 (byte-defop-compiler car 1)
3144 (byte-defop-compiler cdr 1) 3155 (byte-defop-compiler cdr 1)
3145 (byte-defop-compiler length 1) 3156 (byte-defop-compiler length 1)
3146 (byte-defop-compiler symbol-value 1) 3157 (byte-defop-compiler symbol-value)
3147 (byte-defop-compiler symbol-function 1) 3158 (byte-defop-compiler symbol-function 1)
3148 (byte-defop-compiler (1+ byte-add1) 1) 3159 (byte-defop-compiler (1+ byte-add1) 1)
3149 (byte-defop-compiler (1- byte-sub1) 1) 3160 (byte-defop-compiler (1- byte-sub1) 1)
3150 (byte-defop-compiler goto-char 1+1) 3161 (byte-defop-compiler goto-char 1+1)
3151 (byte-defop-compiler char-after 0-1+1) 3162 (byte-defop-compiler char-after 0-1+1)
4312 (byte-compile-form (car (cdr form))) 4323 (byte-compile-form (car (cdr form)))
4313 (byte-compile-out 'byte-temp-output-buffer-setup 0) 4324 (byte-compile-out 'byte-temp-output-buffer-setup 0)
4314 (byte-compile-body (cdr (cdr form))) 4325 (byte-compile-body (cdr (cdr form)))
4315 (byte-compile-out 'byte-temp-output-buffer-show 0)) 4326 (byte-compile-out 'byte-temp-output-buffer-show 0))
4316 4327
4328 (defun byte-compile-symbol-value (form)
4329 (symbol-macrolet ((not-present '#:not-present))
4330 (let ((cl-load-time-value-form not-present)
4331 (byte-compile-bound-variables byte-compile-bound-variables) gensym)
4332 (and (consp (cadr form))
4333 (eq 'quote (caadr form))
4334 (setq gensym (cadadr form))
4335 (symbolp gensym)
4336 (setq cl-load-time-value-form
4337 (get gensym 'cl-load-time-value-form not-present)))
4338 (unless (eq cl-load-time-value-form not-present)
4339 (setq byte-compile-bound-variables
4340 (acons gensym byte-compile-global-bit
4341 byte-compile-bound-variables)
4342 byte-compile-output-preface
4343 (byte-compile-top-level
4344 (if byte-compile-output-preface
4345 `(progn (setq ,gensym ,cl-load-time-value-form)
4346 ,byte-compile-output-preface)
4347 `(setq ,gensym ,cl-load-time-value-form))
4348 t 'file)))
4349 (byte-compile-one-arg form))))
4350
4317 (defun byte-compile-multiple-value-call (form) 4351 (defun byte-compile-multiple-value-call (form)
4318 (if (< (length form) 2) 4352 (if (< (length form) 2)
4319 (progn 4353 (progn
4320 (byte-compile-warn-wrong-args form 1) 4354 (byte-compile-warn-wrong-args form 1)
4321 (byte-compile-normal-call 4355 (byte-compile-normal-call