Re: Use of .lisp Extension

[donc@ISI.EDU (Don Cohen)]

My understanding is that this problem has recently been solved.
That is to say, you can avoid solving the problem yourself IF you
have a new enough version.  In particular, if the version is new
enough to have *source-file-types* defined, just do:

 (push (make-pathname :type "lisp") *source-file-types*)

Otherwise, the fix involves copying and modifying the source of load.
Here's my version:

#+clisp ; redefine load to allow different extensions to be found
(in-package :system)
#+clisp
(progn
 (defvar *load-types*
   (loop for x in '("lisp" "lsp" "fas") collect (make-pathname :type x)))

 (defun new-load (filename
             &key (verbose *load-verbose*) (print *load-print*)
	     (if-does-not-exist t) (echo *load-echo*) (compiling nil))
  (let ((stream
          (if (streamp filename)
            filename
            (or (open (setq filename (pathname filename))
                  :direction :input-immutable
                  :element-type 'string-char
                  :if-does-not-exist nil
                )
                ; Datei mit genau diesem Namen nicht vorhanden.
                ; Suche unter den Dateien mit demselben Namen und den
                ; Extensions "LSP", "FAS" die neueste:
                (let ((present-files
                        (search-file filename
				     ; '(#".lsp" #".fas")
				     *load-types*)))
                  (if (endp present-files)
                    nil
                    (open (setq filename (first present-files))
                          :direction :input-immutable
                          :element-type 'string-char  )) ) )   ) ) )
    (if stream
      (let ((input-stream
              (if echo
                (make-echo-stream stream *standard-output*)
                stream
            ) )
            ; :verbose, :print und :echo wirken nicht rekursiv - dazu
            ; hat man ja gerade die Special-Variablen *load-verbose* etc.
            ;(*load-verbose* verbose)
            ;(*load-print* print)
            ;(*load-echo* echo)
            (*load-pathname* (if (pathnamep filename) filename nil))
            (*load-truename* (if (pathnamep filename) (truename filename) nil))
            (*package* *package*) ; *PACKAGE* binden
            (*readtable* *readtable*) ; *READTABLE* binden
            (end-of-file "EOF")) ; einmaliges Objekt
        (when verbose
          (fresh-line)
          (write-string (DEUTSCH ";; Datei "
                         ENGLISH ";; Loading file "
                         FRANCAIS ";; Chargement du fichier ") )
          (princ filename)
          (write-string (DEUTSCH " wird geladen..."
                         ENGLISH " ..."
                         FRANCAIS " ...") ) )
        (block nil
          (unwind-protect
            (tagbody weiter
              (when echo (fresh-line))
              (let ((obj (read input-stream nil end-of-file)))
                (when (eql obj end-of-file) (return-from nil))
                (setq obj
                  (multiple-value-list
                    (cond ((compiled-function-p obj) (funcall obj))
                          (compiling (funcall (compile-form obj nil nil nil nil nil)))
                          (t (eval obj))  ) ) )
                (when print (when obj (print (first obj)))) )
              (go weiter) )
            (close stream) (close input-stream) ) )
        (when verbose
          (fresh-line)
          (write-string (DEUTSCH ";; Datei "
                         ENGLISH ";; Loading of file "
                         FRANCAIS ";; Le fichier ") )
          (princ filename)
          (write-string (DEUTSCH " ist geladen."
                         ENGLISH " is finished."
                         FRANCAIS " est chargi.") ) )
        t )
      (if if-does-not-exist
        (error-of-type 'file-error
          :pathname filename
          (DEUTSCH "Ein Datei mit Namen ~A gibt es nicht."
           ENGLISH "A file with name ~A does not exist"
           FRANCAIS "Il n'existe pas de fichier de nom ~A.")
          filename )
        nil )) ) )
 (setf (symbol-function 'load) (symbol-function 'new-load)))