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

   1 ;;; -*- Mode: Lisp -*-
   2
   3 ;;; cmulisp.lisp --
   4 ;;; ILISP CMU Common Lisp dialect support definitions.
   5 ;;; Author: Todd Kaufmann    May 1990
   6 ;;;
   7 ;;; This file is part of ILISP.
   8 ;;; Please refer to the file COPYING for copyrights and licensing
   9 ;;; information.
  10 ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
  11 ;;; of present and past contributors.
  12 ;;;
  13 ;;; $Id: cmulisp.lisp,v 1.4 2002-05-30 13:59:20 wbd Exp $
  14
  15
  16 (in-package :ilisp)
  17
  18 ;;;% CMU CL does not define defun as a macro
  19 (defun ilisp-compile (form package filename)
  20   "Compile FORM in PACKAGE recording FILENAME as the source file."
  21   (ilisp-errors
  22    (ilisp-eval
  23     (format nil "(funcall (compile nil '(lambda () ~A)))" form)
  24     package filename)))
  25
  26 ;;;% Stream settings, when running connected to pipes.
  27 ;;;
  28 ;;; This fixes a problem when running piped: When CMU is running as a piped
  29 ;;; process, *terminal-io* really is a terminal; ie, /dev/tty.  This means an
  30 ;;; error will cause lisp to stop and wait for input from /dev/tty, which it
  31 ;;; won't be able to grab, and you'll have to restart your lisp.  But we want
  32 ;;; it to use the same input that the user is typing in, ie, the pipe (stdin).
  33 ;;; This fixes that problem, which only occurs in the CMU cores of this year.
  34 ;;;
  35
  36 (defvar *Fix-pipe-streams* T
  37   "Set to Nil if you want them left alone.  And tell me you don't get stuck.")
  38
  39 (when (and *Fix-pipe-streams*
  40            (lisp::synonym-stream-p *terminal-io*)
  41            (eq (lisp::synonym-stream-symbol *terminal-io*)
  42                'SYSTEM::*TTY*))
  43   (setf *terminal-io* (make-two-way-stream system::*stdin* system::*stdout*))
  44   ;; *query-io* and *debug-io* are synonym streams to this, so this fixes
  45   ;; everything.
  46   )
  47
  48 ;;;% Debugger extensions
  49
  50 ;;;%% Implementation of a :pop command for CMU CL debugger
  51
  52 ;;;
  53 ;;; Normally, errors which occur while in the debugger are just ignored, unless
  54 ;;; the user issues the "flush" command, which toggles this behavior.
  55 ;;;
  56 (setq debug:*flush-debug-errors* nil)  ; allow multiple error levels.
  57
  58 ;;; This implementation of "POP" simply looks for the first restart that says
  59 ;;; "Return to debug level n" or "Return to top level." and executes it.
  60 ;;;
  61 (debug::def-debug-command "POP" #+:new-compiler ()
  62   ;; find the first "Return to ..." restart
  63   (if (not (boundp 'debug::*debug-restarts*))
  64       (error "You're not in the debugger; how can you call this!?")
  65       (labels ((find-return-to (restart-list num)
  66                  (let ((first
  67                         (member-if
  68                          #'(lambda (restart)
  69                              (string=
  70                               (with-output-to-string (s)
  71                                 (funcall
  72                                  (conditions::restart-report-function restart)
  73                                  s))
  74                               "Return to " :end1 10))
  75                          restart-list)))
  76                    (cond ((zerop num) (car first))
  77                          ((cdr first)
  78                           (find-return-to (cdr first) (1- num)))))))
  79         (let* ((level (debug::read-if-available 1))
  80                (first-return-to (find-return-to
  81                                  debug::*debug-restarts* (1- level))))
  82           (if (null first-return-to)
  83               (format *debug-io* "pop: ~d is too far" level)
  84               (debug::invoke-restart-interactively first-return-to)
  85               ))))
  86     )
  87
  88
  89 ;;;%% arglist/source-file utils.
  90
  91 (defun get-correct-fn-object (sym)
  92   "Deduce how to get the \"right\" function object and return it."
  93   (let ((fun (or (macro-function sym)
  94                  (and (fboundp sym) (symbol-function sym)))))
  95     (unless fun
  96       (error "Unknown function ~a.  Check package." sym))
  97
  98     (if (and (= (lisp::get-type fun) #.vm:closure-header-type)
  99              (not (eval:interpreted-function-p fun)))
 100         (lisp::%closure-function fun)
 101         fun)))
 102
 103 (defun extract-function-info-from-name (sym)
 104   (let ((mf (macro-function sym)))
 105     (if mf
 106         (values mf :macro)
 107         (if (fboundp sym)
 108             (values (symbol-function sym) :function)
 109             (values nil nil)))))
 110
 111 ;;;%% arglist - return arglist of function
 112 ;;;
 113 ;;; This function is patterned after DESCRIBE-FUNCTION in the
 114 ;;; 'describe.lisp' file of CMUCL.
 115
 116 (defun arglist (symbol package)
 117   (ilisp-errors
 118    (let* ((package-name (if (packagep package)
 119                             (package-name package)
 120                             package))
 121           (x (ilisp-find-symbol symbol package-name)))
 122      (flet ((massage-arglist (args)
 123               (typecase args
 124                 (string (if (or (null args) (string= args "()"))
 125                             ""
 126                             args))
 127                 (list (format nil "~S" args))
 128                 (t ""))))
 129
 130        (multiple-value-bind (func kind)
 131            (extract-function-info-from-name x)
 132          ;; (print func *trace-output*)
 133          ;; (print kind *trace-output*)
 134          (if (and func kind)
 135              (case (lisp::get-type func)
 136                ((#.vm:closure-header-type
 137                  #.vm:function-header-type
 138                  #.vm:closure-function-header-type)
 139                 (massage-arglist
 140                  (the-function-if-defined
 141                   ((#:%function-arglist :lisp) (#:%function-header-arglist :lisp))
 142                   func)))
 143                (#.vm:funcallable-instance-header-type
 144                 (typecase func
 145                   (kernel:byte-function
 146                    "Byte compiled function or macro, no arglist available.")
 147                   (kernel:byte-closure
 148                    "Byte compiled closure, no arglist available.")
 149                   ((or generic-function pcl:generic-function)
 150                    (pcl::generic-function-pretty-arglist func))
 151                   (eval:interpreted-function
 152                    (massage-arglist (eval::interpreted-function-arglist func)))
 153
 154                   (t (print 99 *trace-output*) "No arglist available.")))
 155                (t "No arglist available."))
 156              "Unknown function - no arglist available." ; For the time
 157                                         ; being I just
 158                                         ; return this
 159                                         ; value. Maybe
 160                                         ; an error would
 161                                         ; be better.
 162              ))))))
 163
 164
 165 ;;; source-file symbol package type --
 166 ;;; New version provided by Richard Harris <rharris@chestnut.com> with
 167 ;;; suggestions by Larry Hunter <hunter@work.nlm.nih.gov>.
 168
 169 (defun source-file (symbol package type)
 170   (declare (ignore type))
 171   (ilisp-errors
 172    (let* ((x (ilisp-find-symbol symbol package))
 173           (fun (get-correct-fn-object x)))
 174      (when (and fun (not (eval:interpreted-function-p fun)))
 175        ;; The hack above is necessary because CMUCL does not
 176        ;; correctly record source file information when 'loading'
 177        ;; a non compiled file.
 178        ;; In this case we fall back on the TAGS machinery.
 179        ;; (At least as I underestand the code).
 180        ;; Marco Antoniotti 11/22/94.
 181        (cond ((or (the-function-if-defined ((#:generic-function-p :pcl) ())
 182                                            fun)
 183                   (the-function-if-defined ((#:get-type :lisp) ()
 184                                             :function-binding-p t)
 185                                            (= (funcall the-function fun)
 186                                               #.vm:funcallable-instance-header-type)))
 187                (dolist (method (pcl::generic-function-methods fun))
 188                  (print-simple-source-info
 189                   (the-function-if-defined ((#:method-fast-function :pcl)
 190                                             (#:method-function :pcl))
 191                                            method)))
 192                t)
 193              (t (print-simple-source-info fun)))))))
 194
 195 ;;; Patch suggested by Richard Harris <rharris@chestnut.com>
 196
 197 ;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object.  It
 198 ;;; returns a pathname for the file the function was defined in.  If it was
 199 ;;; not defined in some file, then nil is returned.
 200 ;;;
 201 ;;; FUN-DEFINED-FROM-PATHNAME is from hemlock/rompsite.lisp (cmucl17f),
 202 ;;; with added read-time conditionalization to work in older versions
 203 ;;; of cmucl.  It may need a little bit more conditionalization for
 204 ;;; some older versions of cmucl.
 205
 206 (defun fun-defined-from-pathname (function)
 207   "Returns the file where FUNCTION is defined in (if the file can be found).
 208 Takes a symbol or function and returns the pathname for the file the
 209 function was defined in.  If it was not defined in some file, nil is
 210 returned."
 211   (flet ((frob (code)
 212                (let ((info (the-function-if-defined ((#:%code-debug-info
 213                                                       :kernel)
 214                                                      (#:code-debug-info
 215                                                       :kernel))
 216                                                     code)))
 217                  (when info
 218                        (let ((sources (c::debug-info-source info)))
 219                          (when sources
 220                                (let ((source (car sources)))
 221                                  (when (eq (c::debug-source-from source) :file)
 222                                        (c::debug-source-name source)))))))))
 223         (typecase function
 224                   (symbol (fun-defined-from-pathname (fdefinition function)))
 225                   (#.(the-symbol-if-defined ((#:byte-closure :kernel) ()))
 226                     (fun-defined-from-pathname
 227                      (kernel:byte-closure-function function)))
 228                   (#.(the-symbol-if-defined ((#:byte-function :kernel) ()))
 229                     (frob (c::byte-function-component function)))
 230                   (function
 231                    (frob (kernel:function-code-header
 232                           (kernel:%function-self function))))
 233                   (t nil))))
 234
 235
 236 ;;; print-simple-source-info --
 237 ;;; Patches suggested by Larry Hunter <hunter@work.nlm.nih.gov> and
 238 ;;; Richard Harris <rharris@chestnut.com>
 239 ;;; Nov 21, 1994.
 240
 241 (defun print-simple-source-info (fun)
 242   (let ((path (fun-defined-from-pathname fun)))
 243     (when (and path (probe-file path))
 244       (print (namestring (truename path)))
 245       t)))
 246
 247 (defun cmulisp-trace (symbol package breakp)
 248   "Trace SYMBOL in PACKAGE."
 249   (ilisp-errors
 250    (let ((real-symbol (ilisp-find-symbol symbol package)))
 251      (setq breakp (read-from-string breakp))
 252      (when real-symbol (eval `(trace ,real-symbol :break ,breakp))))))
 253
 254 ;;; end of file -- cmulisp.lisp --