home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / gnu / lucid / lemacs-19.6 / lisp / ilisp / cmulisp.lisp < prev    next >
Encoding:
Text File  |  1992-06-29  |  4.4 KB  |  138 lines
  1. ;;; -*- mode: LISP; package: LISP -*-
  2.  
  3. ;;;
  4. ;;; Todd Kaufmann    May 1990
  5. ;;;
  6. ;;; Make CMU CL run better within GNU inferior-lisp (by ccm).
  7. ;;;
  8. ;;; This program is freely distributable under
  9. ;;;  the terms of the GNU Public license.
  10.  
  11.  
  12. (in-package "ILISP")
  13.  
  14. ;;;% CMU CL does not define defun as a macro
  15. (defun ilisp-compile (form package filename)
  16.   "Compile FORM in PACKAGE recording FILENAME as the source file."
  17.   (ilisp-errors
  18.    (ilisp-eval
  19.     (format nil "(funcall (compile nil '(lambda () ~A)))" form)
  20.     package filename)))
  21.  
  22. ;;;% Stream settings, when running connected to pipes.
  23. ;;;
  24. ;;; This fixes a problem when running piped: When CMU is running as a piped
  25. ;;; process, *terminal-io* really is a terminal; ie, /dev/tty.  This means an
  26. ;;; error will cause lisp to stop and wait for input from /dev/tty, which it
  27. ;;; won't be able to grab, and you'll have to restart your lisp.  But we want
  28. ;;; it to use the same input that the user is typing in, ie, the pipe (stdin).
  29. ;;; This fixes that problem, which only occurs in the CMU cores of this year.
  30. ;;;
  31.  
  32. (defvar *Fix-pipe-streams* T
  33.   "Set to Nil if you want them left alone.  And tell me you don't get stuck.")
  34.  
  35. (when (and *Fix-pipe-streams*
  36.        (lisp::synonym-stream-p *terminal-io*)
  37.        (eq (lisp::synonym-stream-symbol *terminal-io*)
  38.            'SYSTEM::*TTY*))
  39.   (setf *terminal-io* (make-two-way-stream system::*stdin* system::*stdout*))
  40.   ;; *query-io* and *debug-io* are synonym streams to this, so this fixes
  41.   ;; everything.
  42.   )
  43.  
  44. ;;;% Debugger extensions
  45.  
  46. ;;;%% Implementation of a :pop command for CMU CL debugger
  47.  
  48. ;;;
  49. ;;; Normally, errors which occur while in the debugger are just ignored, unless
  50. ;;; the user issues the "flush" command, which toggles this behavior.
  51. ;;;
  52. (setq debug:*flush-debug-errors* nil)  ;; allow multiple error levels.
  53.  
  54. ;;; This implementation of "POP" simply looks for the first restart that says
  55. ;;; "Return to debug level n" or "Return to top level." and executes it.
  56. ;;;
  57. (debug::def-debug-command "POP" #+:new-compiler ()
  58.     ;; find the first "Return to ..." restart
  59.     (if (not (boundp 'debug::*debug-restarts*))
  60.     (error "You're not in the debugger; how can you call this!?")
  61.     (labels ((find-return-to (restart-list num)
  62.          (let ((first
  63.             (member-if
  64.              #'(lambda (restart)
  65.                  (string= (funcall
  66.                        (conditions::restart-report-function restart)
  67.                        nil)
  68.                       "Return to " :end1 10))
  69.               restart-list)))
  70.            (cond ((zerop num) (car first))
  71.              ((cdr first) (find-return-to (cdr first) (1- num)))))))
  72.     (let* ((level (debug::read-if-available 1))
  73.            (first-return-to (find-return-to 
  74.                  debug::*debug-restarts* (1- level))))
  75.       (if (null first-return-to)
  76.           (format *debug-io* "pop: ~d is too far" level)
  77.           (debug::invoke-restart-interactively first-return-to)
  78.           ))))
  79.     )
  80.  
  81. ;;;% Extensions to describe.
  82.  
  83. ;(in-package "LISP")
  84.  
  85. ;;; Put these in the EXT package, but to define them we need access to
  86. ;;; symbols in lisp's guts. 
  87.  
  88. ;(import '(arglist source-file) (find-package "EXTENSIONS"))
  89. ;(export '(arglist source-file) (find-package "EXTENSIONS"))
  90.  
  91.  
  92. ;;;%% arglist - return arglist of function
  93.  
  94. #+ignore
  95. (defun arglist (symbol package)
  96.   (ilisp:ilisp-errors
  97.    (let* ((x (ilisp:ilisp-find-symbol symbol package))
  98.       (fun (symbol-function x)))
  99.      (values
  100.       (read-from-string
  101.        (cond ((compiled-function-p fun)
  102.           (system::%primitive header-ref fun %function-arg-names-slot)
  103.           )
  104.          ((desc-lambdap fun)    ; (lambda (arglist) ..)  form
  105.           (cadr fun))
  106.  
  107.          ;; this never happens.
  108.          ;;((eq (car fun) '%compiled-closure%)
  109.          ;;(describe-function-compiled (third x)))
  110.  
  111.          ((desc-lexical-closure-p fun)
  112.           (cadadr fun))
  113.          (t (error "Unknown type of function"))))))))
  114.  
  115. ;;;%% source-file
  116. ;;;
  117. ;;; For compiled functions only, since the compiler adds this information.
  118.  
  119. #+ignore
  120. (defun source-file (symbol package type)
  121.   (declare (ignore type))
  122.   (ilisp:ilisp-errors
  123.    (let ((fun (ilisp:ilisp-find-symbol symbol package)))
  124.      (and (fboundp fun)
  125.       (compiled-function-p (symbol-function fun))
  126.       (let* ((compiler-string
  127.           (%primitive header-ref (symbol-function fun)
  128.                   %function-defined-from-slot))
  129.          (def-string
  130.              (subseq
  131.               compiler-string 0 (position #\space compiler-string))))
  132.         (if (string= def-string "Lisp") nil
  133.         (progn (print def-string)
  134.                t)
  135.         ))))))
  136. ;(unless (compiled-function-p #'source-file)
  137. ;  (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))
  138.