Commits

Anonymous committed 67937b3

Update to sync with proposed 5.12.0 release.

Comments (0)

Files changed (10)

 Tim Bradshaw,
 David Braunegg,
 Thomas M. Breuel,
+Craig Brozefsky (Debian packaging),
+Gary Byers (for the OpenMCL code), 
 Rick Campbell,
 Hans Chalupsky,
 Kimball Collins,
 Robert P. Goldman,
 Marty Hall,
 Richard Harris,
+Utz-Uwe Haus,
 Jim Healy,
 Matthias Hoelzl,
 Christopher Hoover,
 Mark Kantrowitz,
 Michael Kashket,
 Matthias Koeppe,
+Hannu Koivisto,
 Qiegang Long,
 Christian Lynbech,
 Erik Naggum,
 Dan Pierson,
 Yusuf Pisan,
 Frank Ritter,
+Ole Rohne,
 Jeffrey Mark Siskind,
 Neil Smithline,
 Richard Stallman,
 Jason Trenouth,
 Christof Ullwer,
 Bjorn Victor,
+Edmund Weitz,
 Fred White,
 Ben Wing,
 Matsuo Yoshihiro,
-ILISP 5.11.1
+ILISP 5.12.0
 ============
 
 ILISP is a powerful GNU Emacs interface to many dialects of Lisp, including
 ;;; Allegro initializations
 ;;; Author: Chris McConnell, ccm@cs.cmu.edu
 
-(in-package "ILISP")
+(in-package :ilisp)
 
 ;;; 20001203 Patch suggested by Larry Hunter <Larry.Hunter@uchsc.edu>
 ;;; EXCL::FN_SYMDEF is no longer available by default.
 
-#+(or allegro-v5.0 allegro-v6.0) (eval-when (compile load) (require
+#+(or allegro-v5.0 allegro-v6.0 allegro-v6.1) (eval-when (compile load) (require
                                                             :llstructs))
 
 ;;;
 ;;; another option might be sys::arglist ...
 ;;; added command to preload inspect1
 
-(in-package "ILISP")
+(in-package :ilisp)
 
 ;;;
 (defun ilisp-inspect (sexp package)
   (setq excl:*cltl1-in-package-compatibility-p* t))
 
 
-(in-package "ILISP")
+(in-package :ilisp)
 
 ;;;
 ;;; GCL 2.2 and GCL 2.3 do not have defpackage (yet) so we need to put
 ;;; Please note that while the comment and the fix posted by R. Toy
 ;;; are correct, they are deprecated by at least one of the ILISP
 ;;; maintainers. :) By removing the 'nil' in the following #+, you
-;;; will fix the problem but will not do a good service to the CL
-;;; community.  The right thing to do is to install DEFPACKAGE in your
-;;; GCL and to write the GCL maintainers and to ask them to
-;;; incorporate DEFPACKAGE in their standard builds.
+;;; will fix the problem.  However you are advised to install
+;;; DEFPACKAGE in your GCL and to write the GCL maintainers and to ask
+;;; them to incorporate DEFPACKAGE in their standard builds if this is
+;;; not so yet.
+
 ;;; 19960715 Marco Antoniotti
-;;; 20000404 Martin Atzmueller: same for ecl/ecls
+;;; 20010831 Marco Antoniotti
 
-#+(or (and nil gcl) (and nil ecl))
+#+(or (and nil gcl))
 (export '(ilisp-errors
 	  ilisp-save
 	  ilisp-restore
 
 (defvar *ilisp-message-addon-string* "ILISP:")
 
-(defmacro the-symbol-if-defined ((if-symbol
-                                  if-package
-                                  &optional else-symbol else-package)
+(defmacro the-symbol-if-defined (((if-symbol if-package)
+                                  (&optional else-symbol else-package)
+                                  &key eval-p)
                                  &body body)
   (let* ((sym-if (and (find-package if-package)
                       (find-symbol (symbol-name if-symbol)
              (and else-symbol
                   (find-package else-package)
                   (find-symbol (symbol-name else-symbol)
-                               (find-package else-package))))))
+                               (find-package else-package)))))
+         (tmp-symbol (or sym-if sym-else)))
     (if (consp (first body))
-      `(let ((the-symbol ,(or sym-if sym-else)))
+      `(let ((the-symbol (symbol-value ',tmp-symbol)))
         ,@body)
-      `',(or sym-if  sym-else))))
+      (if eval-p
+        `,(eval tmp-symbol)
+        `',tmp-symbol))))
                    
-(defmacro the-function-if-defined ((if-function
-                                    if-package
-                                    &optional else-function else-package)
+(defmacro the-function-if-defined (((if-function if-package)
+                                    (&optional else-function else-package)
+                                    &key function-binding-p)
                                    &body body)
   (let* ((fun-if
            (ignore-errors
                     (find-symbol (symbol-name else-function)
                                  (find-package else-package)))))))
     (when (or fun-if fun-else)
-      (if (and (consp body) (not (consp (first body))))
-        `(,(or fun-if fun-else) ,@body)
+      (if function-binding-p        
         `(let ((the-function (symbol-function ',(or fun-if fun-else))))
-          ,@body)))))
+          ,@body)
+        `(,(or fun-if fun-else) ,@body)))))
       
 
 ;;; Martin Atzmueller 2000-01-15
             (concatenate 'string "~&" concat-string *ilisp-message-addon-string* format-string concat-string))))
 
 
-#+:ANSI-CL
+;; MNA: ecl (ecls-0.5) still had special-form-p in COMMON-LISP,
+;; which produced an error, when redefined.
+#+(and :ANSI-CL (not :ecl))
 (defun special-form-p (symbol)
   "Backward compatibility for non ANSI CL's."
   (special-operator-p symbol))
 	 #+cmu
 	 (ext:*gc-verbose* nil) ; cmulisp outputs "[GC ...]" which
 				; doesn't read well...
-	 #+ecl
-	 (sys:*gc-verbose* nil) ; ecolisp also outputs "[GC ...]"
 	 )
      (princ " ")			; Make sure we have output
 
-     ;; 19990912 Martin Atzmuller
+     ;; 19990912 Martin Atzmueller
      ;; Gross CLisp HS hack so that the command-index stays the same
      ;; after an ILISP-command that has to use the inferior lisp
      ;;
 	   #+allegro
 	   (excl::arglist symbol)
 
-	   #+(or ibcl kcl ecl gcl)
+	   #+(or ibcl kcl gcl)
 	   (help symbol)
 
+           #+:ecl
+            (si::help symbol)
+            
 	   #+lucid
 	   (lucid::arglist symbol)
 	   
 	   
 	   #+:sbcl
 	   (arglist symbol (symbol-package symbol))
+
+	   #+:openmcl
+	   (arglist symbol (symbol-package symbol))
 	   
-	   #-(or allegro lucid kcl ibcl ecl gcl lispworks clisp cmu :sbcl)
+	   #-(or allegro lucid kcl ibcl ecl gcl lispworks clisp cmu :sbcl :openmcl)
 	   (documentation symbol 'function)))))
 
 
 ;;; $Id$
 
 
-(in-package "ILISP")
+(in-package :ilisp)
 
 ;;;% CMU CL does not define defun as a macro
 (defun ilisp-compile (form package filename)
 			(member-if
 			 #'(lambda (restart)
 			     (string=
-			      (funcall
-			       (conditions::restart-report-function restart)
-			       nil)
+                              (with-output-to-string (s)
+			        (funcall
+			         (conditions::restart-report-function restart)
+			         s))
 			      "Return to " :end1 10))
 			 restart-list)))
 		   (cond ((zerop num) (car first))
 	    (values (symbol-function sym) :function)
 	    (values nil nil)))))
 
-(export '(arglist source-file cmulisp-trace))
-
 ;;;%% arglist - return arglist of function
 ;;;
 ;;; This function is patterned after DESCRIBE-FUNCTION in the
 		 #.vm:closure-function-header-type)
 		(massage-arglist
                  (the-function-if-defined
-                  (#:%function-arglist :lisp #:%function-header-arglist :lisp)
+                  ((#:%function-arglist :lisp) (#:%function-header-arglist :lisp))
                   func)))
 	       (#.vm:funcallable-instance-header-type
 		(typecase func
        ;; In this case we fall back on the TAGS machinery.
        ;; (At least as I underestand the code).
        ;; Marco Antoniotti 11/22/94.
-       (cond ((or (the-function-if-defined (#:generic-function-p :pcl) fun)
-                  (the-function-if-defined (#:get-type :lisp)
+       (cond ((or (the-function-if-defined ((#:generic-function-p :pcl) ())
+                                           fun)
+                  (the-function-if-defined ((#:get-type :lisp) ()
+                                            :function-binding-p t)
                                            (= (funcall the-function fun)
                                               #.vm:funcallable-instance-header-type)))
                (dolist (method (pcl::generic-function-methods fun))
                  (print-simple-source-info
-                  (the-function-if-defined
-                   (#:method-fast-function :pcl #:method-function :pcl)
-                   method)))
+                  (the-function-if-defined ((#:method-fast-function :pcl)
+                                            (#:method-function :pcl))
+                                           method)))
                t)
              (t (print-simple-source-info fun)))))))
 
 function was defined in.  If it was not defined in some file, nil is
 returned."
   (flet ((frob (code)
-	       (let ((info (the-function-if-defined
-                            (#:%code-debug-info :kernel #:code-debug-info :kernel)
-                            code)))
+	       (let ((info (the-function-if-defined ((#:%code-debug-info
+                                                      :kernel)
+                                                     (#:code-debug-info
+                                                      :kernel))
+                                                    code)))
 		 (when info
 		       (let ((sources (c::debug-info-source info)))
 			 (when sources
 				       (c::debug-source-name source)))))))))
 	(typecase function
 		  (symbol (fun-defined-from-pathname (fdefinition function)))
-                  (#.(the-symbol-if-defined (#:byte-closure :kernel))
-                   (fun-defined-from-pathname
-                    (kernel:byte-closure-function function)))		  
-		  (#.(the-symbol-if-defined (#:byte-function :kernel))
-		   (frob (c::byte-function-component function)))
+                  (#.(the-symbol-if-defined ((#:byte-closure :kernel) ()))
+                    (fun-defined-from-pathname
+                     (kernel:byte-closure-function function)))
+		  (#.(the-symbol-if-defined ((#:byte-function :kernel) ()))
+                    (frob (c::byte-function-component function)))
 		  (function
 		   (frob (kernel:function-code-header
 			  (kernel:%function-self function))))
 ;;; incorporate DEFPACKAGE in their standard builds.
 ;;; Marco Antoniotti <marcoxa@icsi.berkeley.edu> 19960715
 ;;;
+;;; "The use of keyword and uninterned symbol names in the package
+;;; definition is a result of internecine wars during the ANSI
+;;; definition process. The solution to make CL case insensitive and
+;;; have the reader use uppercase appears, with the power of
+;;; hindsight, short-sighted. However, the backwardly incompatible
+;;; solution provided by Franz Inc seems a sub-optimal fix."
+;;; 27 March 2002 Will Deakin
 
 #-(and nil gcl)
-(defpackage "ILISP" (:use "COMMON-LISP" #+:CMU "CONDITIONS")
+(defpackage :ilisp (:use :common-lisp #+:CMU :conditions)
   ;; The following symbols should properly 'shadow' the inherited
   ;; ones.
-  (:export "ILISP-ERRORS"
-	   "ILISP-SAVE"
-	   "ILISP-RESTORE"
-	   "ILISP-SYMBOL-NAME"
-	   "ILISP-FIND-SYMBOL"
-	   "ILISP-FIND-PACKAGE"
-	   "ILISP-EVAL"
-	   "ILISP-COMPILE"
-	   "ILISP-DESCRIBE"
-	   "ILISP-INSPECT"
-	   "ILISP-ARGLIST"
-	   "ILISP-DOCUMENTATION"
-	   "ILISP-MACROEXPAND"
-	   "ILISP-MACROEXPAND-1"
-	   "ILISP-TRACE"
-	   "ILISP-UNTRACE"
-	   "ILISP-COMPILE-FILE-EXTENSION"
-	   "ILISP-COMPILE-FILE"
-	   "ILISP-CASIFY"
-	   "ILISP-MATCHING-SYMBOLS"
-	   "ILISP-CALLERS"
-	   "ILISP-SOURCE-FILES"
-	   "ILISP-PRINT-INFO-MESSAGE"
+  (:export #:ilisp-errors
+           #:ilisp-save
+           #:ilisp-restore
+           #:ilisp-symbol-name
+           #:ilisp-find-symbol
+           #:ilisp-find-package
+           #:ilisp-eval
+           #:ilisp-compile
+           #:ilisp-describe
+           #:ilisp-inspect
+           #:ilisp-arglist
+           #:ilisp-documentation
+           #:ilisp-macroexpand
+           #:ilisp-macroexpand-1
+           #:ilisp-trace
+           #:ilisp-untrace
+           #:ilisp-compile-file-extension
+           #:ilisp-compile-file
+           #:ilisp-casify
+           #:ilisp-matching-symbols
+           #:ilisp-callers
+           #:ilisp-source-files
+           #:ilisp-print-info-message
+           #+:SBCL #:sbcl-trace
+           #+:CMU #:cmulisp-trace
+           #+(or :SBCL :CMU) #:source-file
 	   )
   )
 ;;; ILISP --
 
 (in-package "ILISP")
 
+;; Make LispWorks interactive
+#+Unix
+(setf system::*force-top-level* t)
+
+
 ;;; ilisp-eval --
 ;;;
 ;;; Notes:
 	    )
 	(when (and function-name (fboundp function-name))
 	  (setf callers (munge-who-calls
-			 #+:lispworks4.1 (hcl:who-calls function-name)
-			 #-:lispworks4.1 (lw:who-calls function-name)
+			 #+(or :lispworks3 :lispworks4) (hcl:who-calls function-name)
+			 #-(or :lispworks3 :lispworks4) (lw:who-calls function-name)
 			 ))
 	  (dolist (caller callers)
 	    (print caller))
 ;;; I decided to leave these in, although they are a little too system
 ;;; dependent.  I will remove them if people complain.
 
-(unless (fboundp 'sys::define-top-loop-handler)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (unless (fboundp 'sys::define-top-loop-handler)
 
-  ;; Duplicated from ccl/top-loop.lisp
-  (defmacro sys::get-top-loop-handler (command-name)
-    `(get ,command-name 'sys::top-loop-handler))
+    ;; Duplicated from ccl/top-loop.lisp
+    (defmacro sys::get-top-loop-handler (command-name)
+      `(get ,command-name 'sys::top-loop-handler))
 
-  (defmacro sys::define-top-loop-handler (name &body body)
-    (lw:with-unique-names (top-loop-handler)
-      `(let ((,top-loop-handler #'(lambda (sys::line) ,@body)))
-        (mapc #'(lambda (name)
-                  (setf (sys::get-top-loop-handler name) ,top-loop-handler))
-         (if (consp ',name) ',name  '(,name))))))
-
-  )
+    (defmacro sys::define-top-loop-handler (name &body body)
+      (lw:with-unique-names (top-loop-handler)
+        `(let ((,top-loop-handler #'(lambda (sys::line) ,@body)))
+          (mapc #'(lambda (name)
+                    (setf (sys::get-top-loop-handler name) ,top-loop-handler))
+           (if (consp ',name) ',name  '(,name))))))))
 
 (sys::define-top-loop-handler :ilisp-send
   (values (multiple-value-list (eval (cadr sys::line))) nil))
 ;;;
 ;;; $Id$
 
-(in-package "ILISP")
+(in-package :ilisp)
 
 ;;;
 (defun ilisp-callers (symbol package &aux (list-of-callers nil))
 
 ;;; sbcl.lisp --
 ;;;
-;;; This init file was last tested with SBCL 0.6.12.21
+;;; This init file was last tested with SBCL 0.6.13 and
+;;; SBCL 0.7pre.71
 
 ;;; This file is part of ILISP.
 ;;; Please refer to the file COPYING for copyrights and licensing
 ;;; $Id$
 
 
-(in-package "ILISP")
+(in-package :ilisp)
+
+;; ILISP-specifics for SBCL. Since version 0.7 introduced lots of changes,
+;; e.g.(bytecode-)interpreter goes away, and lots of other 'renaming'-changes,
+;; take care of that, by testing via the 'magic'-macros:
+;; THE-SYMBOL-IF-DEFINED, and THE-FUNCTION-IF-DEFINED.
+;;
+;; MNA: 2001-10-20
+;; Some annotations:
+;; <1> - interpreter related changes (interpreter missing in sbcl-0.7.x)
+;; <2> - byte-compiler related changes (sbcl-0.7.x)
+;; <3> - renamings in sbcl-0.7.x., where in general this is accounted for
+;;       using THE-SYMBOL-IF-DEFINED and THE-FUNCTION-IF-DEFINED macros.
+;;       In general, the "new" symbol comes before the "old" symbol.
 
 ;;;% CMU CL does not define defun as a macro
 (defun ilisp-compile (form package filename)
   (let ((fun (or (macro-function sym)
 		 (and (fboundp sym) (symbol-function sym)))))
     (cond (fun
-	   (when (and (= (sb-impl::get-type fun) #.sb-vm:closure-header-type)
-		      (not (sb-eval:interpreted-function-p fun)))
-	     (setq fun (sb-impl::%closure-function fun)))
-	   fun)
+            (if (and (= (the-function-if-defined ((#:widetag-of :sb-impl)
+                                                  (#:get-type :sb-impl)) fun)
+                        ;; <3>
+                        #.(the-symbol-if-defined
+                           ((#:closure-header-widetag :sb-vm)
+                            (#:closure-header-type :sb-vm) :eval-p t)))
+                     (not (the-function-if-defined
+                           ((#:interpreted-function-p :sb-eval) ()) fun)))
+              ;; <3>
+              (the-function-if-defined ((#:%closure-fun :sb-impl)
+                                        (#:closure-function :sb-impl))
+                                       fun)
+              ;; else just return the old function-object
+              fun))
 	  (t
-	   (error "Unknown function ~a.  Check package." sym)
-	   nil))))
-
-(export '(arglist source-file sbcl-trace))
+            (error "Unknown function ~a.  Check package." sym)
+            nil))))
 
 ;;; 2000-04-02: Martin Atzmueller
 ;;; better (more bulletproof) arglist code adapted from cmulisp.lisp:
 (defun arglist (symbol package)
   (ilisp-errors
    (let* ((package-name (if (packagep package)
-			    (package-name package)
-			    package))
+                          (package-name package)
+                          package))
 	  (x (ilisp-find-symbol symbol package-name)))
      (flet ((massage-arglist (args)
 	      (typecase args
 		(string (if (or (null args) (string= args "()"))
-			    ""
-			    args))
-		(list (format nil "~S" args))
+                          ""
+                          args))
+		(list (if args
+                        (let ((*print-pretty* t)
+                              (*print-escape* t)
+                              (*print-base* 10)
+                              (*print-radix* nil))
+                          (format nil "~A" args))
+                        "()"))
 		(t ""))))
 
        (multiple-value-bind (func kind)
 	   (extract-function-info-from-name x)
-	 ;; (print func *trace-output*)
-	 ;; (print kind *trace-output*)
 	 (if (and func kind)
-	     (case (sb-impl::get-type func)
-	       ((#.sb-vm:closure-header-type
-		 #.sb-vm:function-header-type
-		 #.sb-vm:closure-function-header-type)
-		(massage-arglist
-		 (funcall #'sb-impl::%function-arglist
-			  func)))
-
-	       (#.sb-vm:funcallable-instance-header-type
-		(typecase func
-		  (sb-kernel:byte-function
-		   "Byte compiled function or macro, no arglist available.")
-		  (sb-kernel:byte-closure
-		   "Byte compiled closure, no arglist available.")
-		  ((or generic-function sb-pcl::generic-function)
-		   (sb-pcl::generic-function-pretty-arglist func))
-		  (sb-eval:interpreted-function
-		   (massage-arglist
-		    (sb-eval::interpreted-function-arglist func)))
-		
-		  (t (print 99 *trace-output*) "No arglist available.")
-		  ))			; typecase
-	       (t "No arglist available.")) ; case
-	     "Unknown function - no arglist available." ; For the time
+           (case (the-function-if-defined ((#:widetag-of :sb-impl)
+                                           (#:get-type :sb-impl)) func)
+             ;; <3>
+             ((#.(the-symbol-if-defined ((#:closure-header-widetag :sb-vm)
+                                         (#:closure-header-type :sb-vm)
+                                         :eval-p t))
+                 #.(the-symbol-if-defined ((#:simple-fun-header-widetag :sb-vm)
+                                           (#:function-header-type :sb-vm)
+                                           :eval-p t))
+		 #.(the-symbol-if-defined ((#:closure-fun-header-widetag
+                                            :sb-vm)
+                                           (#:closure-function-header-type
+                                            :sb-vm)
+                                           :eval-p t)))
+               (massage-arglist
+                (the-function-if-defined ((#:%simple-fun-arglist :sb-impl)
+                                          (#:%function-arglist :sb-impl))
+                                         func)))
+             (#.(the-symbol-if-defined
+                 ((#:funcallable-instance-header-widetag :sb-vm)
+                  (#:funcallable-instance-header-type :sb-vm)
+                  :eval-p t))
+               (typecase func
+                 ;; <2>
+                 (#.(the-symbol-if-defined ((#:byte-function :sb-kernel) ()))
+                   "Byte compiled function or macro, no arglist available.")
+                 (#.(the-symbol-if-defined ((#:byte-closure :sb-kernel) ()))
+                   "Byte compiled closure, no arglist available.")
+                 ((or generic-function sb-pcl::generic-function)
+                   (sb-pcl::generic-function-pretty-arglist func))
+                 ;; <1>
+                 (#.(the-symbol-if-defined ((#:interpreted-function :sb-eval) ()))
+                   (the-function-if-defined
+                    ((#:interpreted-function-arglist :sb-eval) ()
+                     :function-binding-p t)
+                    (massage-arglist (funcall the-function func))))
+                 (t (print 99 *trace-output*) "No arglist available.")
+                 ))			; typecase
+             (t "No arglist available.")) ; case
+           "Unknown function - no arglist available." ; For the time
 					; being I just
 					; return this
 					; value. Maybe
 					; an error would
 					; be better.
-	     ))))))
+           ))))))
 
 ;;; source-file symbol package type --
 ;;; New version provided by Richard Harris <rharris@chestnut.com> with
   (ilisp-errors
    (let* ((x (ilisp-find-symbol symbol package))
 	  (fun (get-correct-fn-object x)))
-     (when (and fun (not (sb-eval:interpreted-function-p fun)))
+     (when (and fun
+                ;; <1>
+                (not (the-function-if-defined
+                      ((#:interpreted-function-p :sb-eval) ()) fun)))
 	   ;; The hack above is necessary because CMUCL does not
 	   ;; correctly record source file information when 'loading'
 	   ;; a non compiled file.
 		       (sb-c::debug-source-name source)))))))))
     (typecase function
       (symbol (fun-defined-from-pathname (fdefinition function)))
-      (sb-kernel:byte-closure
-       (fun-defined-from-pathname
-	(sb-kernel:byte-closure-function function)))
-      (sb-kernel:byte-function
-       (frob (sb-c::byte-function-component function)))
+      ;; <2>
+      (#.(the-symbol-if-defined ((#:byte-function :sb-kernel) ()))
+        "Byte compiled function or macro, no arglist available.")
+      (#.(the-symbol-if-defined ((#:byte-closure :sb-kernel) ()))
+        "Byte compiled closure, no arglist available.")
+      (#.(the-symbol-if-defined ((#:byte-closure :sb-kernel) ()))
+        (fun-defined-from-pathname
+         (the-function-if-defined ((#:byte-closure-function :sb-kernel) ()
+                                   :function-binding-p t)
+                                  (funcall the-function function))))
+      (#.(the-symbol-if-defined ((#:byte-function :sb-kernel) ()))
+        (the-function-if-defined ((#:byte-function-component :sb-c) ()
+                                  :function-binding-p t)
+                                 (frob (funcall the-function function))))
       (function
-       (frob (sb-kernel:function-code-header
-	      (sb-kernel:%function-self function))))
+        ;; <3>
+        (frob (the-function-if-defined ((#:fun-code-header :sb-kernel)
+                                        (#:function-code-header :sb-kernel))
+                                       (the-function-if-defined
+                                        ((#:%simple-fun-self :sb-kernel)
+                                         (#:%function-self :sb-kernel))
+                                        function))))
       (t nil))))