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

   1 ;;; -*- Mode: Lisp -*-
   2
   3 ;;; sblisp.lisp --
   4
   5 ;;; This file is part of ILISP.
   6 ;;; Version: 5.10.1
   7 ;;;
   8 ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
   9 ;;;               1993, 1994 Ivan Vasquez
  10 ;;;               1994, 1995, 1996 Marco Antoniotti and Rick Busdiecker
  11 ;;;               1996, 1997, 1998, 1999 Marco Antoniotti and Rick Campbell
  12 ;;;               2000 Matthias Hölzl
  13 ;;;
  14 ;;; Other authors' names for which this Copyright notice also holds
  15 ;;; may appear later in this file.
  16 ;;;
  17 ;;; Send mail to 'majordomo@cons.org' to be included in the
  18 ;;; ILISP mailing list. 'ilisp@cons.org' is the general ILISP
  19 ;;; mailing list were bugs and improvements are discussed.
  20 ;;;
  21 ;;; ILISP is freely redistributable under the terms found in the file
  22 ;;; COPYING.
  23
  24
  25
  26 ;;;
  27 ;;; Todd Kaufmann    May 1990
  28 ;;;
  29 ;;; Make CMU CL run better within GNU inferior-lisp (by ccm).
  30 ;;;
  31 ;;; This init file is compatible with version of SBCL (version >= 0.6.2!)
  32
  33 (in-package "ILISP")
  34
  35 ;;;% CMU CL does not define defun as a macro
  36 (defun ilisp-compile (form package filename)
  37   "Compile FORM in PACKAGE recording FILENAME as the source file."
  38   (ilisp-errors
  39    (ilisp-eval
  40     (format nil "(funcall (compile nil '(lambda () ~A)))" form)
  41     package filename)))
  42
  43 ;;;% Stream settings, when running connected to pipes.
  44 ;;;
  45 ;;; This fixes a problem when running piped: When CMU is running as a piped
  46 ;;; process, *terminal-io* really is a terminal; ie, /dev/tty.  This means an
  47 ;;; error will cause lisp to stop and wait for input from /dev/tty, which it
  48 ;;; won't be able to grab, and you'll have to restart your lisp.  But we want
  49 ;;; it to use the same input that the user is typing in, ie, the pipe (stdin).
  50 ;;; This fixes that problem, which only occurs in the CMU cores of this year.
  51 ;;;
  52
  53 (defvar *Fix-pipe-streams* T
  54   "Set to Nil if you want them left alone.  And tell me you don't get stuck.")
  55
  56 (when (and *Fix-pipe-streams*
  57            (sb-impl::synonym-stream-p *terminal-io*)
  58            (eq (sb-impl::synonym-stream-symbol *terminal-io*)
  59                'sb-impl::*tty*))
  60   (setf *terminal-io* (make-two-way-stream sb-impl::*stdin* sb-impl::*stdout*))
  61   ;; *query-io* and *debug-io* are synonym streams to this, so this fixes
  62   ;; everything.
  63   )
  64
  65 ;;;% Debugger extensions
  66
  67 ;;;%% Implementation of a :pop command for CMU CL debugger
  68
  69 ;;;
  70 ;;; Normally, errors which occur while in the debugger are just ignored, unless
  71 ;;; the user issues the "flush" command, which toggles this behavior.
  72 ;;;
  73 (setq sb-debug:*flush-debug-errors* nil)  ; allow multiple error levels.
  74
  75 ;;; This implementation of "POP" simply looks for the first restart that says
  76 ;;; "Return to debug level n" or "Return to top level." and executes it.
  77 ;;;
  78 (sb-debug::def-debug-command "POP"  ()
  79   ;; find the first "Return to ..." restart
  80   (if (not (boundp 'sb-debug::*debug-restarts*))
  81       (error "You're not in the debugger; how can you call this!?")
  82       (labels ((find-return-to (restart-list num)
  83                  (let ((first
  84                         (member-if
  85                          #'(lambda (restart)
  86                              (string= (funcall
  87                                        (sb-conditions::restart-report-function
  88                                         restart)
  89                                        nil)
  90                                       "Return to " :end1 10))
  91                          restart-list)))
  92                    (cond ((zerop num) (car first))
  93                          ((cdr first) (find-return-to (cdr first)
  94                                                       (1- num)))))))
  95         (let* ((level (sb-debug::read-if-available 1))
  96                (first-return-to (find-return-to
  97                                  sb-debug::*debug-restarts* (1- level))))
  98           (if (null first-return-to)
  99               (format *debug-io* "pop: ~d is too far" level)
 100               (sb-debug::invoke-restart-interactively first-return-to)
 101               )))))
 102
 103
 104 ;;;%% arglist/source-file utils.
 105
 106 (defun get-correct-fn-object (sym)
 107   "Deduce how to get the \"right\" function object and return it."
 108   (let ((fun (or (macro-function sym)
 109                  (and (fboundp sym) (symbol-function sym)))))
 110     (cond (fun
 111            (when (and (= (sb-impl::get-type fun) #.sb-vm:closure-header-type)
 112                       (not (sb-eval:interpreted-function-p fun)))
 113              (setq fun (sb-impl::%closure-function fun)))
 114            fun)
 115           (t
 116            (error "Unknown function ~a.  Check package." sym)
 117            nil))))
 118
 119
 120
 121 (export '(arglist source-file sblisp-trace))
 122
 123 ;;;%% arglist - return arglist of function - former version
 124
 125 ;;(defun arglist (symbol package)
 126 ;;  (ilisp-errors
 127 ;;   (let* ((x (ilisp-find-symbol symbol (package-name package)))
 128 ;;          (fun (get-correct-fn-object x)))
 129 ;;     (values
 130 ;;      (cond ((sb-eval:interpreted-function-p fun)
 131 ;;             (sb-eval:interpreted-function-arglist fun))
 132 ;;            ((= (sb-impl::get-type fun)
 133 ;;                #.sb-vm:funcallable-instance-header-type)
 134 ;;             ;; generic function / method
 135 ;;             (sb-pcl::generic-function-pretty-arglist fun))
 136 ;;            ((compiled-function-p fun)
 137 ;;             (let ((string-or-nil
 138 ;;                    (sb-impl::%function-arglist fun)))
 139 ;;               (if string-or-nil
 140 ;;                   (read-from-string string-or-nil)
 141 ;;                   "No argument info.")))
 142 ;;            (t (error "Unknown type of function")))))))
 143 ;;
 144
 145 ;;; 2000-04-02: Martin Atzmueller
 146 ;;; better (more bulletproof) arglist code adapted from cmulisp.lisp:
 147
 148 (defun extract-function-info-from-name (sym)
 149   (let ((mf (macro-function sym)))
 150     (if mf
 151         (values mf :macro)
 152         (if (fboundp sym)
 153             (values (symbol-function sym) :function)
 154             (values nil nil)))))
 155
 156 (defun arglist (symbol package)
 157   (ilisp-errors
 158    (let* ((package-name (if (packagep package)
 159                             (package-name package)
 160                             package))
 161           (x (ilisp-find-symbol symbol package-name)))
 162      (flet ((massage-arglist (args)
 163               (typecase args
 164                 (string (if (or (null args) (string= args "()"))
 165                             ""
 166                             args))
 167                 (list (format nil "~S" args))
 168                 (t ""))))
 169
 170        (multiple-value-bind (func kind)
 171            (extract-function-info-from-name x)
 172          ;; (print func *trace-output*)
 173          ;; (print kind *trace-output*)
 174          (if (and func kind)
 175              (case (sb-impl::get-type func)
 176                ((#.sb-vm:closure-header-type
 177                  #.sb-vm:function-header-type
 178                  #.sb-vm:closure-function-header-type)
 179                 (massage-arglist
 180                  (funcall #'sb-impl::%function-arglist
 181                           func)))
 182
 183                (#.sb-vm:funcallable-instance-header-type
 184                 (typecase func
 185                   (sb-kernel:byte-function
 186                    "Byte compiled function or macro, no arglist available.")
 187                   (sb-kernel:byte-closure
 188                    "Byte compiled closure, no arglist available.")
 189                   ((or generic-function sb-pcl::generic-function)
 190                    (sb-pcl::generic-function-pretty-arglist func))
 191                   (sb-eval:interpreted-function
 192                    (massage-arglist
 193                     (sb-eval::interpreted-function-arglist func)))
 194
 195                   (t (print 99 *trace-output*) "No arglist available.")
 196                   ))                    ; typecase
 197                (t "No arglist available.")) ; case
 198              "Unknown function - no arglist available." ; For the time
 199                                         ; being I just
 200                                         ; return this
 201                                         ; value. Maybe
 202                                         ; an error would
 203                                         ; be better.
 204              ))))))
 205
 206 ;;; source-file symbol package type --
 207 ;;; New version provided by Richard Harris <rharris@chestnut.com> with
 208 ;;; suggestions by Larry Hunter <hunter@work.nlm.nih.gov>.
 209
 210 (defun source-file (symbol package type)
 211   (declare (ignore type))
 212   (sb-impl-errors
 213    (let* ((x (ilisp-find-symbol symbol package))
 214           (fun (get-correct-fn-object x)))
 215      (when (and fun (not (sb-eval:interpreted-function-p fun)))
 216            ;; The hack above is necessary because CMUCL does not
 217            ;; correctly record source file information when 'loading'
 218            ;; a non compiled file.
 219            ;; In this case we fall back on the TAGS machinery.
 220            ;; (At least as I underestand the code).
 221            ;; Marco Antoniotti 11/22/94.
 222            (cond ((sb-pcl::generic-function-p fun)
 223                   (dolist (method (sb-pcl::generic-function-methods fun))
 224                     (print-simple-source-info
 225                      (or (sb-pcl::method-fast-function method)
 226                          (sb-pcl::method-function method))))
 227                   t)
 228                  (t (print-simple-source-info fun)))))))
 229
 230 ;;; Old version. Left here for the time being.
 231 ;(defun source-file (symbol package type)
 232 ;  (declare (ignore type))
 233 ;  (ilisp-errors
 234 ;   (let* ((x (ilisp-find-symbol symbol package))
 235 ;         (fun (get-correct-fn-object x)))
 236 ;     (when fun
 237 ;       (cond ((= (sb-impl::get-type fun)
 238 ;                #.sb-vm:funcallable-instance-header-type)
 239 ;             ;; A PCL method! Uh boy!
 240 ;             (dolist (method (sb-pcl::generic-function-methods fun))
 241 ;               (print-simple-source-info
 242 ;                (sb-impl::%closure-function (sb-pcl::method-function method))))
 243 ;             t)
 244 ;            (t (print-simple-source-info fun)))))))
 245
 246
 247 ;;; Patch suggested by Richard Harris <rharris@chestnut.com>
 248
 249 ;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object.  It
 250 ;;; returns a pathname for the file the function was defined in.  If it was
 251 ;;; not defined in some file, then nil is returned.
 252 ;;;
 253 ;;; FUN-DEFINED-FROM-PATHNAME is from hemlock/rompsite.lisp (cmucl17f),
 254 ;;; with added read-time conditionalization to work in older versions
 255 ;;; of cmucl.  It may need a little bit more conditionalization for
 256 ;;; some older versions of cmucl.
 257
 258 (defun fun-defined-from-pathname (function)
 259   "Returns the file where FUNCTION is defined in (if the file can be found).
 260 Takes a symbol or function and returns the pathname for the file the
 261 function was defined in.  If it was not defined in some file, nil is
 262 returned."
 263   (flet ((frob (code)
 264            (let ((info (sb-kernel:%code-debug-info code)))
 265              (when info
 266                (let ((sources (sb-c::debug-info-source info)))
 267                  (when sources
 268                    (let ((source (car sources)))
 269                      (when (eq (sb-c::debug-source-from source) :file)
 270                        (sb-c::debug-source-name source)))))))))
 271     (typecase function
 272       (symbol (fun-defined-from-pathname (fdefinition function)))
 273       (sb-kernel:byte-closure
 274        (fun-defined-from-pathname
 275         (sb-kernel:byte-closure-function function)))
 276       (sb-kernel:byte-function
 277        (frob (sb-c::byte-function-component function)))
 278       (function
 279        (frob (sb-kernel:function-code-header
 280               (sb-kernel:%function-self function))))
 281       (t nil))))
 282
 283
 284 ;;; print-simple-source-info --
 285 ;;; Patches suggested by Larry Hunter <hunter@work.nlm.nih.gov> and
 286 ;;; Richard Harris <rharris@chestnut.com>
 287 ;;; Nov 21, 1994.
 288
 289 (defun print-simple-source-info (fun)
 290   (let ((path (fun-defined-from-pathname fun)))
 291     (when (and path (probe-file path))
 292       (print (namestring (truename path)))
 293       t)))
 294
 295
 296 ;;; Old version (semi patched). Left here for the time being.
 297 ;(defun print-simple-source-info (fun)
 298 ;  (let ((info (sb-kernel:%code-debug-info
 299 ;              (sb-kernel:function-code-header fun))))
 300 ;    (when info
 301 ;         (let ((sources (sb-c::compiled-debug-info-source info)))
 302 ;           (when sources
 303 ;                 (dolist (source sources)
 304 ;                         (let ((name (sb-c::debug-source-name source)))
 305 ;                           (when (eq (sb-c::debug-source-from source) :file)
 306 ;                                 ;; Patch suggested by
 307 ;                                 ;; hunter@work.nlm.nih.gov (Larry
 308 ;                                 ;; Hunter)
 309 ;                                 ;; (print (namestring name)) ; old
 310 ;                                 (print (truename name))
 311 ;                                 )))
 312 ;                 t)))))
 313
 314
 315 (defun sblisp-trace (symbol package breakp)
 316   "Trace SYMBOL in PACKAGE."
 317   (ilisp-errors
 318    (let ((real-symbol (ilisp-find-symbol symbol package)))
 319      (setq breakp (read-from-string breakp))
 320      (when real-symbol (eval `(trace ,real-symbol :break ,breakp))))))
 321
 322 ;;; end of file -- sblisp.lisp --
 323