/[emacs]/emacs/lisp/emacs-lisp/bytecomp.el
ViewVC logotype

Diff of /emacs/lisp/emacs-lisp/bytecomp.el

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 2.98.2.1 by miles, Thu Jun 13 07:35:53 2002 UTC revision 2.98.2.2 by miles, Fri Jun 14 08:26:09 2002 UTC
# Line 162  Line 162 
162      ;; This really ought to be loaded already!      ;; This really ought to be loaded already!
163      (load-library "byte-run"))      (load-library "byte-run"))
164    
165    ;; We want to do (require 'byte-lexbind) when compiling, to avoid compilation
166    ;; errors; however that file also wants to do (require 'bytecomp) for the
167    ;; same reason.  Since we know it's OK to load byte-lexbind.el second, we
168    ;; have that file require a feature that's provided before at the beginning
169    ;; of this file, to avoid an infinite require loop.
170    ;; `eval-when-compile' is defined in byte-run.el, so it must come after the
171    ;; preceding load expression.
172    (provide 'bytecomp-preload)
173    (eval-when-compile (require 'byte-lexbind))
174    
175  ;; The feature of compiling in a specific target Emacs version  ;; The feature of compiling in a specific target Emacs version
176  ;; has been turned off because compile time options are a bad idea.  ;; has been turned off because compile time options are a bad idea.
177  (defmacro byte-compile-single-version () nil)  (defmacro byte-compile-single-version () nil)
# Line 381  specify different fields to sort on." Line 391  specify different fields to sort on."
391    :type '(choice (const name) (const callers) (const calls)    :type '(choice (const name) (const callers) (const calls)
392                   (const calls+callers) (const nil)))                   (const calls+callers) (const nil)))
393    
394  (defvar byte-compile-debug nil)  ;(defvar byte-compile-debug nil)
395    (defvar byte-compile-debug t)
396    
397  ;; (defvar byte-compile-overwrite-file t  ;; (defvar byte-compile-overwrite-file t
398  ;;   "If nil, old .elc files are deleted before the new is saved, and .elc  ;;   "If nil, old .elc files are deleted before the new is saved, and .elc
# Line 408  This list lives partly on the stack.") Line 419  This list lives partly on the stack.")
419  ;;     (byte-compiler-options . (lambda (&rest forms)  ;;     (byte-compiler-options . (lambda (&rest forms)
420  ;;                             (apply 'byte-compiler-options-handler forms)))  ;;                             (apply 'byte-compiler-options-handler forms)))
421      (eval-when-compile . (lambda (&rest body)      (eval-when-compile . (lambda (&rest body)
422                             (list 'quote                             (list
423                                   (byte-compile-eval (byte-compile-top-level                              'quote
424                                                       (cons 'progn body))))))                              (byte-compile-eval
425                                  (byte-compile-top-level
426                                   (macroexpand-all
427                                    (cons 'progn body)
428                                    byte-compile-initial-macro-environment))))))
429      (eval-and-compile . (lambda (&rest body)      (eval-and-compile . (lambda (&rest body)
430                            (eval (cons 'progn body))                            (eval (cons 'progn body))
431                            (cons 'progn body))))                            (cons 'progn body))))
# Line 709  otherwise pop it") Line 724  otherwise pop it")
724  ;; front of the constants-vector than the constant-referencing instructions.  ;; front of the constants-vector than the constant-referencing instructions.
725  ;; Also, this lets us notice references to free variables.  ;; Also, this lets us notice references to free variables.
726    
727    (defmacro byte-compile-push-bytecodes (&rest args)
728      "Push BYTE... onto BYTES, and increment PC by the number of bytes pushed.
729    ARGS is of the form (BYTE... BYTES PC), where BYTES and PC are variable names.
730    BYTES and PC are updated after evaluating all the arguments."
731      (let ((byte-exprs (butlast args 2))
732            (bytes-var (car (last args 2)))
733            (pc-var (car (last args))))
734        `(setq ,bytes-var ,(if (null (cdr byte-exprs))
735                               `(cons ,@byte-exprs ,bytes-var)
736                             `(nconc (list ,@(reverse byte-exprs)) ,bytes-var))
737               ,pc-var (+ ,(length byte-exprs) ,pc-var))))
738    
739    (defmacro byte-compile-push-bytecode-const2 (opcode const2 bytes pc)
740      "Push OPCODE and the two-byte constant CONST2 onto BYTES, and add 3 to PC.
741    CONST2 may be evaulated multiple times."
742      `(byte-compile-push-bytecodes ,opcode (logand ,const2 255) (lsh ,const2 -8)
743                                    ,bytes ,pc))
744    
745  (defun byte-compile-lapcode (lap)  (defun byte-compile-lapcode (lap)
746    "Turns lapcode into bytecode.  The lapcode is destroyed."    "Turns lapcode into bytecode.  The lapcode is destroyed."
747    ;; Lapcode modifications: changes the ID of a tag to be the tag's PC.    ;; Lapcode modifications: changes the ID of a tag to be the tag's PC.
# Line 716  otherwise pop it") Line 749  otherwise pop it")
749          op off                  ; Operation & offset          op off                  ; Operation & offset
750          opcode                  ; numeric value of OP          opcode                  ; numeric value of OP
751          (bytes '())             ; Put the output bytes here          (bytes '())             ; Put the output bytes here
752          (patchlist nil)         ; List of tags and goto's to patch          (patchlist nil))        ; List of gotos to patch
753          rest rel tmp)      (dolist (lap-entry lap)
754      (while lap        (setq op (car lap-entry)
755        (setq op (car (car lap))              off (cdr lap-entry))
             off (cdr (car lap)))  
756        (cond ((not (symbolp op))        (cond ((not (symbolp op))
757               (error "Non-symbolic opcode `%s'" op))               (error "Non-symbolic opcode `%s'" op))
758              ((eq op 'TAG)              ((eq op 'TAG)
759               (setcar off pc)               (setcar off pc))
              (setq patchlist (cons off patchlist)))  
760              ((null op)              ((null op)
761               ;; a no-op added by `byte-compile-delay-out'               ;; a no-op added by `byte-compile-delay-out'
762               (unless (zerop off)               (unless (zerop off)
763                 (error                 (error
764                  "Placeholder added by `byte-compile-delay-out' not filled in.")                  "Placeholder added by `byte-compile-delay-out' not filled in.")
765                 ))                 ))
             ((memq op byte-goto-ops)  
              (setq pc (+ pc 3))  
              (setq bytes (cons (cons pc (cdr off))  
                                (cons nil  
                                      (cons (symbol-value op) bytes))))  
              (setq patchlist (cons bytes patchlist)))  
766              (t              (t
767               (setq opcode (symbol-value op))               (setq opcode (symbol-value op))
768               (setq bytes               (cond ((memq op byte-goto-ops)
769                     (cond ((cond ((consp off)                      ;; goto
770                                   ;; Variable or constant reference                      (byte-compile-push-bytecodes opcode nil (cdr off) bytes pc)
771                                   (setq off (cdr off))                      (push bytes patchlist))
772                                   (eq op 'byte-constant)))                     ((and (consp off)
773                            (cond ((< off byte-constant-limit)                           ;; Variable or constant reference
774                                   (setq pc (1+ pc))                           (progn (setq off (cdr off))
775                                   (cons (+ byte-constant off) bytes))                                  (eq op 'byte-constant)))
776                                  (t                      ;; constant ref
777                                   (setq pc (+ 3 pc))                      (if (< off byte-constant-limit)
778                                   (cons (lsh off -8)                          (byte-compile-push-bytecodes (+ byte-constant off)
779                                         (cons (logand off 255)                                                       bytes pc)
780                                               (cons byte-constant2 bytes))))))                        (byte-compile-push-bytecode-const2 byte-constant2 off
781                           ((and (= opcode byte-stack-set)                                                           bytes pc)))
782                                 (> off 255))                     ((and (= opcode byte-stack-set)
783                            ;; Use the two-byte version of byte-stack-set if the                           (> off 255))
784                            ;; offset is too large for the normal version.                      ;; Use the two-byte version of byte-stack-set if the
785                            (setq pc (+ 3 pc))                      ;; offset is too large for the normal version.
786                            (cons (lsh off -8)                      (byte-compile-push-bytecode-const2 byte-stack-set2 off
787                                  (cons (logand off 255)                                                         bytes pc))
788                                        (cons byte-stack-set2 bytes))))                     ((and (>= opcode byte-listN)
789                           ((and (>= opcode byte-listN)                           (<= opcode byte-vec-set))
790                                 (<= opcode byte-vec-set))                      ;; These insns all put their operand into one extra byte.
791                            ;; These insns all put their operand into one extra                      (byte-compile-push-bytecodes opcode off bytes pc))
792                            ;; byte.                     ((null off)
793                            (setq pc (+ 2 pc))                      ;; opcode that doesn't use OFF
794                            (cons off (cons opcode bytes)))                      (byte-compile-push-bytecodes opcode bytes pc))
795                           ((null off)                     ;; The following three cases are for the special
796                            ;; opcode that doesn't use OFF                     ;; insns that encode their operand into 0, 1, or 2
797                            (setq pc (1+ pc))                     ;; extra bytes depending on its magnitude.
798                            (cons opcode bytes))                     ((< off 6)
799                           ;; The following three cases are for the special                      (byte-compile-push-bytecodes (+ opcode off) bytes pc))
800                           ;; insns that encode their operand into 0, 1, or 2                     ((< off 256)
801                           ;; extra bytes depending on its magnitude.                      (byte-compile-push-bytecodes (+ opcode 6) off bytes pc))
802                           ((< off 6)                     (t
803                            (setq pc (1+ pc))                      (byte-compile-push-bytecode-const2 (+ opcode 7) off
804                            (cons (+ opcode off) bytes))                                                         bytes pc))))))
                          ((< off 256)  
                           (setq pc (+ 2 pc))  
                           (cons off (cons (+ opcode 6) bytes)))  
                          (t  
                           (setq pc (+ 3 pc))  
                           (cons (lsh off -8)  
                                 (cons (logand off 255)  
                                       (cons (+ opcode 7) bytes))))))))  
       (setq lap (cdr lap)))  
805      ;;(if (not (= pc (length bytes)))      ;;(if (not (= pc (length bytes)))
806      ;;    (error "Compiler error: pc mismatch - %s %s" pc (length bytes)))      ;;    (error "Compiler error: pc mismatch - %s %s" pc (length bytes)))
807      ;; Patch PC into jumps  
808      (let (bytes)      ;; Patch tag PCs into absolute jumps
809        (while patchlist      (dolist (bytes-tail patchlist)
810          (setq bytes (car patchlist))        (setq pc (caar bytes-tail))       ; Pick PC from goto's tag
811          (cond ((atom (car bytes)))      ; Tag        (setcar (cdr bytes-tail) (logand pc 255))
812                (t                        ; Absolute jump        (setcar bytes-tail (lsh pc -8)))
813                 (setq pc (car (cdr (car bytes))))        ; Pick PC from tag  
                (setcar (cdr bytes) (logand pc 255))  
                (setcar bytes (lsh pc -8))))  
         (setq patchlist (cdr patchlist))))  
814      (concat (nreverse bytes))))      (concat (nreverse bytes))))
815    
816    
# Line 2211  If FORM is a lambda or a macro, byte-com Line 2224  If FORM is a lambda or a macro, byte-com
2224            (setq fun (cdr fun)))            (setq fun (cdr fun)))
2225        (cond ((eq (car-safe fun) 'lambda)        (cond ((eq (car-safe fun) 'lambda)
2226               ;; expand macros               ;; expand macros
2227               (setq fun (macroexpand-all fun byte-compile-macro-environment))               (setq fun
2228                       (macroexpand-all fun
2229                                        byte-compile-initial-macro-environment))
2230               ;; get rid of the `function' quote added by the `lambda' macro               ;; get rid of the `function' quote added by the `lambda' macro
2231               (setq fun (cadr fun))               (setq fun (cadr fun))
2232               (setq fun (if macro               (setq fun (if macro
# Line 2623  If FORM is a lambda or a macro, byte-com Line 2638  If FORM is a lambda or a macro, byte-com
2638    (byte-compile-out 'byte-call (length (cdr form))))    (byte-compile-out 'byte-call (length (cdr form))))
2639    
2640  (defun byte-compile-check-variable (var &optional binding)  (defun byte-compile-check-variable (var &optional binding)
2641      "Do various error checks before a use of the variable VAR.
2642    If BINDING is non-nil, VAR is being bound."
2643    (when (symbolp var)    (when (symbolp var)
2644      (byte-compile-set-symbol-position var))      (byte-compile-set-symbol-position var))
2645    (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var))    (cond ((or (not (symbolp var)) (byte-compile-const-symbol-p var))
# Line 2649  If FORM is a lambda or a macro, byte-com Line 2666  If FORM is a lambda or a macro, byte-com
2666      (byte-compile-out base-op tmp)))      (byte-compile-out base-op tmp)))
2667    
2668  (defun byte-compile-dynamic-variable-bind (var)  (defun byte-compile-dynamic-variable-bind (var)
2669      "Generate code to bind the lexical variable VAR to the top-of-stack value."
2670    (byte-compile-check-variable var t)    (byte-compile-check-variable var t)
2671    (when (memq 'free-vars byte-compile-warnings)    (when (memq 'free-vars byte-compile-warnings)
2672      (push var byte-compile-bound-variables))      (push var byte-compile-bound-variables))
# Line 2657  If FORM is a lambda or a macro, byte-com Line 2675  If FORM is a lambda or a macro, byte-com
2675  ;; This is used when it's know that VAR _definitely_ has a lexical  ;; This is used when it's know that VAR _definitely_ has a lexical
2676  ;; binding, and no error-checking should be done.  ;; binding, and no error-checking should be done.
2677  (defun byte-compile-lexical-variable-ref (var)  (defun byte-compile-lexical-variable-ref (var)
2678      "Generate code to push the value of the lexical variable VAR on the stack."
2679    (let ((binding (assq var byte-compile-lexical-environment)))    (let ((binding (assq var byte-compile-lexical-environment)))
2680      (when (null binding)      (when (null binding)
2681        (error "Lexical binding not found for `%s'" var))        (error "Lexical binding not found for `%s'" var))
# Line 2670  If FORM is a lambda or a macro, byte-com Line 2689  If FORM is a lambda or a macro, byte-com
2689        (byte-compile-out 'byte-vec-ref (byte-compile-lexvar-offset binding)))))        (byte-compile-out 'byte-vec-ref (byte-compile-lexvar-offset binding)))))
2690    
2691  (defun byte-compile-variable-ref (var)  (defun byte-compile-variable-ref (var)
2692      "Generate code to push the value of the dynamic variable VAR on the stack."
2693    (byte-compile-check-variable var)    (byte-compile-check-variable var)
2694    (let ((lex-binding (assq var byte-compile-lexical-environment)))    (let ((lex-binding (assq var byte-compile-lexical-environment)))
2695      (if lex-binding      (if lex-binding
# Line 2693  If FORM is a lambda or a macro, byte-com Line 2713  If FORM is a lambda or a macro, byte-com
2713        (byte-compile-dynamic-variable-op 'byte-varref var))))        (byte-compile-dynamic-variable-op 'byte-varref var))))
2714    
2715  (defun byte-compile-variable-set (var)  (defun byte-compile-variable-set (var)
2716      "Generate code to set the dynamic variable VAR from the top-of-stack value."
2717    (byte-compile-check-variable var)    (byte-compile-check-variable var)
2718    (let ((lex-binding (assq var byte-compile-lexical-environment)))    (let ((lex-binding (assq var byte-compile-lexical-environment)))
2719      (if lex-binding      (if lex-binding
# Line 3343  if LFORMINFO is nil (meaning all binding Line 3364  if LFORMINFO is nil (meaning all binding
3364    init-lexenv)    init-lexenv)
3365    
3366  (defun byte-compile-let (form)  (defun byte-compile-let (form)
3367      "Generate code for the `let' form FORM."
3368    (let ((clauses (cadr form))    (let ((clauses (cadr form))
3369          (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form)))          (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form)))
3370          (init-lexenv nil)          (init-lexenv nil)
# Line 3386  if LFORMINFO is nil (meaning all binding Line 3408  if LFORMINFO is nil (meaning all binding
3408          (byte-compile-out 'byte-unbind (length clauses))))))          (byte-compile-out 'byte-unbind (length clauses))))))
3409    
3410  (defun byte-compile-let* (form)  (defun byte-compile-let* (form)
3411      "Generate code for the `let*' form FORM."
3412    (let ((clauses (cadr form))    (let ((clauses (cadr form))
3413          (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form)))          (lforminfo (and lexical-binding (byte-compile-compute-lforminfo form)))
3414          (init-lexenv nil)          (init-lexenv nil)

Legend:
Removed from v.2.98.2.1  
changed lines
  Added in v.2.98.2.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26