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