Mercurial > hg > xemacs-beta

comparison lisp/bytecomp.el @ 5475:248176c74e6b

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