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