[mcclim-cvs] CVS mcclim/Apps/Listener

tmoore tmoore at common-lisp.net
Wed Mar 15 22:56:55 UTC 2006


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




More information about the Mcclim-cvs mailing list