Mercurial > hg > xemacs-beta

comparison lisp/ilisp/clisp.lisp @ 8:4b173ad71786 r19-15b5

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b5
author cvs
date Mon, 13 Aug 2007 08:47:35 +0200
parents 376386a54a3c
children
comparison
equal deleted inserted replaced
7:c153ca296910 8:4b173ad71786
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 --