At Thu, 29 Nov 2007 06:51:20 +0300, Samium Gromoff wrote:
Good day folks,
The patch below rectifies the swank.asd, making the ASDF load flow more natural.
The per-implementation file constellation definition is moved into a separate file, used by both the ASDF and slime-loader methods.
Now it actually compiles contribs, but also doesn't load them.
The contrib enumeration, protocol version formulation, some utility functions plus the loader epilogue part are now shared between the ASDF and swank-loader paths.
Both paths tested (hopefully things didn't miss me this time) on SBCL.
regards, Samium Gromoff
diff --git a/contrib/swank-presentation-streams.lisp b/contrib/swank-presentation-streams.lisp --- a/contrib/swank-presentation-streams.lisp +++ b/contrib/swank-presentation-streams.lisp @@ -76,7 +76,7 @@ be sensitive and remember what object it is in the repl if predicate is true" (load (make-pathname :name "sbcl-pprint-patch" :type "lisp" - :directory (pathname-directory swank-loader:*source-directory*))))))) + :directory (pathname-directory swank-loader::*source-directory*)))))))
(let ((last-stream nil) (last-answer nil)) diff --git a/contribs.lisp-expr b/contribs.lisp-expr --- /dev/null +++ b/contribs.lisp-expr @@ -0,0 +1,3 @@ +(swank-c-p-c swank-arglists swank-fuzzy swank-fancy-inspector + swank-presentations swank-presentation-streams + #+(or asdf sbcl) swank-asdf) \ No newline at end of file diff --git a/file-constellation.lisp-expr b/file-constellation.lisp-expr --- /dev/null +++ b/file-constellation.lisp-expr @@ -0,0 +1,10 @@ +#+cmu ("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl") +#+scl ("swank-source-path-parser" "swank-source-file-cache" "swank-scl") +#+sbcl ("swank-source-path-parser" "swank-source-file-cache" "swank-sbcl" "swank-gray") +#+openmcl ("metering" "swank-openmcl" "swank-gray") +#+lispworks ("swank-lispworks" "swank-gray") +#+allegro ("swank-allegro" "swank-gray") +#+clisp ("xref" "metering" "swank-clisp" "swank-gray") +#+armedbear ("swank-abcl") +#+cormanlisp ("swank-corman" "swank-gray") +#+ecl ("swank-ecl" "swank-gray") diff --git a/swank-loader-common.lisp b/swank-loader-common.lisp --- /dev/null +++ b/swank-loader-common.lisp @@ -0,0 +1,61 @@ +(in-package :swank-loader) + +(defvar *source-directory* + (make-pathname :name nil :type nil + :defaults (or *load-pathname* *default-pathname-defaults*)) + "The directory where to look for the source.") + +(defparameter *implementation-features* + '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp + :armedbear :gcl :ecl :scl)) + +(defparameter *os-features* + '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux + :unix)) + +(defparameter *architecture-features* + '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 + :sparc64 :sparc :hppa64 :hppa)) + +(defun lisp-version-string () + #+cmu (substitute-if #_ (lambda (x) (find x " /")) + (lisp-implementation-version)) + #+scl (lisp-implementation-version) + #+sbcl (lisp-implementation-version) + #+ecl (lisp-implementation-version) + #+openmcl (format nil "~d.~d" + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version*) + #+lispworks (lisp-implementation-version) + #+allegro (format nil + "~A~A~A" + excl::*common-lisp-version-number* + (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn + (if (member :64bit *features*) "-64bit" "")) + #+clisp (let ((s (lisp-implementation-version))) + (subseq s 0 (position #\space s))) + #+armedbear (lisp-implementation-version) + #+cormanlisp (lisp-implementation-version)) + +(defun slime-version-string () + "Return a string identifying the SLIME version. +Return nil if nothing appropriate is available." + (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*) + :if-does-not-exist nil) + (and s (symbol-name (read s))))) + +(defun load-user-init-file () + "Load the user init file, return NIL if it does not exist." + (load (merge-pathnames (user-homedir-pathname) + (make-pathname :name ".swank" :type "lisp")) + :if-does-not-exist nil)) + +(defun load-site-init-file (directory) + (load (make-pathname :name "site-init" :type "lisp" + :defaults directory) + :if-does-not-exist nil)) + +(defun append-dir (absolute name) + (merge-pathnames + (make-pathname :directory `(:relative ,name) :defaults absolute) + absolute)) \ No newline at end of file diff --git a/swank-loader-epilogue.lisp b/swank-loader-epilogue.lisp --- /dev/null +++ b/swank-loader-epilogue.lisp @@ -0,0 +1,9 @@ +(in-package :swank-loader) + +(setf swank::*swank-wire-protocol-version* (slime-version-string) + swank::*load-path* (append swank::*load-path* + (list (append-dir *source-directory* "contrib")))) +(swank-backend::warn-unimplemented-interfaces) +(load-site-init-file *source-directory*) +(load-user-init-file) +(swank:run-after-init-hook) diff --git a/swank-loader.lisp b/swank-loader.lisp --- a/swank-loader.lisp +++ b/swank-loader.lisp @@ -26,58 +26,20 @@
(cl:in-package :swank-loader)
-(defvar *source-directory* - (make-pathname :name nil :type nil - :defaults (or *load-pathname* *default-pathname-defaults*)) - "The directory where to look for the source.") - (defparameter *sysdep-files* - (append - '() - #+cmu '("swank-source-path-parser" "swank-source-file-cache" "swank-cmucl") - #+scl '("swank-source-path-parser" "swank-source-file-cache" "swank-scl") - #+sbcl '("swank-source-path-parser" "swank-source-file-cache" - "swank-sbcl" "swank-gray") - #+openmcl '("metering" "swank-openmcl" "swank-gray") - #+lispworks '("swank-lispworks" "swank-gray") - #+allegro '("swank-allegro" "swank-gray") - #+clisp '("xref" "metering" "swank-clisp" "swank-gray") - #+armedbear '("swank-abcl") - #+cormanlisp '("swank-corman" "swank-gray") - #+ecl '("swank-ecl" "swank-gray") - )) - -(defparameter *implementation-features* - '(:allegro :lispworks :sbcl :openmcl :cmu :clisp :ccl :corman :cormanlisp - :armedbear :gcl :ecl :scl)) - -(defparameter *os-features* - '(:macosx :linux :windows :mswindows :win32 :solaris :darwin :sunos :hpux - :unix)) - -(defparameter *architecture-features* - '(:powerpc :ppc :x86 :x86-64 :amd64 :i686 :i586 :i486 :pc386 :iapx386 - :sparc64 :sparc :hppa64 :hppa)) - -(defun lisp-version-string () - #+cmu (substitute-if #_ (lambda (x) (find x " /")) - (lisp-implementation-version)) - #+scl (lisp-implementation-version) - #+sbcl (lisp-implementation-version) - #+ecl (lisp-implementation-version) - #+openmcl (format nil "~d.~d" - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version*) - #+lispworks (lisp-implementation-version) - #+allegro (format nil - "~A~A~A" - excl::*common-lisp-version-number* - (if (eq 'h 'H) "A" "M") ; ANSI vs MoDeRn - (if (member :64bit *features*) "-64bit" "")) - #+clisp (let ((s (lisp-implementation-version))) - (subseq s 0 (position #\space s))) - #+armedbear (lisp-implementation-version) - #+cormanlisp (lisp-implementation-version)) + '#.(with-open-file (s (make-pathname :directory (pathname-directory *load-truename*) + :name "file-constellation" :type "lisp-expr") + :direction :input) + (read s))) + +(defparameter *contribs* + '#.(with-open-file (s (make-pathname :directory (pathname-directory *load-truename*) + :name "contribs" :type "lisp-expr") + :direction :input) + (read s))) + +(load (make-pathname :directory (pathname-directory *load-truename*) + :name "swank-loader-common" :type "lisp"))
(defun unique-directory-name () "Return a name that can be used as a directory name that is @@ -107,13 +69,6 @@ operating system, and hardware architecture." "Returns true if NEW-FILE is newer than OLD-FILE." (> (file-write-date new-file) (file-write-date old-file)))
-(defun slime-version-string () - "Return a string identifying the SLIME version. -Return nil if nothing appropriate is available." - (with-open-file (s (merge-pathnames "ChangeLog" *source-directory*) - :if-does-not-exist nil) - (and s (symbol-name (read s))))) - (defun default-fasl-directory () (merge-pathnames (make-pathname @@ -174,17 +129,6 @@ recompiled." (load file :verbose t) (force-output))))
-(defun load-user-init-file () - "Load the user init file, return NIL if it does not exist." - (load (merge-pathnames (user-homedir-pathname) - (make-pathname :name ".swank" :type "lisp")) - :if-does-not-exist nil)) - -(defun load-site-init-file (directory) - (load (make-pathname :name "site-init" :type "lisp" - :defaults directory) - :if-does-not-exist nil)) - (defun source-files (names src-dir) (mapcar (lambda (name) (make-pathname :name (string-downcase name) :type "lisp" @@ -198,29 +142,13 @@ recompiled." (defvar *fasl-directory* (default-fasl-directory) "The directory where fasl files should be placed.")
-(defvar *contribs* '(swank-c-p-c swank-arglists swank-fuzzy - swank-fancy-inspector - swank-presentations swank-presentation-streams - #+(or asdf sbcl) swank-asdf - ) - "List of names for contrib modules.") - -(defun append-dir (absolute name) - (merge-pathnames - (make-pathname :directory `(:relative ,name) :defaults absolute) - absolute)) - -(defun contrib-src-dir (src-dir) - (append-dir src-dir "contrib")) - (defun contrib-source-files (src-dir) - (source-files *contribs* (contrib-src-dir src-dir))) + (source-files *contribs* (append-dir src-dir "contrib")))
(defun load-swank (&key (source-directory *source-directory*) (fasl-directory *fasl-directory*) - (contrib-fasl-directory - (append-dir fasl-directory "contrib"))) + (contrib-fasl-directory (append-dir fasl-directory "contrib"))) (compile-files-if-needed-serially (swank-source-files source-directory) fasl-directory t) (compile-files-if-needed-serially (contrib-source-files source-directory) @@ -228,10 +156,5 @@ recompiled."
(load-swank)
-(setq swank::*swank-wire-protocol-version* (slime-version-string)) -(setq swank::*load-path* - (append swank::*load-path* (list (contrib-src-dir *source-directory*)))) -(swank-backend::warn-unimplemented-interfaces) -(load-site-init-file *source-directory*) -(load-user-init-file) -(swank:run-after-init-hook) +(load (make-pathname :directory (pathname-directory *load-truename*) + :name "swank-loader-epilogue" :type "lisp")) diff --git a/swank-sbcl.lisp b/swank-sbcl.lisp --- a/swank-sbcl.lisp +++ b/swank-sbcl.lisp @@ -22,7 +22,8 @@
(declaim (optimize (debug 2) (sb-c:insert-step-conditions 0)))
-(import-from :sb-gray *gray-stream-symbols* :swank-backend) +(unless (find-symbol (symbol-name (first *gray-stream-symbols*)) :swank-backend) + (import-from :sb-gray *gray-stream-symbols* :swank-backend))
;;; backwards compability tests
diff --git a/swank.asd b/swank.asd --- a/swank.asd +++ b/swank.asd @@ -24,24 +24,30 @@
(in-package :swank-loader)
-(defclass cl-script-file (asdf:source-file) ()) - -(defmethod asdf:perform ((o asdf:compile-op) (f cl-script-file)) - t) -(defmethod asdf:perform ((o asdf:load-op) (f cl-script-file)) - (mapcar #'load (asdf:input-files o f))) -(defmethod asdf:output-files ((o asdf:compile-op) (f cl-script-file)) - nil) -(defmethod asdf:input-files ((o asdf:load-op) (c cl-script-file)) - (list (asdf:component-pathname c))) -(defmethod asdf:operation-done-p ((o asdf:compile-op) (c cl-script-file)) - t) -(defmethod asdf:source-file-type ((c cl-script-file) (s asdf:module)) - "lisp") +(defvar *contribs* '#.(with-open-file (s (make-pathname :directory (pathname-directory *load-truename*) + :name "contribs" :type "lisp-expr") + :direction :input) + (read s)))
(asdf:defsystem :swank - :default-component-class cl-script-file - :components ((:file "swank-loader"))) + :serial t + :components #.(append + '((:file "swank-backend")) + (mapcar (lambda (file) `(:file ,file)) + (with-open-file (s (make-pathname :directory (pathname-directory *load-truename*) + :name "file-constellation" :type "lisp-expr") + :direction :input) + (read s))) + '((:file "swank") (:file "swank-loader-common") + (:module "contrib" + :serial t + :components #.(mapcar (lambda (contrib) `(:file ,contrib + :perform (asdf:load-op :around (op c) (declare (ignore op c)) t))) + (with-open-file (s (make-pathname :directory (pathname-directory *load-truename*) + :name "contribs" :type "lisp-expr") + :direction :input) + (read s)))) + (:file "swank-loader-epilogue" :in-order-to ((asdf:load-op (asdf:compile-op :contrib)))))))
(defparameter *source-directory* (asdf:component-pathname (asdf:find-system :swank)))