Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv7770/Apps/Listener

Modified Files: dev-commands.lisp file-types.lisp listener.lisp util.lisp Log Message: Patches from dtc for Scieneer Common Lisp, and a few other fixes too.

--- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2005/12/06 16:21:58 1.32 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/03/15 22:56:54 1.33 @@ -672,7 +672,8 @@ #+clisp (clos:specializer-direct-generic-functions specializer) #+openmcl-partial-mop (openmcl-mop:specializer-direct-generic-functions specializer) - #-(or PCL SBCL clisp openmcl-partial-mop) + #+scl (clos:specializer-direct-generic-functions specializer) + #-(or PCL SBCL scl clisp openmcl-partial-mop) (error "Sorry, not supported in your CL implementation. See the function X-SPECIALIZER-DIRECT-GENERIC-FUNCTION if you are interested in fixing this."))

(defun class-funcs (class) @@ -941,10 +942,10 @@ "Return the number of internal symbols in PACKAGE." ;; We take only the first value, the symbol count, and discard the second, the ;; hash table capacity - #+cmu (values (lisp::internal-symbol-count package)) + #+(or cmu scl) (values (lisp::internal-symbol-count package)) #+sbcl (values (sb-int:package-internal-symbol-count package)) #+clisp (svref (sys::%record-ref *package* 1) 2) - #-(or cmu sbcl clisp) (portable-internal-symbol-count package)) + #-(or cmu scl sbcl clisp) (portable-internal-symbol-count package))

(defun portable-external-symbol-count (package) (let ((n 0)) @@ -955,10 +956,10 @@

(defun count-external-symbols (package) "Return the number of external symbols in PACKAGE." - #+cmu (values (lisp::external-symbol-count package)) + #+(or cmu scl) (values (lisp::external-symbol-count package)) #+sbcl (values (sb-int:package-external-symbol-count package)) #+clisp (svref (sys::%record-ref *package* 0) 2) - #-(or cmu sbcl clisp) (portable-external-symbol-count package)) + #-(or cmu scl sbcl clisp) (portable-external-symbol-count package))

(defun package-grapher (stream package inferior-fun) "Draw package hierarchy graphs for `Show Package Users' and `Show Used Packages'." --- /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2005/08/31 05:50:37 1.8 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2006/03/15 22:56:54 1.9 @@ -181,7 +181,8 @@ (:icon (standard-icon "design.xpm")))

(define-mime-type (application x-lisp-fasl) - (:extensions "x86f" "fasl" "ibin" "dfsl" "ufsl") ; MORE! + (:extensions "x86f" "amd64f" "sparcf" "sparc64f" "hpf" "hp64f" "lbytef" + "fasl" "ibin" "dfsl" "ufsl") ; MORE! (:icon (standard-icon "object.xpm")))

(define-mime-type (text x-shellscript) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2005/12/06 16:21:11 1.22 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/03/15 22:56:54 1.23 @@ -72,16 +72,18 @@ (declare (ignore frame)) (let* ((*standard-output* pane) (username (or #+cmu (cdr (assoc :user ext:*environment-list*)) + #+scl (cdr (assoc "USER" ext:*environment-list* + :test 'string=)) #+allegro (sys:getenv "USER") - #-(or allegro cmu) (getenv "USER") + #-(or allegro cmu scl) (getenv "USER") "luser")) ; sorry.. (sitename (machine-instance)) - (memusage #+cmu (lisp::dynamic-usage) + (memusage #+(or cmu scl) (lisp::dynamic-space-usage) #+sbcl (sb-kernel:dynamic-usage) #+lispworks (getf (system:room-values) :total-allocated) #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) #+clisp (values (sys::%room)) - #-(or cmu sbcl lispworks openmcl clisp) 0)) + #-(or cmu scl sbcl lispworks openmcl clisp) 0)) (with-text-family (T :serif) (formatting-table (T :x-spacing '(3 :character)) (formatting-row (T) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2005/10/13 14:32:13 1.19 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2006/03/15 22:56:54 1.20 @@ -63,6 +63,7 @@ (defun getenv (var) (or #+cmu (cdr (assoc var ext:*environment-list*)) + #+scl (cdr (assoc var ext:*environment-list* :test #'string=)) #+sbcl (sb-ext:posix-getenv var) #+lispworks (lw:environment-variable var) #+openmcl (ccl::getenv var) @@ -73,6 +74,7 @@ (defun change-directory (pathname) "Ensure that the current directory seen by RUN-PROGRAM has changed, and update *default-pathname-defaults*" #+CMU (unix:unix-chdir (namestring pathname)) + #+scl (unix:unix-chdir (ext:unix-namestring pathname)) #+clisp (ext:cd pathname) ; SBCL FIXME? (setf *default-pathname-defaults* pathname)) @@ -85,7 +87,7 @@ ;;; LIST-DIRECTORY is a wrapper for the CL DIRECTORY function, which really doesn't ;;; do what I'd like (resolves symbolic links, tends to be horribly buggy, etc.)

-#+CMU +#+(or CMU scl) (defun list-directory (pathname) (directory pathname :truenamep nil))

@@ -143,7 +145,7 @@ (directory pathname :directories-are-files nil))

;; Fallback to ANSI CL -#-(OR CMU SBCL OPENMCL ALLEGRO) +#-(OR CMU scl SBCL OPENMCL ALLEGRO) (defun list-directory (pathname) (directory pathname))

@@ -167,8 +169,8 @@ ;;; (see above)

(defun run-program (program args &key (wait T) (output *standard-output*) (input *standard-input*)) - #+CMU (ext:run-program program args :input input - :output output :wait wait) + #+(or CMU scl) (ext:run-program program args :input input + :output output :wait wait)

#+SBCL (sb-ext:run-program program args :input input :search T :output output :wait wait) @@ -179,7 +181,7 @@ :wait wait) #+clisp (ext:run-program program :arguments args :wait wait)

- #-(or CMU SBCL lispworks clisp) + #-(or CMU scl SBCL lispworks clisp) (format T "~&Sorry, don't know how to run programs in your CL.~%"))

;;;; CLIM/UI utilities @@ -256,25 +258,23 @@

(defun gen-wild-pathname (pathname) "Build a pathname with appropriate :wild components for the directory listing." - (make-pathname :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (pathname-directory pathname) - :name (or (pathname-name pathname) :wild) + (make-pathname :name (or (pathname-name pathname) :wild) :type (or (pathname-type pathname) :wild) :version (or #+allegro :unspecific :wild ;#-SBCL (pathname-version pathname) ;#+SBCL :newest - ))) + ) + #+scl :query #+scl nil + :defaults pathname))

(defun strip-filespec (pathname) "Removes name, type, and version components from a pathname." - (make-pathname :host (pathname-host pathname) - :device (pathname-device pathname) - :directory (pathname-directory pathname) - :name nil + (make-pathname :name nil :type nil - :version nil)) + :version nil + #+scl :query #+scl nil + :defaults pathname))

;; Oops, should I be doing something with relative pathnames here? (defun parent-directory (pathname) @@ -282,12 +282,8 @@ (let ((dir (pathname-directory (truename (strip-filespec pathname))))) (when (and (eq (first dir) :absolute) (not (zerop (length (rest dir))))) - (make-pathname :host (pathname-host pathname) - :device (pathname-device pathname) - :directory `(:absolute ,@(nreverse (rest (reverse (rest dir))))) - :name (pathname-name pathname) - :type (pathname-type pathname) - :version (pathname-version pathname))))) + (make-pathname :directory `(:absolute ,@(nreverse (rest (reverse (rest dir))))) + :defaults pathname))))

;;;; Abbreviating item formatter