Mercurial > hg > xemacs-beta

comparison lisp/ilisp/cl-ilisp.lisp @ 4:b82b59fe008d r19-15b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b3
author cvs
date Mon, 13 Aug 2007 08:46:56 +0200
parents
children
comparison
equal deleted inserted replaced
3:30df88044ec6 4:b82b59fe008d
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 --