|
0
|
1 ;;; -*- Mode: Lisp -*-
|
|
|
2
|
|
|
3 ;;; clisp.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 ;;; Common Lisp initializations
|
|
|
25 ;;; Author: Chris McConnell, ccm@cs.cmu.edu
|
|
|
26
|
|
|
27 ;;;
|
|
|
28 ;;; ange-ftp hack added by ivan Wed Mar 10 12:30:15 1993
|
|
|
29 ;;; ilisp-errors *gc-verbose* addition ivan Tue Mar 16 03:21:51 1993
|
|
|
30 ;;;
|
|
|
31 ;;; Rcs_Info: clisp.lisp,v 1.26 1993/09/03 02:05:07 ivan Rel $
|
|
|
32 ;;;
|
|
|
33 ;;; Revision 1.19 1993/08/24 22:01:52 ivan
|
|
|
34 ;;; Use defpackage instead of just IN-PACKAGE.
|
|
|
35 ;;; Renamed FUNCTION to FUN in ilisp-arglist to get around CMUCL 17b bug.
|
|
|
36 ;;;
|
|
|
37 ;;; Revision 1.16 1993/06/29 05:51:35 ivan
|
|
|
38 ;;; Added Ed Gamble's #'readtable-case fix and Hans Chalupsky's
|
|
|
39 ;;; allegro-4.1 addition.
|
|
|
40 ;;;
|
|
|
41 ;;; Revision 1.8 1993/06/28 00:57:42 ivan
|
|
|
42 ;;; Stopped using 'COMPILED-FUNCTION-P for compiled check.
|
|
|
43 ;;;
|
|
|
44 ;;; Revision 1.3 1993/03/16 23:22:10 ivan
|
|
|
45 ;;; Added breakp arg to ilisp-trace.
|
|
|
46 ;;;
|
|
|
47 ;;;
|
|
|
48
|
|
|
49
|
|
|
50 #+(or allegro-v4.0 allegro-v4.1)
|
|
|
51 (eval-when (compile load eval)
|
|
|
52 (setq excl:*cltl1-in-package-compatibility-p* t))
|
|
|
53
|
|
|
54
|
|
|
55 ;;; The following is really a kludge! The defpackage should be in a
|
|
|
56 ;;; separate file, but it looks like it is really hard to change ILISP
|
|
|
57 ;;; behavior on the subject.
|
|
|
58 ;;; Marco Antoniotti 11/22/94
|
|
|
59
|
|
|
60 ;;; I am commenting it out to see whether I can actually load the
|
|
|
61 ;;; package file with the kludge in the definition of the dialect.
|
|
|
62 ;;;
|
|
|
63 ;;; Result: it works! This will disappear in the next release.
|
|
|
64
|
|
|
65 #|
|
|
|
66 (eval-when (compile load eval)
|
|
|
67 (defpackage "ILISP" (:use "LISP" #+:CMU "CONDITIONS")
|
|
|
68 (:export "ILISP-ERRORS"
|
|
|
69 "ILISP-SAVE"
|
|
|
70 "ILISP-RESTORE"
|
|
|
71 "ILISP-SYMBOL-NAME"
|
|
|
72 "ILISP-FIND-SYMBOL"
|
|
|
73 "ILISP-FIND-PACKAGE"
|
|
|
74 "ILISP-EVAL"
|
|
|
75 "ILISP-COMPILE"
|
|
|
76 "ILISP-DESCRIBE"
|
|
|
77 "ILISP-INSPECT"
|
|
|
78 "ILISP-ARGLIST"
|
|
|
79 "ILISP-DOCUMENTATION"
|
|
|
80 "ILISP-MACROEXPAND"
|
|
|
81 "ILISP-MACROEXPAND-1"
|
|
|
82 "ILISP-TRACE"
|
|
|
83 "ILISP-UNTRACE"
|
|
|
84 "ILISP-COMPILE-FILE"
|
|
|
85 "ILISP-CASIFY"
|
|
|
86 "ILISP-MATCHING-SYMBOLS")
|
|
|
87 ))
|
|
|
88 |#
|
|
|
89
|
|
|
90
|
|
|
91 (in-package "ILISP")
|
|
|
92
|
|
|
93 ;;;
|
|
|
94 ;;; GCL 2.2 doesn't have defpackage (yet) so we need to put the export
|
|
|
95 ;;; here. (toy@rtp.ericsson.se)
|
|
|
96
|
|
|
97 #+gcl
|
|
|
98 (export '(ilisp-errors
|
|
|
99 ilisp-save
|
|
|
100 ilisp-restore
|
|
|
101 ilisp-symbol-name
|
|
|
102 ilisp-find-symbol
|
|
|
103 ilisp-find-package
|
|
|
104 ilisp-eval
|
|
|
105 ilisp-compile
|
|
|
106 ilisp-describe
|
|
|
107 ilisp-inspect
|
|
|
108 ilisp-arglist
|
|
|
109 ilisp-documentation
|
|
|
110 ilisp-macroexpand
|
|
|
111 ilisp-macroexpand-1
|
|
|
112 ilisp-trace
|
|
|
113 ilisp-untrace
|
|
|
114 ilisp-compile-file
|
|
|
115 ilisp-casify
|
|
|
116 ilisp-matching-symbols))
|
|
|
117
|
|
|
118
|
|
|
119 ;;;
|
|
|
120 (defvar *ilisp-old-result* nil "Used for save/restore of top level values.")
|
|
|
121
|
|
|
122 #+:ANSI-CL
|
|
|
123 (defun special-form-p (symbol)
|
|
|
124 "Backward compatibility for non ANSI CL's."
|
|
|
125 (special-operator-p symbol))
|
|
|
126
|
|
|
127 ;;;
|
|
|
128 (defmacro ilisp-handler-case (expression &rest handlers)
|
|
|
129 "Evaluate EXPRESSION using HANDLERS to handle errors."
|
|
|
130 handlers
|
|
|
131 (if (macro-function 'handler-case)
|
|
|
132 `(handler-case ,expression ,@handlers)
|
|
|
133 #+allegro `(excl::handler-case ,expression ,@handlers)
|
|
|
134 #+lucid `(lucid::handler-case ,expression ,@handlers)
|
|
|
135 #-(or allegro lucid) expression))
|
|
|
136
|
|
|
137 ;;;
|
|
|
138 (defun ilisp-readtable-case (readtable)
|
|
|
139 (if (fboundp 'readtable-case)
|
|
|
140 (funcall #'readtable-case readtable)
|
|
|
141 #+allegro (case excl:*current-case-mode*
|
|
|
142 (:case-insensitive-upper :upcase)
|
|
|
143 (:case-insensitive-lower :downcase)
|
|
|
144 (otherwise :preserve))
|
|
|
145 #-allegro :upcase))
|
|
|
146
|
|
|
147 ;;;
|
|
|
148 (defmacro ilisp-errors (form)
|
|
|
149 "Handle errors when evaluating FORM."
|
|
|
150 `(let ((*standard-output* *terminal-io*)
|
|
|
151 (*error-output* *terminal-io*)
|
|
|
152 #+cmu
|
|
|
153 (ext:*gc-verbose* nil) ; cmulisp outputs "[GC ...]" which
|
|
|
154 ; doesn't read well...
|
|
|
155 #+ecl
|
|
|
156 (sys:*gc-verbose* nil) ; ecolisp also outputs "[GC ...]"
|
|
|
157 )
|
|
|
158 (princ " ") ;Make sure we have output
|
|
|
159 (ilisp-handler-case
|
|
|
160 ,form
|
|
|
161 (error (error)
|
|
|
162 (with-output-to-string (string)
|
|
|
163 (format string "ILISP: ~A" error))))))
|
|
|
164
|
|
|
165
|
|
|
166 ;;;
|
|
|
167 (defun ilisp-save ()
|
|
|
168 "Save the current state of the result history."
|
|
|
169 (declare (special / // /// + ++ +++))
|
|
|
170 (unless *ilisp-old-result*
|
|
|
171 (setq *ilisp-old-result* (list /// // +++ ++ + /))))
|
|
|
172
|
|
|
173 ;;;
|
|
|
174 (defun ilisp-restore ()
|
|
|
175 "Restore the old result history."
|
|
|
176 (declare (special / // /// + ++ +++ * ** -))
|
|
|
177 (setq // (pop *ilisp-old-result*)
|
|
|
178 ** (first //)
|
|
|
179 / (pop *ilisp-old-result*)
|
|
|
180 * (first /)
|
|
|
181 ++ (pop *ilisp-old-result*)
|
|
|
182 + (pop *ilisp-old-result*)
|
|
|
183 - (pop *ilisp-old-result*))
|
|
|
184 (values-list (pop *ilisp-old-result*)))
|
|
|
185
|
|
|
186 ;;; ilisp-symbol-name --
|
|
|
187 ;;;
|
|
|
188 ;;; ':capitalize' case added under suggestion by Rich Mallory.
|
|
|
189 (defun ilisp-symbol-name (symbol-name)
|
|
|
190 "Return SYMBOL-NAME with the appropriate case as a symbol."
|
|
|
191 (case (ilisp-readtable-case *readtable*)
|
|
|
192 (:upcase (string-upcase symbol-name))
|
|
|
193 (:downcase (string-downcase symbol-name))
|
|
|
194 (:capitalize (string-capitalize symbol-name))
|
|
|
195 (:preserve symbol-name)))
|
|
|
196
|
|
|
197 ;;;
|
|
|
198 (defun ilisp-find-package (package-name)
|
|
|
199 "Return package PACKAGE-NAME or the current package."
|
|
|
200 (if (string-equal package-name "nil")
|
|
|
201 *package*
|
|
|
202 (or (find-package (ilisp-symbol-name package-name))
|
|
|
203 (error "Package ~A not found" package-name))))
|
|
|
204
|
|
|
205 ;;;
|
|
|
206 (defun ilisp-find-symbol (symbol-name package-name)
|
|
|
207 "Return the symbol associated with SYMBOL-NAME in PACKAGE-NAME trying to
|
|
|
208 handle case issues intelligently."
|
|
|
209 (find-symbol (ilisp-symbol-name symbol-name)
|
|
|
210 (ilisp-find-package package-name)))
|
|
|
211
|
|
|
212
|
|
|
213 ;;; The following two functions were in version 5.5.
|
|
|
214 ;;; They disappeared in version 5.6. I am putting them back in the
|
|
|
215 ;;; distribution in order to make use of them later if the need
|
|
|
216 ;;; arises.
|
|
|
217 ;;; Marco Antoniotti: Jan 2 1995
|
|
|
218 #|
|
|
|
219 (defun ilisp-filename-hack (filename)
|
|
|
220 "Strip `/user@machine:' prefix from filename."
|
|
|
221 ;; Ivan's hack for getting away with dumb /ivan@bu-conx:/foo/bar/baz
|
|
|
222 ;; filenames...
|
|
|
223 (let ((at-location (position #\@ filename))
|
|
|
224 (colon-location (position #\: filename)))
|
|
|
225 (if (and at-location colon-location)
|
|
|
226 (subseq filename (1+ colon-location))
|
|
|
227 filename)))
|
|
|
228
|
|
|
229
|
|
|
230 (defun ilisp-read-form (form package)
|
|
|
231 "Read string FORM in PACKAGE and return the resulting form."
|
|
|
232 (let ((*package* (ilisp-find-package package)))
|
|
|
233 (read-from-string form)))
|
|
|
234 |#
|
|
|
235
|
|
|
236 ;;;
|
|
|
237 (defun ilisp-eval (form package filename)
|
|
|
238 "Evaluate FORM in PACKAGE recording FILENAME as the source file."
|
|
|
239 (princ " ")
|
|
|
240 ;; Ivan's hack for getting away with dumb /ivan@bu-conx:/foo/bar/baz
|
|
|
241 ;; filenames...
|
|
|
242 (let* ((at-location (position #\@ filename))
|
|
|
243 (colon-location (position #\: filename))
|
|
|
244 (filename
|
|
|
245 (if (and at-location colon-location)
|
|
|
246 (subseq filename (1+ colon-location))
|
|
|
247 filename))
|
|
|
248 (*package* (ilisp-find-package package))
|
|
|
249 #+allegro (excl::*source-pathname* filename)
|
|
|
250 #+allegro (excl::*redefinition-warnings* nil)
|
|
|
251 #+lucid (lucid::*source-pathname*
|
|
|
252 (if (probe-file filename)
|
|
|
253 (truename filename)
|
|
|
254 (merge-pathnames filename)))
|
|
|
255 #+lucid (lucid::*redefinition-action* nil)
|
|
|
256 #+lispworks (compiler::*input-pathname* (merge-pathnames filename))
|
|
|
257 #+lispworks (compiler::*warn-on-non-top-level-defun* nil)
|
|
|
258 ;; The LW entries are a mix of Rich Mallory and Jason
|
|
|
259 ;; Trenouth suggestions
|
|
|
260 ;; Marco Antoniotti: Jan 2 1995.
|
|
|
261 )
|
|
|
262 filename
|
|
|
263 (eval (read-from-string form))))
|
|
|
264
|
|
|
265 ;;;
|
|
|
266 (defun ilisp-compile (form package filename)
|
|
|
267 "Compile FORM in PACKAGE recording FILENAME as the source file."
|
|
|
268 (princ " ")
|
|
|
269 ;; This makes sure that function forms are compiled
|
|
|
270 ;; NOTE: Rich Mallory proposed a variation of the next piece of
|
|
|
271 ;; code. for the time being we stick to the following simpler code.
|
|
|
272 ;; Marco Antoniotti: Jan 2 1995.
|
|
|
273 #-lucid
|
|
|
274 (ilisp-eval
|
|
|
275 (format nil "(funcall (compile nil '(lisp:lambda () ~A)))"
|
|
|
276 form)
|
|
|
277 package
|
|
|
278 filename)
|
|
|
279
|
|
|
280 ;; The following piece of conditional code is left in the
|
|
|
281 ;; distribution just for historical purposes.
|
|
|
282 ;; It will disappear in the next release.
|
|
|
283 ;; Marco Antoniotti: Jan 2 1995.
|
|
|
284 #+lucid-ilisp-5.6
|
|
|
285 (labels ((compiler (form env)
|
|
|
286 (if (and (consp form)
|
|
|
287 (eq (first form) 'function)
|
|
|
288 (consp (second form)))
|
|
|
289 #-LCL3.0
|
|
|
290 (evalhook `(compile nil ,form) nil nil env)
|
|
|
291 #+LCL3.0
|
|
|
292 ;; If we have just compiled a named-lambda, and the
|
|
|
293 ;; name didn't make it in to the procedure object,
|
|
|
294 ;; then stuff the appropriate symbol in to the
|
|
|
295 ;; procedure object.
|
|
|
296 (let* ((proc (evalhook `(compile nil ,form)
|
|
|
297 nil nil env))
|
|
|
298 (old-name (and proc (sys:procedure-ref proc 1)))
|
|
|
299 (lambda (second form))
|
|
|
300 (name (and (eq (first lambda)
|
|
|
301 'lucid::named-lambda)
|
|
|
302 (second lambda))))
|
|
|
303 (when (or (null old-name)
|
|
|
304 (and (listp old-name)
|
|
|
305 (eq :internal (car old-name))))
|
|
|
306 (setf (sys:procedure-ref proc 1) name))
|
|
|
307 proc)
|
|
|
308 (evalhook form #'compiler nil env))))
|
|
|
309 (let ((*evalhook* #'compiler))
|
|
|
310 (ilisp-eval form package filename)))
|
|
|
311 #+lucid
|
|
|
312 ;; Following form is a patch provided by Christopher Hoover
|
|
|
313 ;; <ch@lks.csi.com>
|
|
|
314 (let ((*package* (ilisp-find-package package))
|
|
|
315 (lcl:*source-pathname* (if (probe-file filename)
|
|
|
316 (truename filename)
|
|
|
317 (merge-pathnames filename)))
|
|
|
318 (lcl:*redefinition-action* nil))
|
|
|
319 (with-input-from-string (s form)
|
|
|
320 (lucid::compile-in-core-from-stream s)
|
|
|
321 (values)))
|
|
|
322 )
|
|
|
323
|
|
|
324 ;;;
|
|
|
325 (defun ilisp-describe (sexp package)
|
|
|
326 "Describe SEXP in PACKAGE."
|
|
|
327 (ilisp-errors
|
|
|
328 (let ((*package* (ilisp-find-package package)))
|
|
|
329 (describe (eval (read-from-string sexp))))))
|
|
|
330
|
|
|
331 ;;;
|
|
|
332 (defun ilisp-inspect (sexp package)
|
|
|
333 "Inspect SEXP in PACKAGE."
|
|
|
334 (ilisp-errors
|
|
|
335 (let ((*package* (ilisp-find-package package)))
|
|
|
336 (inspect (eval (read-from-string sexp))))))
|
|
|
337
|
|
|
338 ;;;
|
|
|
339 (defun ilisp-arglist (symbol package)
|
|
|
340 (ilisp-errors
|
|
|
341 (let ((fn (ilisp-find-symbol symbol package))
|
|
|
342 (*print-length* nil)
|
|
|
343 (*print-pretty* t)
|
|
|
344 (*package* (ilisp-find-package package)))
|
|
|
345 (cond ((null fn)
|
|
|
346 (format t "Symbol ~s not present in ~s." symbol package))
|
|
|
347 ((not (fboundp fn))
|
|
|
348 (format t "~s: undefined~%" fn))
|
|
|
349 (t
|
|
|
350 (print-function-arglist fn)))))
|
|
|
351 (values))
|
|
|
352
|
|
|
353
|
|
|
354 (defun print-function-arglist (fn)
|
|
|
355 "Pretty arglist printer"
|
|
|
356 (let* ((a (get-function-arglist fn))
|
|
|
357 (arglist (ldiff a (member '&aux a)))
|
|
|
358 (desc (ilisp-function-short-description fn)))
|
|
|
359 (format t "~&~s~a" fn (or desc ""))
|
|
|
360 (write-string ": ")
|
|
|
361 (if arglist
|
|
|
362 (write arglist :case :downcase :escape nil)
|
|
|
363 (write-string "()"))
|
|
|
364 (terpri)))
|
|
|
365
|
|
|
366
|
|
|
367
|
|
|
368 (defun ilisp-generic-function-p (symbol)
|
|
|
369 (let ((generic-p
|
|
|
370 (find-symbol "GENERIC-FUNCTION-P"
|
|
|
371 (or (find-package "PCL")
|
|
|
372 *package*))))
|
|
|
373 (and generic-p
|
|
|
374 (fboundp generic-p)
|
|
|
375 (funcall generic-p symbol))))
|
|
|
376
|
|
|
377
|
|
|
378
|
|
|
379 (defun ilisp-function-short-description (symbol)
|
|
|
380 (cond ((macro-function symbol)
|
|
|
381 " (Macro)")
|
|
|
382 ((special-form-p symbol)
|
|
|
383 " (Special Form)")
|
|
|
384 ((ilisp-generic-function-p symbol)
|
|
|
385 " (Generic)")))
|
|
|
386
|
|
|
387
|
|
|
388
|
|
|
389 (defun get-function-arglist (symbol)
|
|
|
390 (let ((fun (symbol-function symbol)))
|
|
|
391 (cond ((ilisp-generic-function-p symbol)
|
|
|
392 (funcall
|
|
|
393 (find-symbol "GENERIC-FUNCTION-PRETTY-ARGLIST"
|
|
|
394 (or (find-package "PCL") *package*))
|
|
|
395 fun))
|
|
|
396 (t
|
|
|
397 #+allegro
|
|
|
398 (excl::arglist symbol)
|
|
|
399
|
|
|
400 #+(or ibcl kcl ecl gcl)
|
|
|
401 (help symbol)
|
|
|
402
|
|
|
403 #+lucid
|
|
|
404 (lucid::arglist symbol)
|
|
|
405
|
|
|
406 #+lispworks
|
|
|
407 (system::function-lambda-list symbol)
|
|
|
408
|
|
|
409 #-(or allegro lucid kcl ibcl ecl)
|
|
|
410 (documentation symbol 'function)))))
|
|
|
411
|
|
|
412 ;;;
|
|
|
413 (defun ilisp-documentation (symbol package type)
|
|
|
414 "Return the TYPE documentation for SYMBOL in PACKAGE. If TYPE is
|
|
|
415 \(qualifiers* (class ...)), the appropriate method will be found."
|
|
|
416 (ilisp-errors
|
|
|
417 (let* ((real-symbol (ilisp-find-symbol symbol package))
|
|
|
418 (type (if (and (not (zerop (length type)))
|
|
|
419 (eq (elt type 0) #\())
|
|
|
420 (let ((*package* (ilisp-find-package package)))
|
|
|
421 (read-from-string type))
|
|
|
422 (ilisp-find-symbol type package))))
|
|
|
423 (when (listp type)
|
|
|
424 (setq real-symbol
|
|
|
425 (funcall
|
|
|
426 (find-symbol "FIND-METHOD" (or (find-package "CLOS")
|
|
|
427 (find-package "PCL")
|
|
|
428 *package*))
|
|
|
429 (symbol-function real-symbol)
|
|
|
430 (reverse
|
|
|
431 (let ((quals nil))
|
|
|
432 (dolist (entry type quals)
|
|
|
433 (if (listp entry)
|
|
|
434 (return quals)
|
|
|
435 (setq quals (cons entry quals))))))
|
|
|
436 (reverse
|
|
|
437 (let ((types nil))
|
|
|
438 (dolist (class (first (last type)) types)
|
|
|
439 (setq types
|
|
|
440 (cons (funcall
|
|
|
441 (find-symbol "FIND-CLASS"
|
|
|
442 (or (find-package "CLOS")
|
|
|
443 (find-package "PCL")
|
|
|
444 *package*))
|
|
|
445 class) types))))))))
|
|
|
446 (if real-symbol
|
|
|
447 (if (symbolp real-symbol)
|
|
|
448 (documentation real-symbol type)
|
|
|
449 ;; Prevent compiler complaints
|
|
|
450 (eval `(documentation ,real-symbol)))
|
|
|
451 (format nil "~A has no ~A documentation" symbol type)))))
|
|
|
452
|
|
|
453 ;;;
|
|
|
454 (defun ilisp-macroexpand (expression package)
|
|
|
455 "Macroexpand EXPRESSION as long as the top level function is still a
|
|
|
456 macro."
|
|
|
457 (ilisp-errors
|
|
|
458 (let ((*print-length* nil)
|
|
|
459 (*print-level* nil)
|
|
|
460 (*package* (ilisp-find-package package)))
|
|
|
461 (pprint (#-allegro macroexpand #+allegro excl::walk
|
|
|
462 (read-from-string expression))))))
|
|
|
463
|
|
|
464 ;;;
|
|
|
465 (defun ilisp-macroexpand-1 (expression package)
|
|
|
466 "Macroexpand EXPRESSION once."
|
|
|
467 (ilisp-errors
|
|
|
468 (let ((*print-length* nil)
|
|
|
469 (*print-level* nil)
|
|
|
470 (*package* (ilisp-find-package package)))
|
|
|
471 (pprint (macroexpand-1 (read-from-string expression))))))
|
|
|
472
|
|
|
473 ;;;
|
|
|
474 #-lispworks
|
|
|
475 (defun ilisp-trace (symbol package breakp)
|
|
|
476 "Trace SYMBOL in PACKAGE."
|
|
|
477 (declare (ignore breakp)) ; No way to do this in CL.
|
|
|
478 (ilisp-errors
|
|
|
479 (let ((real-symbol (ilisp-find-symbol symbol package)))
|
|
|
480 (when real-symbol (eval `(trace ,real-symbol))))))
|
|
|
481
|
|
|
482 ;;; Jason Trenouth: SEP 6 94 -- LispWorks can trace-break
|
|
|
483 #+lispworks
|
|
|
484 (defun ilisp-trace (symbol package breakp)
|
|
|
485 "Trace SYMBOL in PACKAGE."
|
|
|
486 (ilisp-errors
|
|
|
487 (let ((real-symbol (ilisp-find-symbol symbol package)))
|
|
|
488 breakp ;; idiom for (declare (ignorable breakp))
|
|
|
489 (when real-symbol (eval `(trace (,real-symbol :break breakp)))))))
|
|
|
490
|
|
|
491
|
|
|
492
|
|
|
493 (defun ilisp-untrace (symbol package)
|
|
|
494 "Untrace SYMBOL in PACKAGE."
|
|
|
495 (ilisp-errors
|
|
|
496 (let ((real-symbol (ilisp-find-symbol symbol package)))
|
|
|
497 (when real-symbol (eval `(untrace ,real-symbol))))))
|
|
|
498
|
|
|
499 ;;;
|
|
|
500 (defun ilisp-compile-file (file extension)
|
|
|
501 "Compile FILE putting the result in FILE+EXTENSION."
|
|
|
502 (ilisp-errors
|
|
|
503 (compile-file file
|
|
|
504 :output-file
|
|
|
505 (merge-pathnames (make-pathname :type extension) file))))
|
|
|
506
|
|
|
507 ;;;
|
|
|
508 (defun ilisp-casify (pattern string lower-p upper-p)
|
|
|
509 "Return STRING with its characters converted to the case of PATTERN,
|
|
|
510 continuing with the last case beyond the end."
|
|
|
511 (cond (lower-p (string-downcase string))
|
|
|
512 (upper-p (string-upcase string))
|
|
|
513 (t
|
|
|
514 (let (case)
|
|
|
515 (concatenate
|
|
|
516 'string
|
|
|
517 (map 'string
|
|
|
518 #'(lambda (p s)
|
|
|
519 (setq case (if (upper-case-p p)
|
|
|
520 #'char-upcase
|
|
|
521 #'char-downcase))
|
|
|
522 (funcall case s))
|
|
|
523 pattern string)
|
|
|
524 (map 'string case (subseq string (length pattern))))))))
|
|
|
525
|
|
|
526 ;;;
|
|
|
527 (defun ilisp-words (string)
|
|
|
528 "Return STRING broken up into words. Each word is (start end
|
|
|
529 delimiter)."
|
|
|
530 (do* ((length (length string))
|
|
|
531 (start 0)
|
|
|
532 (end t)
|
|
|
533 (words nil))
|
|
|
534 ((null end) (nreverse words))
|
|
|
535 (if (setq end (position-if-not #'alphanumericp string :start start))
|
|
|
536 (setq words (cons (list end (1+ end) t)
|
|
|
537 (if (= start end)
|
|
|
538 words
|
|
|
539 (cons (list start end nil) words)))
|
|
|
540 start (1+ end))
|
|
|
541 (setq words (cons (list start length nil) words)))))
|
|
|
542
|
|
|
543 ;;;
|
|
|
544 (defun ilisp-match-words (string pattern words)
|
|
|
545 "Match STRING to PATTERN using WORDS."
|
|
|
546 (do* ((strlen (length string))
|
|
|
547 (words words (cdr words))
|
|
|
548 (word (first words) (first words))
|
|
|
549 (start1 (first word) (first word))
|
|
|
550 (end1 (second word) (second word))
|
|
|
551 (delimiter (third word) (third word))
|
|
|
552 (len (- end1 start1) (and word (- end1 start1)))
|
|
|
553 (start2 0)
|
|
|
554 (end2 len))
|
|
|
555 ((or (null word) (null start2)) start2)
|
|
|
556 (setq end2 (+ start2 len)
|
|
|
557 start2
|
|
|
558 (if delimiter
|
|
|
559 (position (elt pattern start1) string :start start2)
|
|
|
560 (when (and (<= end2 strlen)
|
|
|
561 (string= pattern string
|
|
|
562 :start1 start1 :end1 end1
|
|
|
563 :start2 start2 :end2 end2))
|
|
|
564 (1- end2))))
|
|
|
565 (when start2 (incf start2))))
|
|
|
566
|
|
|
567 ;;;
|
|
|
568 (defun ilisp-matching-symbols (string package &optional (function-p nil)
|
|
|
569 (external-p nil)
|
|
|
570 (prefix-p nil))
|
|
|
571 "Return a list of the symbols that have STRING as a prefix in
|
|
|
572 PACKAGE. FUNCTION-P indicates that only symbols with a function value
|
|
|
573 should be considered. EXTERNAL-P indicates that only external symbols
|
|
|
574 should be considered. PREFIX-P means that partial matches should not
|
|
|
575 be considered. The returned strings have the same case as the
|
|
|
576 original string."
|
|
|
577 (ilisp-errors
|
|
|
578 (let* ((lower-p (notany #'upper-case-p string))
|
|
|
579 (upper-p (notany #'lower-case-p string))
|
|
|
580 (no-casify (eq (ilisp-readtable-case *readtable*) :preserve))
|
|
|
581 (symbol-string (ilisp-symbol-name string))
|
|
|
582 (length (length string))
|
|
|
583 (results nil)
|
|
|
584 (*print-length* nil)
|
|
|
585 (*package* (ilisp-find-package package)))
|
|
|
586 (labels
|
|
|
587 (
|
|
|
588 ;; Check SYMBOL against PATTERN
|
|
|
589 (check-symbol (symbol pattern)
|
|
|
590 (let ((name (symbol-name symbol)))
|
|
|
591 (when (and (or (not function-p) (fboundp symbol))
|
|
|
592 (>= (length name) length)
|
|
|
593 (string= pattern name :end2 length))
|
|
|
594 (push (list (if no-casify
|
|
|
595 name
|
|
|
596 (ilisp-casify pattern name lower-p upper-p)))
|
|
|
597 results))))
|
|
|
598 ;; Check SYMBOL against PATTERN using WORDS
|
|
|
599 (check-symbol2 (symbol pattern words)
|
|
|
600 (let ((name (symbol-name symbol)))
|
|
|
601 (when (and (or (not function-p) (fboundp symbol))
|
|
|
602 (ilisp-match-words name pattern words))
|
|
|
603 (push (list (if no-casify
|
|
|
604 name
|
|
|
605 (ilisp-casify pattern name lower-p upper-p)))
|
|
|
606 results)))))
|
|
|
607 (if external-p
|
|
|
608 (do-external-symbols (symbol *package*)
|
|
|
609 (check-symbol symbol symbol-string))
|
|
|
610 (progn
|
|
|
611 ;; KCL does not go over used symbols.
|
|
|
612 #+(or kcl ibcl ecl)
|
|
|
613 (dolist (used-package (package-use-list *package*))
|
|
|
614 (do-external-symbols (symbol used-package)
|
|
|
615 (check-symbol symbol symbol-string)))
|
|
|
616 (do-symbols (symbol *package*)
|
|
|
617 (check-symbol symbol symbol-string))))
|
|
|
618 (unless (or results prefix-p)
|
|
|
619 (let ((words (ilisp-words symbol-string)))
|
|
|
620 (if external-p
|
|
|
621 (do-external-symbols (symbol *package*)
|
|
|
622 (check-symbol2 symbol symbol-string words))
|
|
|
623 (progn
|
|
|
624 ;; KCL does not go over used symbols.
|
|
|
625 #+(or kcl ibcl ecl)
|
|
|
626 (dolist (used-package (package-use-list *package*))
|
|
|
627 (do-external-symbols (symbol used-package)
|
|
|
628 (check-symbol2 symbol symbol-string words)))
|
|
|
629 (do-symbols (symbol *package*)
|
|
|
630 (check-symbol2 symbol symbol-string words))))))
|
|
|
631 (prin1 results)
|
|
|
632 nil))))
|
|
|
633
|
|
|
634
|
|
|
635 ;;; Make sure that functions are exported
|
|
|
636 ;;; Now this could go away. I just leave commented it for backup reasons.
|
|
|
637
|
|
|
638 #|
|
|
|
639 (dolist (symbol '(ilisp-errors ilisp-save ilisp-restore
|
|
|
640 ilisp-symbol-name ilisp-find-symbol ilisp-find-package
|
|
|
641 ilisp-eval ilisp-compile
|
|
|
642 ilisp-describe ilisp-inspect
|
|
|
643 ilisp-arglist ilisp-documentation
|
|
|
644 ilisp-macroexpand ilisp-macroexpand-1
|
|
|
645 ilisp-trace ilisp-untrace
|
|
|
646 ilisp-compile-file ilisp-casify
|
|
|
647 ilisp-matching-symbols))
|
|
|
648 (export symbol))
|
|
|
649 |#
|
|
|
650
|
|
|
651
|
|
|
652 (when
|
|
|
653 #+cmu (eval:interpreted-function-p #'ilisp-matching-symbols)
|
|
|
654 #-cmu (not (compiled-function-p #'ilisp-matching-symbols))
|
|
|
655 (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))
|
|
|
656
|
|
|
657 ;;; end of file -- clisp.lisp --
|
