Commit 03863a12 authored by Pascal J. Bourguignon's avatar Pascal J. Bourguignon

Tuned tools.

parent 569074e3
......@@ -11,13 +11,11 @@
(defvar *use-scheme-write* t)
(pushnew :unix *features*)
(if (equal (lisp-implementation-type) "Emacs Common Lisp")
(progn
(load "/usr/local/share/lisp/packages/edu/mit/ai/pseudo/loadit.lisp")
(load-pseudoscheme "/usr/local/share/lisp/packages/edu/mit/ai/pseudo/"))
(progn
(load "PACKAGES:EDU;MIT;AI;PSEUDO;LOADIT")
(load-pseudoscheme "PACKAGES:EDU;MIT;AI;PSEUDO;")))
(defmacro scheme () `(ps:scheme))
(progn
(load (com.informatimago.tools.pathname:translate-logical-pathname #P"PACKAGES:EDU;MIT;AI;PSEUDO;LOADIT"))
(load-pseudoscheme (com.informatimago.tools.pathname:translate-logical-pathname #P"PACKAGES:EDU;MIT;AI;PSEUDO;")))
(defun scheme () (ps:scheme))
(format t "~2%Use: (scheme)~2%")
;;;; pseudo.lisp -- -- ;;;;
;;;; THE END ;;;;
......@@ -35,8 +35,10 @@
(defpackage "COM.INFORMATIMAGO.TOOLS.ASDF"
(:use "COMMON-LISP"
"ASDF"
"QUICKLISP"
"COM.INFORMATIMAGO.TOOLS.PATHNAME")
"QUICKLISP")
(:shadowing-import-from
"COM.INFORMATIMAGO.TOOLS.PATHNAME"
"USER-HOMEDIR-PATHNAME" "MAKE-PATHNAME" "TRANSLATE-LOGICAL-PATHNAME")
(:export "ASDF-LOAD"
"ASDF-LOAD-SOURCE"
"ASDF-INSTALL"
......@@ -81,9 +83,9 @@
(defparameter *asdf-registry-file*
(merge-pathnames (user-pathname)
(make-pathname* :name "ASDF-CENTRAL-REGISTRY" :type "DATA" :version :newest :case :common
:defaults (user-pathname))
(merge-pathnames (user-homedir-pathname)
(make-pathname :name "ASDF-CENTRAL-REGISTRY" :type "DATA" :version :newest :case :common
:defaults (user-homedir-pathname))
nil)
"Cache file.")
......@@ -97,10 +99,10 @@ It is sorted in ascending namestring length."
(sort
(delete-duplicates
(mapcar
(lambda (p) (make-pathname* :name nil :type nil :version nil :defaults p))
(lambda (p) (make-pathname :name nil :type nil :version nil :defaults p))
(mapcan (lambda (dir)
(directory (merge-pathnames
(make-pathname* :directory (if (pathname-directory dir)
(make-pathname :directory (if (pathname-directory dir)
'(:relative :wild-inferiors)
'(:absolute :wild-inferiors))
:name :wild
......@@ -112,8 +114,8 @@ It is sorted in ascending namestring length."
directories))
:test (function equal))
(lambda (a b) (if (= (length a) (length b))
(string< a b)
(< (length a) (length b))))
(string< a b)
(< (length a) (length b))))
:key (function namestring))
(format *trace-output* "~&;; Done.~%")))
......
......@@ -38,9 +38,9 @@
:author "Pascal J. Bourguignon"
:version "1.0.0"
:license "GPL3"
:depends-on ("quicklisp")
:depends-on ("quicklisp"
"com.informatimago.tools.pathname")
:components ((:file "quicklisp")
(:file "pathname")
(:file "asdf" :depends-on ("quicklisp" "pathname"))))
(:file "asdf" :depends-on ("quicklisp"))))
;;;; THE END ;;;;
......@@ -33,26 +33,53 @@
;;;;**************************************************************************
(defpackage "COM.INFORMATIMAGO.TOOLS.PATHNAME"
(:use "COMMON-LISP")
(:export "MAKE-PATHNAME*"
"USER-PATHNAME")
(:shadow "MAKE-PATHNAME"
"USER-HOMEDIR-PATHNAME"
"TRANSLATE-LOGICAL-PATHNAME")
(:export "MAKE-PATHNAME"
"USER-HOMEDIR-PATHNAME"
"TRANSLATE-LOGICAL-PATHNAME")
(:documentation "Pathname tools."))
(in-package "COM.INFORMATIMAGO.TOOLS.PATHNAME")
;; in those implementations, :case :common is not downcased on posix systems.
#+(or allegro ccl emacs-cl)
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :bad-pathname-implementation *features*))
(defun user-pathname ()
"On MS-Windows, it's not the USER-HOMEDIR-PATHNAME."
#+windows-target (let ((home (ccl::getenv "HOME")))
(if home
(pathname (format nil "~A\\" home))
#P"C:\\cygwin\\home\\pjb\\"))
#-windows-target (USER-HOMEDIR-PATHNAME))
(defun user-homedir-pathname ()
"On CCL on MS-Windows, it's not the USER-HOMEDIR-PATHNAME."
#+(and ccl windows-target)
(let ((home (ccl::getenv "HOME")))
(if home
(pathname (format nil "~A\\" home))
#P"C:\\cygwin\\home\\pjb\\"))
#-(and ccl windows-target)
(cl:user-homedir-pathname))
(defun make-pathname* (&key (host nil hostp) (device nil devicep) (directory nil directoryp)
(defun translate-logical-pathname (pathname)
(cl:translate-logical-pathname
(etypecase pathname
(string (pathname pathname))
(logical-pathname (make-pathname :host (pathname-host pathname)
:device (pathname-device pathname)
:directory (pathname-directory pathname)
:name (pathname-name pathname)
:type (pathname-type pathname)
:version (pathname-version pathname)
:defaults pathname
:case :common))
(pathname pathname))))
(defun make-pathname (&key (host nil hostp) (device nil devicep) (directory nil directoryp)
(name nil namep) (type nil typep) (version nil versionp)
(defaults nil defaultsp) (case :local casep))
(declare (ignorable casep))
#+ (or abcl ccl allegro)
#+:bad-pathname-implementation
(labels ((localize (object)
(typecase object
(list (mapcar (function localize) object))
......@@ -63,7 +90,7 @@
(list key (if (eql case :common)
(localize value)
value)))))
(apply (function make-pathname)
(apply (function cl:make-pathname)
(append (parameter hostp :host host)
(parameter devicep :device device)
(parameter directoryp :directory directory)
......@@ -72,8 +99,8 @@
(parameter versionp :version version)
(parameter defaultsp :defaults defaults)
(list :case :local))))
#-(or abcl ccl allegro)
(apply (function make-pathname)
#-:bad-pathname-implementation
(apply (function cl:make-pathname)
(append
(when hostp (list :host host))
(when devicep (list :device device))
......
......@@ -34,7 +34,8 @@
(defpackage "COM.INFORMATIMAGO.TOOLS.QUICKLISP"
(:use "COMMON-LISP"
"QUICKLISP")
"QUICKLISP"
"ASDF")
(:export "PRINT-SYSTEMS"
"QUICK-INSTALLED-SYSTEMS"
"QUICK-LIST-SYSTEMS"
......@@ -135,7 +136,7 @@ are listed."
(defun quick-delete (&rest systems)
"Delete the ASDF systems so they'll be reloaded."
(map 'list (lambda (system) (asdf-delete-system system)) systems))
(map 'list (lambda (system) (asdf:clear-system system)) systems))
(defun quick-reload (&rest systems)
"Delete and reload the ASDF systems."
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment