Source

ilisp / sbcl.lisp

Diff from to

File sbcl.lisp

 
 ;;; 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))))