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

   1 ;;; -*- Mode: Lisp -*-
   2
   3 ;;; openmcl.lisp --
   4
   5 ;;; This file is part of ILISP.
   6 ;;; Please refer to the file COPYING for copyrights and licensing
   7 ;;; information.
   8 ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
   9 ;;; of present and past contributors.
  10
  11
  12 (in-package "ILISP")
  13
  14
  15 ;;;%% arglist/source-file utils.
  16
  17 (eval-when (:compile-toplevel :load-toplevel :execute)
  18   (export '(arglist source-file openmcl-trace)))
  19
  20
  21 ;;;%% arglist - return arglist of function
  22
  23 (defun arglist (symbol package)
  24   (ilisp-errors
  25    (let* ((package-name (if (packagep package)
  26                             (package-name package)
  27                             package))
  28           (x (ilisp-find-symbol symbol package-name)))
  29      (ccl::arglist x))))
  30
  31
  32 ;;; source-file symbol package type --
  33
  34
  35 (defun source-file (name package type)
  36   (ilisp-errors
  37    (flet ((print-source (path) (when path (print (namestring (truename path))) t)))
  38      (setq type (intern (string-upcase (string type)) "CL"))
  39      (let* ((symbol (ilisp-find-symbol name package))
  40             (source-info (ccl::%source-files symbol)))
  41        (when source-info
  42          (if (atom source-info)
  43            (when (eq type 'function)
  44              (print-source source-info))
  45            (let* ((info (or (cdr (assoc type source-info))
  46                             (and (eq type 'function)
  47                                  (mapcar #'cdr
  48                                           (cdr (assoc 'ccl::method source-info)))))))
  49              (when info
  50                (if (atom info)
  51                  (print-source info)
  52                  (dolist (p info t)
  53                    (print-source p)))))))))))
  54
  55 (defun ilisp-callers (symbol package)
  56   (ilisp-errors
  57    (let* ((function-name (ilisp-find-symbol symbol package))
  58           (callers (ccl::callers function-name)))
  59      (when callers
  60        (dolist (caller callers t) (print caller))))))
  61
  62
  63
  64 (defun openmcl-trace (symbol package breakp)
  65   "Trace SYMBOL in PACKAGE."
  66   (ilisp-errors
  67    (let ((real-symbol (ilisp-find-symbol symbol package)))
  68      (setq breakp (read-from-string breakp))
  69      (when real-symbol (eval `(trace (,real-symbol
  70                                       :before ,(if breakp :break))))))))
  71
  72
  73 ;;; Some versions of OpenMCL don't define INSPECT.  The FTYPE declamation
  74 ;;; below will keep the compiler from generating UNDEFINED-FUNCTION warnings
  75 ;;; when it sees calls to INSPECT.
  76
  77 (declaim (ftype (function (t) t) inspect))
  78
  79 ;;; end of file -- openmcl.lisp --