Index: defsystem.lisp
===================================================================
RCS file: /cvsroot/clocc/clocc/src/defsystem-3.x/defsystem.lisp,v
retrieving revision 1.102
diff -c -r1.102 defsystem.lisp
*** defsystem.lisp	5 Sep 2005 18:39:21 -0000	1.102
--- defsystem.lisp	25 Feb 2006 00:34:55 -0000
***************
*** 886,892 ****
  	      (fboundp 'system::require))
  
      #-:lispworks
!     (in-package "LISP")
      #+:lispworks
      (in-package "SYSTEM")
  
--- 886,892 ----
  	      (fboundp 'system::require))
  
      #-:lispworks
!     (in-package :lisp)
      #+:lispworks
      (in-package "SYSTEM")
  
***************
*** 1024,1030 ****
  ;;; The code below, is originally executed also for CMUCL. However I
  ;;; believe this is wrong, since CMUCL comes with its own defpackage.
  ;;; I added the extra :CMU in the 'or'.
! #+(and :cltl2 (not (or :cmu :clisp :sbcl
  		       (and :excl (or :allegro-v4.0 :allegro-v4.1))
  		       :mcl)))
  (eval-when (compile load eval)
--- 1024,1030 ----
  ;;; The code below, is originally executed also for CMUCL. However I
  ;;; believe this is wrong, since CMUCL comes with its own defpackage.
  ;;; I added the extra :CMU in the 'or'.
! #+(and :cltl2 (not (or :cmu :scl :clisp :sbcl
  		       (and :excl (or :allegro-v4.0 :allegro-v4.1))
  		       :mcl)))
  (eval-when (compile load eval)
***************
*** 1047,1053 ****
  
  #+(or :cltl2 :lispworks :scl)
  (eval-when (compile load eval)
!   (in-package "MAKE"))
  
  #+ecl
  (in-package "MAKE")
--- 1047,1053 ----
  
  #+(or :cltl2 :lispworks :scl)
  (eval-when (compile load eval)
!   (in-package :make))
  
  #+ecl
  (in-package "MAKE")
***************
*** 1172,1192 ****
  #|
  #-(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
  (eval-when (compile load eval)
!   (import *exports* #-(or :cltl2 :lispworks) "USER"
! 	            #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
!   (import *special-exports* #-(or :cltl2 :lispworks) "USER"
! 	                    #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
  #+(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
  (eval-when (compile load eval)
!   (import *exports* #-(or :cltl2 :lispworks) "USER"
! 	            #+(or :cltl2 :lispworks) "COMMON-LISP-USER")
    (shadowing-import *special-exports*
! 		    #-(or :cltl2 :lispworks) "USER"
! 		    #+(or :cltl2 :lispworks) "COMMON-LISP-USER"))
  |#
  
! #-(or :PCL :CLOS :scl)
! (when (find-package "PCL")
    (pushnew :pcl *modules*)
    (pushnew :pcl *features*))
  
--- 1172,1192 ----
  #|
  #-(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
  (eval-when (compile load eval)
!   (import *exports* #-(or :cltl2 :lispworks) :user
! 	            #+(or :cltl2 :lispworks) :common-lisp-user)
!   (import *special-exports* #-(or :cltl2 :lispworks) :user
! 	                    #+(or :cltl2 :lispworks) :common-lisp-user))
  #+(or :sbcl :cmu :ccl :allegro :excl :lispworks :symbolics)
  (eval-when (compile load eval)
!   (import *exports* #-(or :cltl2 :lispworks) :user
! 	            #+(or :cltl2 :lispworks) :common-lisp-user)
    (shadowing-import *special-exports*
! 		    #-(or :cltl2 :lispworks) :user
! 		    #+(or :cltl2 :lispworks) :common-lisp-user))
  |#
  
! #-(or :pcl :clos :scl)
! (when (find-package :pcl)
    (pushnew :pcl *modules*)
    (pushnew :pcl *features*))
  
***************
*** 1203,1209 ****
  ;;; ********************************
  
  (defvar *dont-redefine-require*
!   #+cmu (if (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" "EXT") t nil)
    #+(or clisp sbcl) t
    #+allegro t
    #-(or cmu sbcl clisp allegro) nil
--- 1203,1209 ----
  ;;; ********************************
  
  (defvar *dont-redefine-require*
!   #+cmu (if (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :ext) t nil)
    #+(or clisp sbcl) t
    #+allegro t
    #-(or cmu sbcl clisp allegro) nil
***************
*** 1231,1238 ****
  #-cormanlisp
  (defun home-subdirectory (directory)
    (concatenate 'string
! 	#+(or :sbcl :cmu :scl)
  	"home:"
  	#-(or :sbcl :cmu :scl)
  	(let ((homedir (user-homedir-pathname)))
  	  (or (and homedir (namestring homedir))
--- 1231,1239 ----
  #-cormanlisp
  (defun home-subdirectory (directory)
    (concatenate 'string
! 	#+(or :sbcl :cmu)
  	"home:"
+ 	#+scl "file://home/"
  	#-(or :sbcl :cmu :scl)
  	(let ((homedir (user-homedir-pathname)))
  	  (or (and homedir (namestring homedir))
***************
*** 1436,1442 ****
  	 ;; PA is Precision Architecture, HP's 9000/800 RISC cpu
  	 #+(and Lucid PA)		      ("lisp" . "hbin")
           #+excl ("cl"   . ,(pathname-type (compile-file-pathname "foo.cl")))
!          #+(or :cmu :scl)  ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
  ;	 #+(and :CMU (not (or :sgi :sparc)))  ("lisp" . "fasl")
  ;        #+(and :CMU :sgi)                    ("lisp" . "sgif")
  ;        #+(and :CMU :sparc)                  ("lisp" . "sparcf")
--- 1437,1443 ----
  	 ;; PA is Precision Architecture, HP's 9000/800 RISC cpu
  	 #+(and Lucid PA)		      ("lisp" . "hbin")
           #+excl ("cl"   . ,(pathname-type (compile-file-pathname "foo.cl")))
!          #+(or cmu scl) ("lisp" . ,(or (c:backend-fasl-file-type c:*backend*) "fasl"))
  ;	 #+(and :CMU (not (or :sgi :sparc)))  ("lisp" . "fasl")
  ;        #+(and :CMU :sgi)                    ("lisp" . "sgif")
  ;        #+(and :CMU :sparc)                  ("lisp" . "sparcf")
***************
*** 1719,1724 ****
--- 1720,1728 ----
  (machine-type-translation "PC/386"                           "x86")
  ;;; CLisp Win32
  
+ ;;; SCL.
+ (machine-type-translation "AMD64"                            "amd64")
+ 
  #+(and :lucid :sun :mc68000)
  (machine-type-translation "unknown"     "sun3")
  
***************
*** 1766,1772 ****
  (defun compiler-type-translation (name &optional operation)
    (if operation
        (setf (gethash (string-upcase name) *compiler-type-alist*) operation)
!     (gethash (string-upcase name) *compiler-type-alist*)))
  
  
  (compiler-type-translation "lispworks 3.2.1"         "lispworks")
--- 1770,1776 ----
  (defun compiler-type-translation (name &optional operation)
    (if operation
        (setf (gethash (string-upcase name) *compiler-type-alist*) operation)
!       (gethash (string-upcase name) *compiler-type-alist*)))
  
  
  (compiler-type-translation "lispworks 3.2.1"         "lispworks")
***************
*** 1800,1805 ****
--- 1804,1814 ----
  (compiler-type-translation "cmu 17e" "cmu")
  (compiler-type-translation "cmu 17d" "cmu")
  
+ (compiler-type-translation "scl 1.2.7" "scl")
+ (compiler-type-translation "scl 1.2.8" "scl")
+ (compiler-type-translation "scl 1.2.9" "scl")
+ (compiler-type-translation "scl 1.2.10" "scl")
+ 
  
  ;;; ********************************
  ;;; System Names *******************
***************
*** 1897,1902 ****
--- 1906,1912 ----
  ;;;       "[root.][subdir]BAZ"
  ;;; Use #+:vaxlisp for VAXLisp 3.0, #+(and vms dec common vax) for v2.2
  
+ #-scl
  (defun new-append-directories (absolute-dir relative-dir)
    ;; Version of append-directories for CLtL2-compliant lisps. In particular,
    ;; they must conform to section 23.1.3 "Structured Directories". We are
***************
*** 1984,1990 ****
  		    #+(or :sbcl :MCL :clisp) rel-type
  		    ))))
  
! 
  (defun directory-to-list (directory)
    ;; The directory should be a list, but nonstandard implementations have
    ;; been known to use a vector or even a string.
--- 1994,2000 ----
  		    #+(or :sbcl :MCL :clisp) rel-type
  		    ))))
  
! #-scl
  (defun directory-to-list (directory)
    ;; The directory should be a list, but nonstandard implementations have
    ;; been known to use a vector or even a string.
***************
*** 2057,2063 ****
  
  ||#
  
- 
  (defun append-directories (absolute-directory relative-directory)
    "There is no CL primitive for tacking a subdirectory onto a directory.
     We need such a function because defsystem has both absolute and
--- 2067,2072 ----
***************
*** 2082,2091 ****
  	    relative-directory)
         ;; For use with logical pathnames package.
         (append-logical-directories-mk absolute-directory relative-directory))
!      |#
        ((namestring-probably-logical absolute-directory)
         ;; A simplistic stab at handling logical pathnames
         (append-logical-pnames absolute-directory relative-directory))
        (t
         ;; In VMS, merge-pathnames actually does what we want!!!
         #+:VMS
--- 2091,2102 ----
  	    relative-directory)
         ;; For use with logical pathnames package.
         (append-logical-directories-mk absolute-directory relative-directory))
!       |#
!       #-scl
        ((namestring-probably-logical absolute-directory)
         ;; A simplistic stab at handling logical pathnames
         (append-logical-pnames absolute-directory relative-directory))
+       #-scl
        (t
         ;; In VMS, merge-pathnames actually does what we want!!!
         #+:VMS
***************
*** 2096,2102 ****
  				  :name relative-directory))
         ;; Cross your fingers and pray.
         #-(or :VMS :macl1.3.2)
!        (new-append-directories absolute-directory relative-directory)))))
  
  
  #+:logical-pathnames-mk
--- 2107,2127 ----
  				  :name relative-directory))
         ;; Cross your fingers and pray.
         #-(or :VMS :macl1.3.2)
!        (new-append-directories absolute-directory relative-directory))
!       #+scl
!       (t
!        (let ((absolute (pathname (or absolute-directory ""))))
! 	 (when (or (pathname-name absolute) (pathname-type absolute))
! 	   (let* ((directory (or (pathname-directory absolute) '(:relative)))
! 		  (directory (append directory (list (file-namestring absolute)))))
! 	     (setf absolute (make-pathname :directory directory
! 					   :name nil
! 					   :type nil
! 					   :version nil
! 					   :defaults absolute))))
! 	 (ext:resolve-pathname (or relative-directory "")
! 			       absolute))))))
!       
  
  
  #+:logical-pathnames-mk
***************
*** 2181,2186 ****
--- 2206,2212 ----
  (defun logical-pathname-p (thing)
    (typep (parse-namestring thing) 'logical-pathname))
  
+ #-scl
  (defun pathname-logical-p (thing)
    (typecase thing
      (logical-pathname t)
***************
*** 2195,2200 ****
--- 2221,2227 ----
  ;;; 19990707 Marco Antoniotti
  ;;; old version
  
+ #-scl
  (defun namestring-probably-logical (namestring)
    (and (stringp namestring)
         ;; unix pathnames don't have embedded semicolons
***************
*** 2234,2239 ****
--- 2261,2267 ----
  ||#
  
  
+ #-scl
  (defun append-logical-pnames (absolute relative)
    (declare (type (or null string pathname) absolute relative))
    (let ((abs (if absolute
***************
*** 2317,2325 ****
  
  ||#
  
- ;;; The following is a change proposed by DTC for SCL.
- ;;; Maybe it could be used all the time.
- 
  #-scl
  (defun new-file-type (pathname type)
    ;; why not (make-pathname :type type :defaults pathname)?
--- 2345,2350 ----
***************
*** 2331,2348 ****
     :type type
     :version (pathname-version pathname)))
  
- 
  #+scl
  (defun new-file-type (pathname type)
!   ;; why not (make-pathname :type type :defaults pathname)?
!   (make-pathname
!    :host (pathname-host pathname :case :common)
!    :device (pathname-device pathname :case :common)
!    :directory (pathname-directory pathname :case :common)
!    :name (pathname-name pathname :case :common)
!    :type (string-upcase type)
!    :version (pathname-version pathname :case :common)))
! 
  
  
  ;;; ********************************
--- 2356,2364 ----
     :type type
     :version (pathname-version pathname)))
  
  #+scl
  (defun new-file-type (pathname type)
!   (make-pathname :type type :defaults pathname))
  
  
  ;;; ********************************
***************
*** 2547,2553 ****
  	    (when path
  	      (gethash path *file-load-time-table*)))))))))
  
! #-(or :cmu)
  (defsetf component-load-time (component) (value)
    `(when ,component
      (etypecase ,component
--- 2563,2569 ----
  	    (when path
  	      (gethash path *file-load-time-table*)))))))))
  
! #-(or :cmu :scl)
  (defsetf component-load-time (component) (value)
    `(when ,component
      (etypecase ,component
***************
*** 2572,2578 ****
  		    ,value)))))))
      ,value))
  
! #+(or :cmu)
  (defun (setf component-load-time) (value component)
    (declare
     (type (or null string pathname component) component)
--- 2588,2594 ----
  		    ,value)))))))
      ,value))
  
! #+(or :cmu :scl)
  (defun (setf component-load-time) (value component)
    (declare
     (type (or null string pathname component) component)
***************
*** 2933,2939 ****
      ;; Added COMPONENT-NAME extraction to :NAME part, in case the
      ;; PATHNAME-NAME is NIL.
  
!     (cond ((pathname-logical-p pathname) ; See definition of test above.
  	   (setf pathname
  		 (merge-pathnames pathname
  				  (make-pathname
--- 2949,2956 ----
      ;; Added COMPONENT-NAME extraction to :NAME part, in case the
      ;; PATHNAME-NAME is NIL.
  
!     (cond #-scl
! 	  ((pathname-logical-p pathname) ; See definition of test above.
  	   (setf pathname
  		 (merge-pathnames pathname
  				  (make-pathname
***************
*** 2941,2967 ****
  				   :type (component-extension component
  							      type))))
  	   (namestring (translate-logical-pathname pathname)))
  	  (t
  	   (namestring
  	    (make-pathname :host (or (component-host component)
  				     (pathname-host pathname))
  
! 			   :directory (pathname-directory pathname
! 							  #+scl :case
! 							  #+scl :common
! 							  )
! 
! 			   :name (or (pathname-name pathname
!                                                     #+scl :case
!                                                     #+scl :common
!                                                     )
                                       (component-name component))
  
! 			   :type
! 			   #-scl (component-extension component type)
! 			   #+scl (string-upcase
! 				  (component-extension component type))
! 
  			   :device
  			   #+sbcl
  			   :unspecific
--- 2958,2974 ----
  				   :type (component-extension component
  							      type))))
  	   (namestring (translate-logical-pathname pathname)))
+ 	  #-scl
  	  (t
  	   (namestring
  	    (make-pathname :host (or (component-host component)
  				     (pathname-host pathname))
  
! 			   :directory (pathname-directory pathname)
! 			   :name (or (pathname-name pathname)
                                       (component-name component))
  
! 			   :type (component-extension component type)
  			   :device
  			   #+sbcl
  			   :unspecific
***************
*** 2972,2978 ****
  						#+scl :common
  						))
  			   ;; :version :newest
! 			   ))))))
  
  
  #-lispworks
--- 2979,2992 ----
  						#+scl :common
  						))
  			   ;; :version :newest
! 			   )))
! 	  #+scl
! 	  (t
! 	   (make-pathname
! 	    :name (component-name component)
! 	    :type (component-extension component type)
! 	    :defaults pathname
! 	    :case :uri)))))
  
  
  #-lispworks
***************
*** 4403,4409 ****
  (pushnew 'sbcl-mk-defsystem-module-provider sb-ext:*module-provider-functions*)
  )
  
! #+#.(cl:if (cl:and (cl:find-package "EXT") (cl:find-symbol "*MODULE-PROVIDER-FUNCTIONS*" "EXT")) '(and) '(or))
  (progn
    (defun cmucl-mk-defsystem-module-provider (name)
      (let ((module-name (string-downcase (string name))))
--- 4417,4423 ----
  (pushnew 'sbcl-mk-defsystem-module-provider sb-ext:*module-provider-functions*)
  )
  
! #+#.(cl:if (cl:and (cl:find-package :ext) (cl:find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :ext)) '(and) '(or))
  (progn
    (defun cmucl-mk-defsystem-module-provider (name)
      (let ((module-name (string-downcase (string name))))
***************
*** 4474,4480 ****
  
  (defmacro define-language (name &key compiler loader
  				source-extension binary-extension)
!   (let ((language (gensym "LANGUAGE")))
      `(let ((,language (make-language :name ,name
  				     :compiler ,compiler
  				     :loader ,loader
--- 4488,4494 ----
  
  (defmacro define-language (name &key compiler loader
  				source-extension binary-extension)
!   (let ((language (gensym (symbol-name '#:language))))
      `(let ((,language (make-language :name ,name
  				     :compiler ,compiler
  				     :loader ,loader
***************
*** 4688,4694 ****
  
  	     (setf verbose-stream
  		   (make-useable-stream
! 		    #+cmu error-file-stream
  		    (and verbose *trace-output*)))
  
  	     (format verbose-stream "Running ~A~@[ ~{~A~^ ~}~]~%"
--- 4702,4708 ----
  
  	     (setf verbose-stream
  		   (make-useable-stream
! 		    #+(or cmu scl) error-file-stream
  		    (and verbose *trace-output*)))
  
  	     (format verbose-stream "Running ~A~@[ ~{~A~^ ~}~]~%"
***************
*** 4703,4709 ****
  			   (make-useable-stream error-file-stream
  						(if (eq error-output t)
  						    *error-output*
! 						  error-output)))
  			  (process
  			   (ext:run-program program arguments
  					    :error error-output)))
--- 4717,4723 ----
  			   (make-useable-stream error-file-stream
  						(if (eq error-output t)
  						    *error-output*
! 						    error-output)))
  			  (process
  			   (ext:run-program program arguments
  					    :error error-output)))
***************
*** 4934,4942 ****
  	       ;; DeSoi [marcoxa at sourceforge.net 20020529]
  
  	       (ensure-directories-exist
! 		(make-pathname
! 		 :host (pathname-host output-file)
! 		 :directory (pathname-directory output-file)))
  
  	       (or *oos-test*
  		   (apply (compile-function component)
--- 4948,4957 ----
  	       ;; DeSoi [marcoxa at sourceforge.net 20020529]
  
  	       (ensure-directories-exist
! 		(make-pathname :name nil
! 			       :type nil
! 			       :version nil
! 			       :defaults output-file))
  
  	       (or *oos-test*
  		   (apply (compile-function component)
***************
*** 4970,4977 ****
  ;;; See CLOCC/PORT/sys.lisp:compiled-file-p
  
  (eval-when (:load-toplevel :execute :compile-toplevel)
!   (when (find-package "PORT")
!     (import (find-symbol "COMPILED-FILE-P" "PORT"))))
  
  (unless (fboundp 'compiled-file-p)
    (defun compiled-file-p (file-name)
--- 4985,4992 ----
  ;;; See CLOCC/PORT/sys.lisp:compiled-file-p
  
  (eval-when (:load-toplevel :execute :compile-toplevel)
!   (when (find-package :port)
!     (import (find-symbol (symbol-name '#:compiled-file-p) :port))))
  
  (unless (fboundp 'compiled-file-p)
    (defun compiled-file-p (file-name)