Patch for finding the truename.

The following patch may be more baroque than necessary (it come from an 
OLD homegrown load system which has accumulated a fair degree of cruft 
over the years!). It does two things: 1. Under MCL, it allows systems 
to be defined by evaluating a buffer (instead of having to load them) 
and 2. It prints a warning message when the truename cannot be found -- 
rather than getting an error applying some function to nil later on.

Number 1 is handled because MCL has the variable 
ccl:*loading-file-source-file* which is the name of the currently 
active buffer. Number 2 is handled by adding an assertion. The code 
below defines load-truename and uses it in the defsystem macro. As I 
said above, a bunch of the conditionals in load-truename may be 
optional. I don't currently have a version of Lispworks, Allegro or 
other Lisps on which to test this.

(defun load-truename ()
   "Returns a pathname that is useful for merging with filenames to get a
complete pathname for a file in the same directory as the one currently 
being
loaded.  This function is a more portable version of the Common Lisp 
variable
*load-pathname*, since not all vendors implemented that correctly."
   (let ((pn   #+allegro (translate-logical-pathname (truename 
excl:*source-pathname*))
               #+MCL (cond (*load-pathname*
                            (translate-logical-pathname *load-pathname*))
                           (ccl:*loading-file-source-file*
                            ;; This makes it work in a fred buffer...
                            (translate-logical-pathname 
ccl:*loading-file-source-file*))
                           (t
                            nil))
               #+Lispworks (translate-logical-pathname *load-pathname*)
               #-(or allegro MCL Lispworks)
               (translate-logical-pathname *load-pathname*)))
     (assert (pathnamep pn) (pn)
             "load-pathname* did not return a pathname, it returned ~s;
this might be because it executed in a context where you're not loading 
a file
or because the file is in the current working directory.  In any event, 
this
will break the code in generic-load-utils, because it works with the 
components
of pathnames." pn)
     ;; Deal with the lispworks using an empty pathname for 
*default-pathname-defaults*
     ;; if you are loading from the current working directory.
     (values
      #-lispworks pn
      #+lispworks
      (if (null (pathname-directory pn))
        (merge-pathnames pn (current-pathname)) pn))))

(defmacro defsystem (name &body options)
   (destructuring-bind (&key pathname (class 'system) &allow-other-keys) 
options
     (let ((component-options (remove-keyword :class options)))
       `(progn
	 ;; system must be registered before we parse the body, otherwise
	 ;; we recur when trying to find an existing system of the same name
	 ;; to reuse options (e.g. pathname) from
	 (let ((s (system-registered-p ',name)))
	   (cond ((and s (eq (type-of (cdr s)) ',class))
		  (setf (car s) (get-universal-time)))
		 (s
		  #+clisp
		  (sysdef-error "Cannot redefine the existing system ~A with a 
different class" s)
		  #-clisp
		  (change-class (cdr s) ',class))
		 (t
		  (register-system (quote ,name)
				   (make-instance ',class :name ',name)))))
	 (parse-component-form nil (apply
				    #'list
				    :module (coerce-name ',name)
				    :pathname
				    (or ,pathname
				        (pathname-sans-name+type
					 (resolve-symlinks  (load-truename)))
				        *default-pathname-defaults*)
				    ',component-options))))))
-- 
Gary Warren King, Lab Manager
EKSL East, University of Massachusetts * 413 577 0176

The section heading ACKNOWLEDGMENTS (if present) is spelled without an 
"E" after the "G."
   -- Winter simulation author checklist