Mercurial > hg > xemacs-beta
comparison lisp/ilisp/lispworks.lisp @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
author | cvs |
---|---|
date | Mon, 13 Aug 2007 08:45:50 +0200 |
parents | |
children | b82b59fe008d |
comparison
equal
deleted
inserted
replaced
-1:000000000000 | 0:376386a54a3c |
---|---|
1 ;;; -*- Mode: Lisp -*- | |
2 | |
3 ;;; lispworks.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 ;;; LispWorks ILISP initializations. | |
25 ;;; | |
26 ;;; Independently written by: | |
27 ;;; | |
28 ;;; Jason Trenouth: jason@harlequin.co.uk | |
29 ;;; Qiegang Long: qlong@cs.umass.edu | |
30 ;;; | |
31 ;;; and later merged together by Jason | |
32 | |
33 | |
34 (in-package "ILISP") | |
35 | |
36 (defun ilisp-callers (symbol package) | |
37 "Print a list of all of the functions that call FUNCTION. | |
38 Return T if successful." | |
39 (ilisp-errors | |
40 (let ((function-name (ilisp-find-symbol symbol package)) | |
41 (*print-level* nil) | |
42 (*print-length* nil) | |
43 (*package* (find-package 'lisp)) | |
44 (callers ()) | |
45 ) | |
46 (when (and function-name (fboundp function-name)) | |
47 (setf callers (munge-who-calls (lw:who-calls function-name))) | |
48 (dolist (caller callers) | |
49 (print caller)) | |
50 t)))) | |
51 | |
52 ;; gross hack to munge who-calls output for ILISP | |
53 (defun munge-who-calls (who-calls) | |
54 (labels ((top-level-caller (form) | |
55 (if (atom form) | |
56 form | |
57 (top-level-caller (second form))))) | |
58 (delete-if-not 'symbolp | |
59 (delete-duplicates (mapcar #'top-level-caller who-calls))))) | |
60 | |
61 | |
62 ;; Jason 6 SEP 94 -- tabularized Qiegang's code | |
63 ;; | |
64 ;; There are some problems lurking here: | |
65 ;; - the mapping ought to be done by LispWorks | |
66 ;; - surely you really want just three source types: | |
67 ;; function, type, and variable | |
68 ;; | |
69 (defconstant *source-type-translations* | |
70 '( | |
71 ("class" defclass) | |
72 ("function" ) | |
73 ("macro" ) | |
74 ("structure" defstruct) | |
75 ("setf" defsetf) | |
76 ("type" deftype) | |
77 ("variable" defvar defparameter defconstant) | |
78 )) | |
79 | |
80 | |
81 (defun translate-source-type-to-dspec (symbol type) | |
82 (let ((entry (find type *source-type-translations* | |
83 :key 'first :test 'equal))) | |
84 (if entry | |
85 (let ((wrappers (rest entry))) | |
86 (if wrappers | |
87 (loop for wrap in wrappers collecting `(,wrap ,symbol)) | |
88 `(,symbol))) | |
89 (error "unknown source type for ~S requested from ILISP: ~S" | |
90 symbol type)))) | |
91 | |
92 | |
93 (defun ilisp-source-files (symbol package type) | |
94 "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and | |
95 return T if successful. A function to limit the search with type?" | |
96 (ilisp-errors | |
97 (let* ((symbol (ilisp-find-symbol symbol package)) | |
98 (all (equal type "any")) | |
99 (paths (when symbol (compiler::find-source-file symbol))) | |
100 (dspecs (or all (translate-source-type-to-dspec symbol type))) | |
101 (cands ()) | |
102 ) | |
103 (if (and paths (not all)) | |
104 (setq cands | |
105 (loop for path in paths | |
106 when (find (car path) dspecs :test 'equal) | |
107 collect path)) | |
108 (setq cands paths)) | |
109 (if cands | |
110 (progn | |
111 (dolist (file (remove-duplicates paths | |
112 :key #'cdr :test #'equal)) | |
113 (print (namestring (cadr file)))) | |
114 t) | |
115 nil)))) | |
116 | |
117 (unless (compiled-function-p #'ilisp-callers) | |
118 (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\"")) | |
119 | |
120 ;;; end of file -- lispworks.lisp -- |