cgit.sxemacs.org Git - packages/blob - xemacs-packages/ilisp/cl-ilisp.lisp

   1 ;;; -*- Mode: Lisp -*-
   2
   3 ;;; cl-ilisp.lisp --
   4 ;;; Common Lisp initializations
   5 ;;; Author: Chris McConnell, ccm@cs.cmu.edu
   6 ;;;
   7 ;;; This file is part of ILISP.
   8 ;;; Please refer to the file COPYING for copyrights and licensing
   9 ;;; information.
  10 ;;; Please refer to the file ACKNOWLEGDEMENTS for an (incomplete) list
  11 ;;; of present and past contributors.
  12 ;;;
  13 ;;; $Id: cl-ilisp.lisp,v 1.6 2002-07-15 19:37:33 adrian Exp $
  14
  15
  16 ;;; Old history log.
  17 ;;;
  18 ;;; ange-ftp hack added by ivan Wed Mar 10 12:30:15 1993
  19 ;;; ilisp-errors *gc-verbose* addition ivan Tue Mar 16 03:21:51 1993
  20 ;;;
  21 ;;; Rcs_Info: clisp.lisp,v 1.26 1993/09/03 02:05:07 ivan Rel $
  22 ;;;
  23 ;;; Revision 1.19  1993/08/24  22:01:52  ivan
  24 ;;; Use defpackage instead of just IN-PACKAGE.
  25 ;;; Renamed FUNCTION to FUN in ilisp-arglist to get around CMUCL 17b bug.
  26 ;;;
  27 ;;; Revision 1.16  1993/06/29  05:51:35  ivan
  28 ;;; Added Ed Gamble's #'readtable-case fix and Hans Chalupsky's
  29 ;;; allegro-4.1 addition.
  30 ;;;
  31 ;;; Revision 1.8  1993/06/28  00:57:42  ivan
  32 ;;; Stopped using 'COMPILED-FUNCTION-P for compiled check.
  33 ;;;
  34 ;;; Revision 1.3  1993/03/16  23:22:10  ivan
  35 ;;; Added breakp arg to ilisp-trace.
  36 ;;;
  37 ;;;
  38
  39
  40 #+(or allegro-v4.0 allegro-v4.1)
  41 (eval-when (compile load eval)
  42   (setq excl:*cltl1-in-package-compatibility-p* t))
  43
  44
  45 (in-package :ilisp)
  46
  47 ;;;
  48 ;;; GCL 2.2 and GCL 2.3 do not have defpackage (yet) so we need to put
  49 ;;; the export here. (toy@rtp.ericsson.se)
  50 ;;;
  51 ;;; Please note that while the comment and the fix posted by R. Toy
  52 ;;; are correct, they are deprecated by at least one of the ILISP
  53 ;;; maintainers. :) By removing the 'nil' in the following #+, you
  54 ;;; will fix the problem.  However you are advised to install
  55 ;;; DEFPACKAGE in your GCL and to write the GCL maintainers and to ask
  56 ;;; them to incorporate DEFPACKAGE in their standard builds if this is
  57 ;;; not so yet.
  58
  59 ;;; 19960715 Marco Antoniotti
  60 ;;; 20010831 Marco Antoniotti
  61
  62 #+(or (and nil gcl))
  63 (export '(ilisp-errors
  64           ilisp-save
  65           ilisp-restore
  66           ilisp-symbol-name
  67           ilisp-find-symbol
  68           ilisp-find-package
  69           ilisp-eval
  70           ilisp-compile
  71           ilisp-describe
  72           ilisp-inspect
  73           ilisp-arglist
  74           ilisp-documentation
  75           ilisp-macroexpand
  76           ilisp-macroexpand-1
  77           ilisp-trace
  78           ilisp-untrace
  79           ilisp-compile-file
  80           ilisp-casify
  81           ilisp-print-info-message
  82           ilisp-matching-symbols))
  83
  84
  85 ;;;
  86 (defvar *ilisp-old-result* nil "Used for save/restore of top level values.")
  87
  88 (defvar *ilisp-message-addon-string* "ILISP:")
  89
  90 (defmacro the-symbol-if-defined (((if-symbol if-package)
  91                                   (&optional else-symbol else-package)
  92                                   &key eval-p)
  93                                  &body body)
  94   (let* ((sym-if (and (find-package if-package)
  95                       (find-symbol (symbol-name if-symbol)
  96                                    (find-package if-package))))
  97           (sym-else
  98            (unless sym-if
  99              (and else-symbol
 100                   (find-package else-package)
 101                   (find-symbol (symbol-name else-symbol)
 102                                (find-package else-package)))))
 103          (tmp-symbol (or sym-if sym-else)))
 104     (if (consp (first body))
 105       `(let ((the-symbol (symbol-value ',tmp-symbol)))
 106         ,@body)
 107       (if eval-p
 108         `,(eval tmp-symbol)
 109         `',tmp-symbol))))
 110
 111 (defmacro the-function-if-defined (((if-function if-package)
 112                                     (&optional else-function else-package)
 113                                     &key function-binding-p)
 114                                    &body body)
 115   (let* ((fun-if
 116            (ignore-errors
 117              (find-symbol (symbol-name if-function)
 118                           (find-package if-package))))
 119          (fun-else
 120            (unless fun-if
 121              (ignore-errors
 122                (and else-function
 123                     (find-symbol (symbol-name else-function)
 124                                  (find-package else-package)))))))
 125     (when (or fun-if fun-else)
 126       (if function-binding-p
 127         `(let ((the-function (symbol-function ',(or fun-if fun-else))))
 128           ,@body)
 129         `(,(or fun-if fun-else) ,@body)))))
 130
 131
 132 ;;; Martin Atzmueller 2000-01-15
 133 ;;; ilisp-message was mostly set up because Clisp expects an
 134 ;;; ~& or ~% before the message-string, otherwise it does not display anything!"
 135
 136 (defun ilisp-message (format-output-stream format-control-string &rest args)
 137   "ilisp-message provides an interface to create 'special' ILISP messages, i.e. \"ILISP: ... \" in an uniform way."
 138   (let* ((format-string (apply #'format nil " ~@?" format-control-string args))
 139          (concat-string (if (equal (char format-string 0) #\")
 140                             ""
 141                           (if format-output-stream
 142                               "\""
 143                             ""))))
 144     (format format-output-stream
 145             (concatenate 'string "~&" concat-string *ilisp-message-addon-string* format-string concat-string))))
 146
 147
 148 ;; MNA: ecl (ecls-0.5) still had special-form-p in COMMON-LISP,
 149 ;; which produced an error, when redefined.
 150 #+(and (or :CORMANLISP :ANSI-CL) (not :ecl))
 151 (defun special-form-p (symbol)
 152   "Backward compatibility for non ANSI CL's."
 153   (special-operator-p symbol))
 154
 155 #+(and :CLTL2 (not :ANSI-CL))
 156 (defun special-form-p (symbol)
 157   "For CLTL2 Lisp just use the old one."
 158   (lisp:special-form-p symbol))
 159 ;;;
 160 (defmacro ilisp-handler-case (expression &rest handlers)
 161   "Evaluate EXPRESSION using HANDLERS to handle errors."
 162   handlers
 163   (if (macro-function 'handler-case)
 164       `(handler-case ,expression ,@handlers)
 165       #+allegro `(excl::handler-case ,expression ,@handlers)
 166       #+lucid `(lucid::handler-case ,expression ,@handlers)
 167       #-(or allegro lucid) expression))
 168
 169
 170 ;;; ilisp-readtable-case --
 171 ;;;
 172 ;;; 19991218 Marco Antoniotti
 173 ;;; READTABLE-CASE is ANSI.  However, I feel magnanimous today, so I
 174 ;;; leave the check in to make it easier for non conforming
 175 ;;; implementations.
 176
 177 (defun ilisp-readtable-case (readtable)
 178   (if (fboundp 'readtable-case)
 179       (readtable-case readtable)
 180       #+allegro (case excl:*current-case-mode*
 181                   (:case-insensitive-upper :upcase)
 182                   (:case-insensitive-lower :downcase)
 183                   (otherwise :preserve))
 184       #-allegro :upcase))
 185
 186 ;;;
 187 (defmacro ilisp-errors (form)
 188   "Handle errors when evaluating FORM."
 189   `(let ((*standard-output* *terminal-io*)
 190          (*error-output* *terminal-io*)
 191          #+cmu
 192          (ext:*gc-verbose* nil) ; cmulisp outputs "[GC ...]" which
 193                                 ; doesn't read well...
 194          )
 195      (princ " ")                        ; Make sure we have output
 196
 197      ;; 19990912 Martin Atzmueller
 198      ;; Gross CLisp HS hack so that the command-index stays the same
 199      ;; after an ILISP-command that has to use the inferior lisp
 200      ;;
 201      ;; 19990912 Marco Antoniotti
 202      ;; Put here since the change is very localized and not requiring
 203      ;; a separate init file.
 204      #+:clisp
 205      (setq system::*command-index* (max 0 (- system::*command-index* 2)))
 206
 207      (ilisp-handler-case
 208       ,form
 209       (error (error)
 210              (ilisp-message nil "~A" error)))))
 211
 212
 213 ;;;
 214 (defun ilisp-save ()
 215   "Save the current state of the result history."
 216   (declare (special / // /// + ++ +++))
 217   (unless *ilisp-old-result*
 218     (setq *ilisp-old-result* (list /// // +++ ++ + /))))
 219
 220 ;;;
 221 (defun ilisp-restore ()
 222   "Restore the old result history."
 223   (declare (special / // + ++ * ** -))
 224
 225   (setq // (pop *ilisp-old-result*)
 226         ** (first //)
 227         /  (pop *ilisp-old-result*)
 228         *  (first /)
 229         ++  (pop *ilisp-old-result*)
 230         +   (pop *ilisp-old-result*)
 231         -   (pop *ilisp-old-result*))
 232
 233     ;; Martin Atzmueller 2000-01-26
 234     (let ((new/ (pop *ilisp-old-result*)))
 235       (if (some #'(lambda (new+)
 236                     (and (stringp new+)
 237                          (search *ilisp-message-addon-string* new+)))
 238                 new/)
 239           nil
 240         (values-list new/))))
 241
 242 ;;; ilisp-symbol-name --
 243 ;;;
 244 ;;; ':capitalize' case added under suggestion by Rich Mallory.
 245 (defun ilisp-symbol-name (symbol-name)
 246   "Return SYMBOL-NAME with the appropriate case as a symbol."
 247   (case (ilisp-readtable-case *readtable*)
 248     (:upcase (string-upcase symbol-name))
 249     (:downcase (string-downcase symbol-name))
 250     (:capitalize (string-capitalize symbol-name))
 251     (:preserve symbol-name)))
 252
 253
 254 ;;; ilisp-find-package --
 255 ;;;
 256 ;;; Notes:
 257 ;;; 19990806 Unknown Author (blame Marco Antoniotti for this)
 258 ;;; Added test for KEYWORD case.
 259
 260 (defun ilisp-find-package (package-name)
 261   "Return package PACKAGE-NAME or the current package."
 262   (cond ((string-equal package-name "nil") *package*)
 263         ((string-equal package-name "") (find-package "KEYWORD"))
 264         (t (or (find-package (ilisp-symbol-name package-name))
 265                (error "Package ~A not found" package-name)))))
 266
 267 ;;;
 268 (defun ilisp-find-symbol (symbol-name package-name)
 269   "Return the symbol associated with SYMBOL-NAME in PACKAGE-NAME.
 270 The trick is to try to handle print case issues intelligently."
 271   (find-symbol (ilisp-symbol-name symbol-name)
 272                (ilisp-find-package package-name)))
 273
 274
 275 ;;; The following two functions were in version 5.5.
 276 ;;; They disappeared in version 5.6. I am putting them back in the
 277 ;;; distribution in order to make use of them later if the need
 278 ;;; arises.
 279 ;;; Marco Antoniotti: Jan 2 1995
 280 #|
 281 (defun ilisp-filename-hack (filename)
 282   "Strip `/user@machine:' prefix from filename."
 283   ;; Ivan's hack for getting away with dumb /ivan@bu-conx:/foo/bar/baz
 284   ;; filenames...
 285   (let ((at-location (position #\@ filename))
 286         (colon-location (position #\: filename)))
 287     (if (and at-location colon-location)
 288         (subseq filename (1+ colon-location))
 289         filename)))
 290
 291
 292 (defun ilisp-read-form (form package)
 293   "Read string FORM in PACKAGE and return the resulting form."
 294   (let ((*package* (ilisp-find-package package)))
 295     (read-from-string form)))
 296 |#
 297
 298 ;;; 2000-09-29 11:28:36 rurban
 299 ;;; I needed this for XEmacs/cmd.exe/cormanlisp which swallows all my backslashes.
 300 ;;; Slashes do work fine on NT.
 301 (defun ilisp-w32-fix-filename (filename)
 302   "Pathslash hack: replace all '\\' by '/' in filenames.
 303 Convert cygwin paths also.
 304 This will only work on Microsoft NT, not on a Win95 based OS."
 305   ;; (setq filename "r:\\gnu\\XEMACS~1.35\\lisp\\replace.elc")
 306   ;; (setq filename "/cygdrive/r/xx") => "r:/"
 307   (do ((pos (position #\\ filename) (position #\\ filename)))
 308       ((null pos) filename)
 309     (setf (aref filename pos) #\/))
 310   (if (string-equal "/cygdrive/" (subseq filename 0 10))
 311       (setf filename (concatenate 'string (subseq filename 10 11) ":" (subseq filename 11)))
 312       filename))
 313
 314 ;;;
 315 (defun ilisp-eval (form package filename)
 316   "Evaluate FORM in PACKAGE recording FILENAME as the source file."
 317   (princ " ")
 318   ;; Ivan's hack for getting away with dumb /ivan@bu-conx:/foo/bar/baz
 319   ;; filenames...
 320   (let* ((at-location (position #\@ filename))
 321          (colon-location (position #\: filename))
 322          (filename
 323           (if (and at-location colon-location)
 324               (subseq filename (1+ colon-location))
 325               filename))
 326          #+:cormanlisp
 327          (filename (ilisp-w32-fix-filename filename))
 328          (*package* (ilisp-find-package package))
 329          #+allegro (excl::*source-pathname* filename)
 330          #+allegro (excl::*redefinition-warnings* nil)
 331          #+lucid (lucid::*source-pathname*
 332                   (if (probe-file filename)
 333                       (truename filename)
 334                       (merge-pathnames filename)))
 335          #+lucid (lucid::*redefinition-action* nil)
 336          #+lispworks (compiler::*input-pathname* (merge-pathnames filename))
 337          #+lispworks (compiler::*warn-on-non-top-level-defun* nil)
 338          ;; The LW entries are a mix of Rich Mallory and Jason
 339          ;; Trenouth suggestions
 340          ;; Marco Antoniotti: Jan 2 1995.
 341          )
 342     filename
 343     (eval (read-from-string form))))
 344
 345 ;;;
 346 (defun ilisp-compile (form package filename)
 347   "Compile FORM in PACKAGE recording FILENAME as the source file."
 348   (princ " ")
 349   ;; This makes sure that function forms are compiled
 350   ;; NOTE: Rich Mallory proposed a variation of the next piece of
 351   ;; code. for the time being we stick to the following simpler code.
 352   ;; Marco Antoniotti: Jan 2 1995.
 353   #-lucid
 354   (ilisp-eval
 355    (format nil "(funcall (compile nil '(lambda () ~A)))"
 356            form)
 357    package
 358    filename)
 359   #+lucid
 360   ;; Following form is a patch provided by Christopher Hoover
 361   ;; <ch@lks.csi.com>
 362   (let ((*package* (ilisp-find-package package))
 363         (lcl:*source-pathname* (if (probe-file filename)
 364                                    (truename filename)
 365                                  (merge-pathnames filename)))
 366         (lcl:*redefinition-action* nil))
 367     (with-input-from-string (s form)
 368                             (lucid::compile-in-core-from-stream s)
 369                             (values)))
 370   )
 371
 372 ;;;
 373 (defun ilisp-describe (sexp package)
 374   "Describe SEXP in PACKAGE."
 375   (ilisp-errors
 376    (let ((*package* (ilisp-find-package package)))
 377      (let ((item-to-be-described (read-from-string sexp)))
 378        (if (atom item-to-be-described)
 379            (describe item-to-be-described)
 380            (describe (eval item-to-be-described)))))))
 381
 382 ;;;
 383 (defun ilisp-inspect (sexp package)
 384   "Inspect SEXP in PACKAGE."
 385   (ilisp-errors
 386    (let ((*package* (ilisp-find-package package)))
 387     (let ((item-to-be-described (read-from-string sexp)))
 388        (if (atom item-to-be-described)
 389            (inspect item-to-be-described)
 390            (inspect (eval item-to-be-described)))))))
 391
 392 ;;;
 393 (defun ilisp-arglist (symbol package)
 394   "Returns the argument list of SYMBOL from PACKAGE."
 395   (ilisp-errors
 396     (let ((fn (ilisp-find-symbol symbol package))
 397           (*print-length* nil)
 398           (*print-pretty* t)
 399           (*package* (ilisp-find-package package)))
 400       (cond ((null fn)
 401              (format t "Symbol ~s not present in ~s." symbol package))
 402             ((not (fboundp fn))
 403              (format t "~s: undefined~%" fn))
 404             (t
 405              (print-function-arglist fn)))))
 406   (values))
 407
 408
 409 ;;; print-function-arglist --
 410 ;;; This function is really invoked only by the #\Space binding of
 411 ;;; ILISP-PRINT-INFO-MESSAGE.
 412
 413 ;;; 19991218 Marco Antoniotti
 414 ;;; Unfortunately the function GET-FUNCTION-ARGLIST may default to
 415 ;;; DOCUMENTATION, which returns a string.  Hence the change.
 416 ;;;
 417 ;;; 19991218 Marco Antoniotti
 418 ;;; Using the arglist command bound to #\Space would probably be
 419 ;;; better.  Anyway...
 420
 421 (defun print-function-arglist (fn)
 422   "Pretty arglist printer"
 423   (let* ((arglist-doc (get-function-arglist fn))
 424          (desc (ilisp-function-short-description fn)))
 425     (format t "~&~s~a" fn (or desc ""))
 426     (write-string ": ")
 427     (typecase arglist-doc
 428       (string (write-string arglist-doc))
 429       (list (let ((arglist (ldiff arglist-doc
 430                                   (member '&aux arglist-doc))))
 431               (if arglist
 432                   (write arglist :case :downcase :escape nil)
 433                   (write-string "()"))))
 434       (t (error (ilisp-message nil
 435                                "arglist doc very messed up [~S]."
 436                                arglist-doc))))
 437     (terpri)
 438     (values)))
 439
 440 (defun ilisp-generic-function-p (symbol)
 441   (let ((generic-p
 442          (find-symbol "GENERIC-FUNCTION-P"
 443                       (or (find-package "PCL")
 444                           *package*))))
 445     (and generic-p
 446          (fboundp generic-p)
 447          (funcall generic-p symbol))))
 448
 449
 450
 451 (defun ilisp-function-short-description (symbol)
 452   (cond ((macro-function symbol)
 453          " (Macro)")
 454         ((special-form-p symbol)
 455          " (Special Form)")
 456         ((ilisp-generic-function-p symbol)
 457          " (Generic)")))
 458
 459
 460
 461 (defun get-function-arglist (symbol)
 462   (let ((fun (symbol-function symbol)))
 463     (cond ((ilisp-generic-function-p symbol)
 464            (funcall
 465             (find-symbol "GENERIC-FUNCTION-PRETTY-ARGLIST"
 466                          (or (find-package "PCL") *package*))
 467             fun))
 468           (t
 469            #+allegro
 470            (excl::arglist symbol)
 471
 472            #+(or ibcl kcl gcl)
 473            (help symbol)
 474
 475            #+:ecl
 476             (si::help symbol)
 477
 478            #+lucid
 479            (lucid::arglist symbol)
 480
 481            #+lispworks
 482            (system::function-lambda-list symbol)
 483
 484            #+clisp
 485            (arglist symbol)
 486
 487            #+cmu
 488            (arglist symbol (symbol-package symbol))
 489
 490            #+:sbcl
 491            (arglist symbol (symbol-package symbol))
 492
 493            #+:openmcl
 494            (arglist symbol (symbol-package symbol))
 495
 496            #-(or allegro lucid kcl ibcl ecl gcl lispworks clisp cmu :sbcl :openmcl)
 497            (documentation symbol 'function)))))
 498
 499
 500 (defun ilisp-print-info-message (symbol package)
 501   "Returns the argument list or the value of SYMBOL from PACKAGE.
 502 Error messages are generated appropriately."
 503   (ilisp-errors
 504    (let ((real-symbol (ilisp-find-symbol symbol package))
 505          (*print-length* nil)
 506          (*print-level* nil)
 507          (*package* (ilisp-find-package package)))
 508      (cond ((null real-symbol)
 509             (format t "")
 510             ;; (ilisp-message t "symbol ~S not present in ~S." symbol package)
 511             (values))
 512            ((special-form-p real-symbol)
 513             (format t "~S: special-operator." real-symbol)
 514             (values))
 515            ((fboundp real-symbol)
 516             (print-function-arglist real-symbol))
 517            ((ignore-errors (boundp real-symbol))
 518             (format t "~S is bound to ~S."
 519                     real-symbol (symbol-value real-symbol))
 520             (values))
 521            (t
 522             (format t "Symbol ~S is unbound." real-symbol)
 523             (values))))))
 524
 525
 526 ;;;
 527 (defun ilisp-documentation (symbol package type)
 528   "Return the TYPE documentation for SYMBOL in PACKAGE.
 529 If TYPE is \(qualifiers* (class ...)), the appropriate method will be found."
 530   (ilisp-errors
 531    (let* ((real-symbol (ilisp-find-symbol symbol package))
 532           (type (if (and (not (zerop (length type)))
 533                          (eq (elt type 0) #\())
 534                     (let ((*package* (ilisp-find-package package)))
 535                       (read-from-string type))
 536                     (ilisp-find-symbol type package))))
 537      (when (listp type)
 538        (setq real-symbol
 539              (funcall
 540               (find-symbol "FIND-METHOD" (or (find-package "CLOS")
 541                                              (find-package "PCL")
 542                                              *package*))
 543               (symbol-function real-symbol)
 544               (reverse
 545                (let ((quals nil))
 546                  (dolist (entry type quals)
 547                    (if (listp entry)
 548                        (return quals)
 549                        (setq quals (cons entry quals))))))
 550               (reverse
 551                (let ((types nil))
 552                  (dolist (class (first (last type)) types)
 553                    (setq types
 554                          (cons (funcall
 555                                 (find-symbol "FIND-CLASS"
 556                                              (or (find-package "CLOS")
 557                                                  (find-package "PCL")
 558                                                  *package*))
 559                                 class) types))))))))
 560      (if real-symbol
 561          (if (symbolp real-symbol)
 562              (documentation real-symbol type)
 563              ;; Prevent compiler complaints
 564              (eval `(documentation ,real-symbol)))
 565          (format nil "~A has no ~A documentation" symbol type)))))
 566
 567 ;;;
 568 (defun ilisp-macroexpand (expression package)
 569   "Macroexpand EXPRESSION as long as the top level function is still a macro."
 570   (ilisp-errors
 571    (let ((*print-length* nil)
 572          (*print-level* nil)
 573          (*package* (ilisp-find-package package)))
 574      (pprint (#-allegro macroexpand #+allegro excl::walk
 575                         (read-from-string expression))))))
 576
 577 ;;;
 578 (defun ilisp-macroexpand-1 (expression package)
 579   "Macroexpand EXPRESSION once."
 580   (ilisp-errors
 581    (let ((*print-length* nil)
 582          (*print-level* nil)
 583          (*package* (ilisp-find-package package)))
 584      (pprint (macroexpand-1 (read-from-string expression))))))
 585
 586
 587 (defun ilisp-trace (symbol package breakp)
 588   "Trace SYMBOL in PACKAGE."
 589   (declare (ignore breakp)) ; No way to do this in CL.
 590   (ilisp-errors
 591    (let ((real-symbol (ilisp-find-symbol symbol package)))
 592      (when real-symbol (eval `(trace ,real-symbol))))))
 593
 594
 595 (defun ilisp-untrace (symbol package)
 596   "Untrace SYMBOL in PACKAGE."
 597   (ilisp-errors
 598    (let ((real-symbol (ilisp-find-symbol symbol package)))
 599      (when real-symbol (eval `(untrace ,real-symbol))))))
 600
 601
 602 ;;; ilisp-compile-file-extension --
 603 ;;;
 604 ;;; 19990806 Marco Antoniotti
 605
 606 (defun ilisp-compile-file-extension ()
 607   (pathname-type (compile-file-pathname "ilisp-foo")))
 608
 609
 610 ;;;
 611 (defun ilisp-compile-file (file extension)
 612   "Compile FILE putting the result in FILE+EXTENSION."
 613   (ilisp-errors
 614    (compile-file file
 615                  :output-file
 616                  (merge-pathnames (make-pathname :type extension) file))))
 617
 618 ;;;
 619 (defun ilisp-casify (pattern string lower-p upper-p)
 620   "Return STRING with its characters converted to the case of PATTERN.
 621 It continues with the 'last case' beyond the end."
 622   (cond (lower-p (string-downcase string))
 623         (upper-p (string-upcase string))
 624         (t
 625          (let (case)
 626            (concatenate
 627             'string
 628             (map 'string
 629                  #'(lambda (p s)
 630                      (setq case (if (upper-case-p p)
 631                                     #'char-upcase
 632                                     #'char-downcase))
 633                      (funcall case s))
 634                  pattern string)
 635             (map 'string case (subseq string (length pattern))))))))
 636
 637 ;;;
 638 (defun ilisp-words (string)
 639   "Return STRING broken up into words.
 640 Each word is (start end delimiter)."
 641   (do* ((length (length string))
 642         (start 0)
 643         (end t)
 644         (words nil))
 645        ((null end) (nreverse words))
 646     (if (setq end (position-if-not #'alphanumericp string :start start))
 647         (setq words (cons (list end (1+ end) t)
 648                           (if (= start end)
 649                               words
 650                               (cons (list start end nil) words)))
 651               start (1+ end))
 652         (setq words (cons (list start length nil) words)))))
 653
 654 ;;;
 655 (defun ilisp-match-words (string pattern words)
 656   "Match STRING to PATTERN using WORDS."
 657   (do* ((strlen (length string))
 658         (words words (cdr words))
 659         (word (first words) (first words))
 660         (start1 (first word) (first word))
 661         (end1 (second word) (second word))
 662         (delimiter (third word) (third word))
 663         (len (- end1 start1) (and word (- end1 start1)))
 664         (start2 0)
 665         (end2 len))
 666        ((or (null word) (null start2)) start2)
 667     (setq end2 (+ start2 len)
 668           start2
 669           (if delimiter
 670               (position (elt pattern start1) string :start start2)
 671               (when (and (<= end2 strlen)
 672                          (string= pattern string
 673                                   :start1 start1 :end1 end1
 674                                   :start2 start2 :end2 end2))
 675                 (1- end2))))
 676     (when start2 (incf start2))))
 677
 678 ;;;
 679 (defun ilisp-matching-symbols (string package
 680                                       &optional
 681                                       (function-p nil)
 682                                       (external-p nil)
 683                                       (prefix-p nil))
 684   "Return a list of the symbols that have STRING as a prefix in PACKAGE.
 685 FUNCTION-P indicates that only symbols with a function value
 686 should be considered.  EXTERNAL-P indicates that only external symbols
 687 should be considered.  PREFIX-P means that partial matches should not
 688 be considered.  The returned strings have the same case as the
 689 original string."
 690   (ilisp-errors
 691    (let* ((lower-p (notany #'upper-case-p string))
 692           (upper-p (notany #'lower-case-p string))
 693           (no-casify (eq (ilisp-readtable-case *readtable*) :preserve))
 694           (symbol-string (ilisp-symbol-name string))
 695           (length (length string))
 696           (results nil)
 697           (*print-length* nil)
 698           (*package* (ilisp-find-package package)))
 699      (labels
 700          (
 701           ;; Check SYMBOL against PATTERN
 702           (check-symbol (symbol pattern)
 703             (let ((name (symbol-name symbol)))
 704               (when (and (or (not function-p) (fboundp symbol))
 705                          (>= (length name) length)
 706                          (string= pattern name :end2 length))
 707                 (push (list (if no-casify
 708                                 name
 709                                 (ilisp-casify pattern name lower-p upper-p)))
 710                       results))))
 711           ;; Check SYMBOL against PATTERN using WORDS
 712           (check-symbol2 (symbol pattern words)
 713             (let ((name (symbol-name symbol)))
 714               (when (and (or (not function-p) (fboundp symbol))
 715                          (ilisp-match-words name pattern words))
 716                 (push (list (if no-casify
 717                                 name
 718                                 (ilisp-casify pattern name lower-p upper-p)))
 719                       results)))))
 720        (if external-p
 721            (do-external-symbols (symbol *package*)
 722              (check-symbol symbol symbol-string))
 723            (progn
 724              ;; KCL does not go over used symbols.
 725              #+(or kcl ibcl ecl)
 726              (dolist (used-package (package-use-list *package*))
 727                (do-external-symbols (symbol used-package)
 728                  (check-symbol symbol symbol-string)))
 729              (do-symbols (symbol *package*)
 730                (check-symbol symbol symbol-string))))
 731        (unless (or results prefix-p)
 732          (let ((words (ilisp-words symbol-string)))
 733            (if external-p
 734                (do-external-symbols (symbol *package*)
 735                  (check-symbol2 symbol symbol-string words))
 736                (progn
 737                  ;; KCL does not go over used symbols.
 738                  #+(or kcl ibcl ecl)
 739                  (dolist (used-package (package-use-list *package*))
 740                    (do-external-symbols (symbol used-package)
 741                      (check-symbol2 symbol symbol-string words)))
 742                  (do-symbols (symbol *package*)
 743                    (check-symbol2 symbol symbol-string words))))))
 744        ;; 19990806 Unknown Author (blame Marco Antoniotti for this)
 745        ;; () doesn't depend on *PACKAGE*
 746        ;;
 747        ;; (prin1 results)
 748        (if results (prin1 results) (princ "()"))
 749        nil))))
 750
 751 #-:cormanlisp
 752 (eval-when (load eval)
 753   (when
 754       #+(and :CMU (or :CMU17 :CMU18))
 755       (eval:interpreted-function-p #'ilisp-matching-symbols)
 756       #-(and :CMU (or :CMU17 :CMU18))
 757       (not (compiled-function-p #'ilisp-matching-symbols))
 758       (ilisp-message *standard-output*
 759                      "File is not compiled, use M-x ilisp-compile-inits")))
 760
 761
 762 ;;; end of file -- cl-ilisp.lisp --