Initial revision

lisp/byte-run.el

@@ -0,0 +1,173 @@
+;;; -*- Mode:Emacs-Lisp -*-
+
+;; Runtime support for the new optimizing byte compiler.  
+;; By Jamie Zawinski <jwz@lucid.com>.
+;; Last Modified: 27-jul-91.
+;;
+;; The code in this file should always be loaded, because it defines things 
+;; like "defsubst" which should work interpreted as well.  The code in 
+;; bytecomp.el and byte-optimize.el can be loaded as needed.
+;;
+;; This should be loaded by loadup.el or startup.el.  If you can't modify
+;; those files, load this from your .emacs file.  But if you are using
+;; emacs18, this file must be loaded before any .elc files which were
+;; generated by the new compiler without emacs18 compatibility turned on.
+;; If this file is loaded, certain emacs19 binaries will run in emacs18.
+;; Meditate on the meanings of byte-compile-generate-emacs19-bytecodes and
+;; byte-compile-emacs18-compatibility.
+
+
+;; Copyright (C) 1985, 1986, 1987 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;; emacs-18 compatibility.
+
+(if (fboundp 'make-byte-code)
+    nil
+  ;;
+  ;; To avoid compiler bootstrapping problems, this temporary uncompiled
+  ;; make-byte-code is needed to load the compiled one.  Ignore the warnings.
+  (fset 'make-byte-code
+	'(lambda (arglist bytestring constants stackdepth doc)
+	   (list 'lambda arglist doc
+		 (list 'byte-code bytestring constants stackdepth))))
+  ;;
+  ;; Now get a compiled version.
+  (defun make-byte-code (arglist bytestring constants stackdepth
+				 &optional doc &rest interactive)
+    "For compatibility with Emacs19 ``.elc'' files."
+    (nconc (list 'lambda arglist)
+	   ;; #### Removed the (stringp doc) for speed.  Because the V19
+	   ;;	make-byte-code depends on the args being correct, it won't
+	   ;;	help to make a smarter version for V18 alone.
+	   ;;	Btw, it should have been (or (stringp doc) (natnump doc)).  
+	   (if doc (list doc))
+	   (if interactive
+	       (list (cons 'interactive (if (car interactive) interactive))))
+	   (list (list 'byte-code bytestring constants stackdepth)))))
+
+
+;;; interface to selectively inlining functions.
+;;; This only happens when source-code optimization is turned on.
+
+;; Redefined in byte-optimize.el.
+(fset 'inline 'progn)
+(put 'inline 'lisp-indent-hook 0)
+
+
+;;; Interface to inline functions.
+
+(defmacro proclaim-inline (&rest fns)
+  "Cause the named functions to be open-coded when called from compiled code.
+They will only be compiled open-coded when byte-compile-optimize is true."
+  (cons 'eval-and-compile
+	(mapcar '(lambda (x)
+		   (or (memq (get x 'byte-optimizer)
+			     '(nil byte-compile-inline-expand))
+		       (error
+			"%s already has a byte-optimizer, can't make it inline"
+			x))
+		   (list 'put (list 'quote x)
+			 ''byte-optimizer ''byte-compile-inline-expand))
+		fns)))
+
+
+(defmacro proclaim-notinline (&rest fns)
+  "Cause the named functions to no longer be open-coded."
+  (cons 'eval-and-compile
+	(mapcar '(lambda (x)
+		   (if (eq (get x 'byte-optimizer) 'byte-compile-inline-expand)
+		       (put x 'byte-optimizer nil))
+		   (list 'if (list 'eq (list 'get (list 'quote x) ''byte-optimizer)
+				   ''byte-compile-inline-expand)
+			 (list 'put x ''byte-optimizer nil)))
+		fns)))
+
+;; This has a special byte-hunk-handler in bytecomp.el.
+(defmacro defsubst (name arglist &rest body)
+  "Same syntax as defun, but the defined function will always be open-coded,
+so long as byte-compile-optimize is true."
+  (list 'prog1
+	(cons 'defun (cons name (cons arglist body)))
+	(list 'proclaim-inline name)))
+
+(defun make-obsolete (fn new)
+  "Make the byte-compiler warn that FUNCTION is obsolete and NEW should be
+used instead.  If NEW is a string, that is the `use instead' message."
+  (interactive "aMake function obsolete: \nxObsoletion replacement: ")
+  (let ((handler (get fn 'byte-compile)))
+    (if (eq 'byte-compile-obsolete handler)
+	(setcar (get fn 'byte-obsolete-info) new)
+      (put fn 'byte-obsolete-info (cons new handler))
+      (put fn 'byte-compile 'byte-compile-obsolete)))
+  fn)
+
+(put 'dont-compile 'lisp-indent-hook 0)
+(defmacro dont-compile (&rest body)
+  "Like progn, but the body will always run interpreted (not compiled)."
+  (list 'eval (list 'quote (if (cdr body) (cons 'progn body) (car body)))))
+
+
+;;; interface to evaluating things at compile time and/or load time
+;;; these macro must come after any uses of them in this file, as their
+;;; definition in the file overrides the magic definitions on the
+;;; byte-compile-macro-environment.
+
+(put 'eval-when-compile 'lisp-indent-hook 0)
+(defmacro eval-when-compile (&rest body)
+  "Like progn, but evaluates the body at compile-time.  The result of the
+body appears to the compiler as a quoted constant."
+  ;; Not necessary because we have it in b-c-initial-macro-environment
+  ;; (list 'quote (eval (cons 'progn body)))
+  (cons 'progn body))
+
+(put 'eval-and-compile 'lisp-indent-hook 0)
+(defmacro eval-and-compile (&rest body)
+  "Like progn, but evaluates the body at compile-time as well as at load-time."
+  ;; Remember, it's magic.
+  (cons 'progn body))
+
+
+;;; Interface to file-local byte-compiler parameters.
+;;; Redefined in bytecomp.el.
+
+(put 'byte-compiler-options 'lisp-indent-hook 0)
+(defmacro byte-compiler-options (&rest args)
+  "Set some compilation-parameters for this file.  This will affect only the
+file in which it appears; this does nothing when evaluated, and when loaded
+from a .el file.
+
+Each argument to this macro must be a list of a key and a value.
+
+  Keys:		  Values:		Corresponding variable:
+
+  verbose	  t, nil		byte-compile-verbose
+  optimize	  t, nil, source, byte	byte-compile-optimize
+  warnings	  list of warnings	byte-compile-warnings
+		      Legal elements: (callargs redefine free-vars unresolved)
+  file-format	  emacs18, emacs19	byte-compile-emacs18-compatibility
+  new-bytecodes	  t, nil		byte-compile-generate-emacs19-bytecodes
+
+For example, this might appear at the top of a source file:
+
+    (byte-compiler-options
+      (optimize t)
+      (warnings (- free-vars))		; Don't warn about free variables
+      (file-format emacs19))"
+  nil)

lisp/emacs-lisp/disass.el

@@ -0,0 +1,224 @@
+;;; Disassembler for compiled Emacs Lisp code
+;;; Copyright (C) 1986 Free Software Foundation, Inc.
+;;; Original version by Doug Cutting (doug@csli.stanford.edu)
+;;; Substantially modified by Jamie Zawinski <jwz@lucid.com> for
+;;; the new lapcode-based byte compiler.
+;;; Last modified 22-oct-91.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to
+;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+
+;;; The variable byte-code-vector is defined by the new bytecomp.el.
+;;; The function byte-decompile-lapcode is defined in byte-optimize.el.
+(require 'byte-optimize)
+
+(defvar disassemble-column-1-indent 5 "*")
+(defvar disassemble-column-2-indent 10 "*")
+
+(defvar disassemble-recursive-indent 3 "*")
+
+(defun disassemble (object &optional buffer indent interactive-p)
+  "Print disassembled code for OBJECT in (optional) BUFFER.
+OBJECT can be a symbol defined as a function, or a function itself
+\(a lambda expression or a compiled-function object).
+If OBJECT is not already compiled, we compile it, but do not
+redefine OBJECT if it is a symbol."
+  (interactive (list (intern (completing-read "Disassemble function: "
+					      obarray 'fboundp t))
+		     nil 0 t))
+  (if (eq (car-safe object) 'byte-code)
+      (setq object (list 'lambda () object)))
+  (or indent (setq indent 0))		;Default indent to zero
+  (save-excursion
+    (if (or interactive-p (null buffer))
+	(with-output-to-temp-buffer "*Disassemble*"
+	  (set-buffer "*Disassemble*")
+	  (disassemble-internal object indent (not interactive-p)))
+      (set-buffer buffer)
+      (disassemble-internal object indent nil)))
+  nil)
+
+
+(defun disassemble-internal (obj indent interactive-p)
+  (let ((macro 'nil)
+	(name 'nil)
+	(doc 'nil)
+	args)
+    (while (symbolp obj)
+      (setq name obj
+	    obj (symbol-function obj)))
+    (if (subrp obj)
+	(error "Can't disassemble #<subr %s>" name))
+    (if (eq (car-safe obj) 'macro)	;handle macros
+	(setq macro t
+	      obj (cdr obj)))
+    (if (and (listp obj) (not (eq (car obj) 'lambda)))
+	(error "not a function"))
+    (if (consp obj)
+	(if (assq 'byte-code obj)
+	    nil
+	  (if interactive-p (message (if name
+					 "Compiling %s's definition..."
+				       "Compiling definition...")
+				     name))
+	  (setq obj (byte-compile obj))
+	  (if interactive-p (message "Done compiling.  Disassembling..."))))
+    (cond ((consp obj)
+	   (setq obj (cdr obj))		;throw lambda away
+	   (setq args (car obj))	;save arg list
+	   (setq obj (cdr obj)))
+	  (t
+	   (setq args (aref obj 0))))
+    (if (zerop indent) ; not a nested function
+	(progn
+	  (indent-to indent)
+	  (insert (format "byte code%s%s%s:\n"
+			  (if (or macro name) " for" "")
+			  (if macro " macro" "")
+			  (if name (format " %s" name) "")))))
+    (let ((doc (if (consp obj)
+		   (and (stringp (car obj)) (car obj))
+		 (and (> (length obj) 4) (aref obj 4)))))
+      (if (and doc (stringp doc))
+	  (progn (and (consp obj) (setq obj (cdr obj)))
+		 (indent-to indent)
+		 (princ "  doc:  " (current-buffer))
+		 (if (string-match "\n" doc)
+		     (setq doc (concat (substring doc 0 (match-beginning 0))
+				       " ...")))
+		 (insert doc "\n"))))
+    (indent-to indent)
+    (insert "  args: ")
+    (prin1 args (current-buffer))
+    (insert "\n")
+    (let ((interactive (cond ((consp obj)
+			      (assq 'interactive obj))
+			     ((> (length obj) 5)
+			      (list 'interactive (aref obj 5))))))
+      (if interactive
+	  (progn
+	    (setq interactive (nth 1 interactive))
+	    (if (eq (car-safe (car-safe obj)) 'interactive)
+		(setq obj (cdr obj)))
+	    (indent-to indent)
+	    (insert " interactive: ")
+	    (if (eq (car-safe interactive) 'byte-code)
+		(progn
+		  (insert "\n")
+		  (disassemble-1 interactive
+				 (+ indent disassemble-recursive-indent)))
+	      (let ((print-escape-newlines t))
+		(prin1 interactive (current-buffer))))
+	    (insert "\n"))))
+    (cond ((and (consp obj) (assq 'byte-code obj))
+	   (disassemble-1 (assq 'byte-code obj) indent))
+	  ((compiled-function-p obj)
+	   (disassemble-1 obj indent))
+	  (t
+	   (insert "Uncompiled body:  ")
+	   (let ((print-escape-newlines t))
+	     (prin1 (if (cdr obj) (cons 'progn obj) (car obj))
+		    (current-buffer))))))
+  (if interactive-p
+      (message "")))
+
+
+(defun disassemble-1 (obj indent)
+  "Prints the byte-code call OBJ in the current buffer.
+OBJ should be a call to BYTE-CODE generated by the byte compiler."
+  (let (bytes constvec)
+    (if (consp obj)
+	(setq bytes (car (cdr obj))		;the byte code
+	      constvec (car (cdr (cdr obj))))	;constant vector
+      (setq bytes (aref obj 1)
+	    constvec (aref obj 2)))
+    (let ((lap (byte-decompile-bytecode bytes constvec))
+	  op arg opname)
+      (let ((tagno 0)
+	    tmp
+	    (lap lap))
+	(while (setq tmp (assq 'TAG lap))
+	  (setcar (cdr tmp) (setq tagno (1+ tagno)))
+	  (setq lap (cdr (memq tmp lap)))))
+      (while lap
+	(setq op (car (car lap))
+	      arg (cdr (car lap)))
+	(indent-to indent)
+	(if (eq 'TAG op)
+	    (insert (int-to-string (car arg)) ":")
+
+	  (indent-to (+ indent disassemble-column-1-indent))
+	  (if (and op
+		   (string-match "^byte-" (setq opname (symbol-name op))))
+	      (setq opname (substring opname 5))
+	    (setq opname "<not-an-opcode>"))
+	  (if (eq op 'byte-constant2)
+	      (insert " #### shouldn't have seen constant2 here!\n  "))
+	  (insert opname)
+	  (indent-to (+ indent disassemble-column-1-indent
+			disassemble-column-2-indent
+			-1))
+	  (insert " ")
+	  (cond ((memq op byte-goto-ops)
+		 (insert (int-to-string (nth 1 arg))))
+		((memq op '(byte-call byte-unbind
+			    byte-listN byte-concatN byte-insertN))
+		 (insert (int-to-string arg)))
+		((memq op '(byte-varref byte-varset byte-varbind))
+		 (prin1 (car arg) (current-buffer)))
+		((memq op '(byte-constant byte-constant2))
+		 ;; it's a constant
+		 (setq arg (car arg))
+		 ;; but if the value of the constant is compiled code, then
+		 ;; recursively disassemble it.
+		 (cond ((or (compiled-function-p arg)
+			    (and (eq (car-safe arg) 'lambda)
+				 (assq 'byte-code arg))
+			    (and (eq (car-safe arg) 'macro)
+				 (or (compiled-function-p (cdr arg))
+				     (and (eq (car-safe (cdr arg)) 'lambda)
+					  (assq 'byte-code (cdr arg))))))
+			(cond ((compiled-function-p arg)
+			       (insert "<compiled-function>\n"))
+			      ((eq (car-safe arg) 'lambda)
+			       (insert "<compiled lambda>"))
+			      (t (insert "<compiled macro>\n")))
+			(disassemble-internal
+			 arg
+			 (+ indent disassemble-recursive-indent 1)
+			 nil))
+		       ((eq (car-safe arg) 'byte-code)
+			(insert "<byte code>\n")
+			(disassemble-1	;recurse on byte-code object
+			 arg
+			 (+ indent disassemble-recursive-indent)))
+		       ((eq (car-safe (car-safe arg)) 'byte-code)
+			(insert "(<byte code>...)\n")
+			(mapcar ;recurse on list of byte-code objects
+			 '(lambda (obj)
+			    (disassemble-1
+			     obj
+			     (+ indent disassemble-recursive-indent)))
+			 arg))
+		       (t
+			;; really just a constant
+			(let ((print-escape-newlines t))
+			  (prin1 arg (current-buffer))))))
+		)
+	  (insert "\n"))
+	(setq lap (cdr lap)))))
+  nil)