cgit.sxemacs.org Git - packages/blob - xemacs-packages/ilisp/sbcl.lisp

   1 ;;; -*- Mode: Lisp -*-
   2
   3 ;;; sbcl.lisp --
   4 ;;;
   5 ;;; This init file was last tested with SBCL 0.6.13 and
   6 ;;; SBCL 0.7pre.71
   7
   8 ;;; This file is part of ILISP.
   9 ;;; Please refer to the file COPYING for copyrights and licensing
  10 ;;; information.
  11 ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
  12 ;;; of present and past contributors.
  13 ;;;
  14 ;;; $Id: sbcl.lisp,v 1.2 2002-05-30 13:59:21 wbd Exp $
  15
  16
  17 (in-package :ilisp)
  18
  19 ;; ILISP-specifics for SBCL. Since version 0.7 introduced lots of changes,
  20 ;; e.g.(bytecode-)interpreter goes away, and lots of other 'renaming'-changes,
  21 ;; take care of that, by testing via the 'magic'-macros:
  22 ;; THE-SYMBOL-IF-DEFINED, and THE-FUNCTION-IF-DEFINED.
  23 ;;
  24 ;; MNA: 2001-10-20
  25 ;; Some annotations:
  26 ;; <1> - interpreter related changes (interpreter missing in sbcl-0.7.x)
  27 ;; <2> - byte-compiler related changes (sbcl-0.7.x)
  28 ;; <3> - renamings in sbcl-0.7.x., where in general this is accounted for
  29 ;;       using THE-SYMBOL-IF-DEFINED and THE-FUNCTION-IF-DEFINED macros.
  30 ;;       In general, the "new" symbol comes before the "old" symbol.
  31
  32 ;;;% CMU CL does not define defun as a macro
  33 (defun ilisp-compile (form package filename)
  34   "Compile FORM in PACKAGE recording FILENAME as the source file."
  35   (ilisp-errors
  36    (ilisp-eval
  37     (format nil "(funcall (compile nil '(lambda () ~A)))" form)
  38     package filename)))
  39
  40 ;;;% Stream settings, when running connected to pipes.
  41 ;;;
  42 ;;; When SBCL is running as a piped process, it still manages to open
  43 ;;; /dev/tty to use it for the *terminal-io* stream.  This means that an
  44 ;;; error will cause lisp to stop and wait for input from /dev/tty, which is
  45 ;;; probably not available and certainly not what you were expecting.
  46 ;;;
  47 ;;; We want it to use the same input that the user is typing at, ie,
  48 ;;; the pipe (stdin).
  49
  50 (defvar *Fix-pipe-streams* T
  51   "Set to Nil if you want them left alone.  And tell me you don't get stuck.")
  52
  53 (when (and *Fix-pipe-streams*
  54            (sb-impl::synonym-stream-p *terminal-io*)
  55            (eq (sb-impl::synonym-stream-symbol *terminal-io*)
  56                'sb-impl::*tty*))
  57   (setf *terminal-io* (make-two-way-stream sb-impl::*stdin* sb-impl::*stdout*))
  58   ;; *query-io* and *debug-io* are synonym streams to this, so this fixes
  59   ;; everything.
  60   )
  61
  62 ;;; Normally, errors which occur while in the debugger are just ignored, unless
  63 ;;; the user issues the "flush" command, which toggles this behavior.
  64
  65 (setq sb-debug:*flush-debug-errors* nil)  ; allow multiple error levels.
  66
  67
  68 ;;;%% arglist/source-file utils.
  69
  70 (defun get-correct-fn-object (sym)
  71   "Deduce how to get the \"right\" function object and return it."
  72   (let ((fun (or (macro-function sym)
  73                  (and (fboundp sym) (symbol-function sym)))))
  74     (cond (fun
  75             (if (and (= (the-function-if-defined ((#:widetag-of :sb-impl)
  76                                                   (#:get-type :sb-impl)) fun)
  77                         ;; <3>
  78                         #.(the-symbol-if-defined
  79                            ((#:closure-header-widetag :sb-vm)
  80                             (#:closure-header-type :sb-vm) :eval-p t)))
  81                      (not (the-function-if-defined
  82                            ((#:interpreted-function-p :sb-eval) ()) fun)))
  83               ;; <3>
  84               (the-function-if-defined ((#:%closure-fun :sb-impl)
  85                                         (#:closure-function :sb-impl))
  86                                        fun)
  87               ;; else just return the old function-object
  88               fun))
  89           (t
  90             (error "Unknown function ~a.  Check package." sym)
  91             nil))))
  92
  93 ;;; 2000-04-02: Martin Atzmueller
  94 ;;; better (more bulletproof) arglist code adapted from cmulisp.lisp:
  95
  96 (defun extract-function-info-from-name (sym)
  97   (let ((mf (macro-function sym)))
  98     (if mf
  99         (values mf :macro)
 100         (if (fboundp sym)
 101             (values (symbol-function sym) :function)
 102             (values nil nil)))))
 103
 104 (defun arglist (symbol package)
 105   (ilisp-errors
 106    (let* ((package-name (if (packagep package)
 107                           (package-name package)
 108                           package))
 109           (x (ilisp-find-symbol symbol package-name)))
 110      (flet ((massage-arglist (args)
 111               (typecase args
 112                 (string (if (or (null args) (string= args "()"))
 113                           ""
 114                           args))
 115                 (list (if args
 116                         (let ((*print-pretty* t)
 117                               (*print-escape* t)
 118                               (*print-base* 10)
 119                               (*print-radix* nil))
 120                           (format nil "~A" args))
 121                         "()"))
 122                 (t ""))))
 123
 124        (multiple-value-bind (func kind)
 125            (extract-function-info-from-name x)
 126          (if (and func kind)
 127            (case (the-function-if-defined ((#:widetag-of :sb-impl)
 128                                            (#:get-type :sb-impl)) func)
 129              ;; <3>
 130              ((#.(the-symbol-if-defined ((#:closure-header-widetag :sb-vm)
 131                                          (#:closure-header-type :sb-vm)
 132                                          :eval-p t))
 133                  #.(the-symbol-if-defined ((#:simple-fun-header-widetag :sb-vm)
 134                                            (#:function-header-type :sb-vm)
 135                                            :eval-p t))
 136                  #.(the-symbol-if-defined ((#:closure-fun-header-widetag
 137                                             :sb-vm)
 138                                            (#:closure-function-header-type
 139                                             :sb-vm)
 140                                            :eval-p t)))
 141                (massage-arglist
 142                 (the-function-if-defined ((#:%simple-fun-arglist :sb-impl)
 143                                           (#:%function-arglist :sb-impl))
 144                                          func)))
 145              (#.(the-symbol-if-defined
 146                  ((#:funcallable-instance-header-widetag :sb-vm)
 147                   (#:funcallable-instance-header-type :sb-vm)
 148                   :eval-p t))
 149                (typecase func
 150                  ;; <2>
 151                  (#.(the-symbol-if-defined ((#:byte-function :sb-kernel) ()))
 152                    "Byte compiled function or macro, no arglist available.")
 153                  (#.(the-symbol-if-defined ((#:byte-closure :sb-kernel) ()))
 154                    "Byte compiled closure, no arglist available.")
 155                  ((or generic-function sb-pcl::generic-function)
 156                    (sb-pcl::generic-function-pretty-arglist func))
 157                  ;; <1>
 158                  (#.(the-symbol-if-defined ((#:interpreted-function :sb-eval) ()))
 159                    (the-function-if-defined
 160                     ((#:interpreted-function-arglist :sb-eval) ()
 161                      :function-binding-p t)
 162                     (massage-arglist (funcall the-function func))))
 163                  (t (print 99 *trace-output*) "No arglist available.")
 164                  ))                     ; typecase
 165              (t "No arglist available.")) ; case
 166            "Unknown function - no arglist available." ; For the time
 167                                         ; being I just
 168                                         ; return this
 169                                         ; value. Maybe
 170                                         ; an error would
 171                                         ; be better.
 172            ))))))
 173
 174 ;;; source-file symbol package type --
 175 ;;; New version provided by Richard Harris <rharris@chestnut.com> with
 176 ;;; suggestions by Larry Hunter <hunter@work.nlm.nih.gov>.
 177
 178 (defun source-file (symbol package type)
 179   (declare (ignore type))
 180   (ilisp-errors
 181    (let* ((x (ilisp-find-symbol symbol package))
 182           (fun (get-correct-fn-object x)))
 183      (when (and fun
 184                 ;; <1>
 185                 (not (the-function-if-defined
 186                       ((#:interpreted-function-p :sb-eval) ()) fun)))
 187            ;; The hack above is necessary because CMUCL does not
 188            ;; correctly record source file information when 'loading'
 189            ;; a non compiled file.
 190            ;; In this case we fall back on the TAGS machinery.
 191            ;; (At least as I underestand the code).
 192            ;; Marco Antoniotti 11/22/94.
 193            (cond ((sb-pcl::generic-function-p fun)
 194                   (dolist (method (sb-pcl::generic-function-methods fun))
 195                     (print-simple-source-info
 196                      (or (sb-pcl::method-fast-function method)
 197                          (sb-pcl::method-function method))))
 198                   t)
 199                  (t (print-simple-source-info fun)))))))
 200
 201 ;;; Patch suggested by Richard Harris <rharris@chestnut.com>
 202
 203 ;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object.  It
 204 ;;; returns a pathname for the file the function was defined in.  If it was
 205 ;;; not defined in some file, then nil is returned.
 206 ;;;
 207 ;;; FUN-DEFINED-FROM-PATHNAME is from hemlock/rompsite.lisp (cmucl17f),
 208 ;;; with added read-time conditionalization to work in older versions
 209 ;;; of cmucl.  It may need a little bit more conditionalization for
 210 ;;; some older versions of cmucl.
 211
 212 (defun fun-defined-from-pathname (function)
 213   "Returns the file where FUNCTION is defined in (if the file can be found).
 214 Takes a symbol or function and returns the pathname for the file the
 215 function was defined in.  If it was not defined in some file, nil is
 216 returned."
 217   (flet ((frob (code)
 218            (let ((info (sb-kernel:%code-debug-info code)))
 219              (when info
 220                (let ((sources (sb-c::debug-info-source info)))
 221                  (when sources
 222                    (let ((source (car sources)))
 223                      (when (eq (sb-c::debug-source-from source) :file)
 224                        (sb-c::debug-source-name source)))))))))
 225     (typecase function
 226       (symbol (fun-defined-from-pathname (fdefinition function)))
 227       ;; <2>
 228       (#.(the-symbol-if-defined ((#:byte-function :sb-kernel) ()))
 229         "Byte compiled function or macro, no arglist available.")
 230       (#.(the-symbol-if-defined ((#:byte-closure :sb-kernel) ()))
 231         "Byte compiled closure, no arglist available.")
 232       (#.(the-symbol-if-defined ((#:byte-closure :sb-kernel) ()))
 233         (fun-defined-from-pathname
 234          (the-function-if-defined ((#:byte-closure-function :sb-kernel) ()
 235                                    :function-binding-p t)
 236                                   (funcall the-function function))))
 237       (#.(the-symbol-if-defined ((#:byte-function :sb-kernel) ()))
 238         (the-function-if-defined ((#:byte-function-component :sb-c) ()
 239                                   :function-binding-p t)
 240                                  (frob (funcall the-function function))))
 241       (function
 242         ;; <3>
 243         (frob (the-function-if-defined ((#:fun-code-header :sb-kernel)
 244                                         (#:function-code-header :sb-kernel))
 245                                        (the-function-if-defined
 246                                         ((#:%simple-fun-self :sb-kernel)
 247                                          (#:%function-self :sb-kernel))
 248                                         function))))
 249       (t nil))))
 250
 251
 252 ;;; print-simple-source-info --
 253 ;;; Patches suggested by Larry Hunter <hunter@work.nlm.nih.gov> and
 254 ;;; Richard Harris <rharris@chestnut.com>
 255 ;;; Nov 21, 1994.
 256
 257 (defun print-simple-source-info (fun)
 258   (let ((path (fun-defined-from-pathname fun)))
 259     (when (and path (probe-file path))
 260       (print (namestring (truename path)))
 261       t)))
 262
 263
 264 (defun sbcl-trace (symbol package breakp)
 265   "Trace SYMBOL in PACKAGE."
 266   (ilisp-errors
 267    (let ((real-symbol (ilisp-find-symbol symbol package)))
 268      (setq breakp (read-from-string breakp))
 269      (when real-symbol (eval `(trace ,real-symbol :break ,breakp))))))
 270
 271 ;;; end of file -- sbcl.lisp --
 272