;;****************************************************************************
;;FILE: init.lisp
;;LANGUAGE: Common-Lisp
;;SYSTEM: Common-Lisp
;;USER-INTERFACE: NONE
;;DESCRIPTION
;;
;; Initialization for common-lisp packages.
;;
;; This files remove some specificities from the lisp environment
;; (to make it more Common-Lisp),
;; loads the package COM.INFORMATIMAGO.COMMON-LISP.PACKAGE,
;; and add logical pathname translations to help find then other packages.
;;
;; Since we're generating an image, it should be useful only
;; at compilation-time, so any path present here should not be needed
;; at run-time. (But we don't clear them from the translations...).
;;
;;AUTHORS
;; <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;MODIFICATIONS
;; 2004-01-20 <PJB> Created.
;;BUGS
;;LEGAL
;; GPL
;;
;; Copyright Pascal J. Bourguignon 2004 - 2004
;;
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License
;; as published by the Free Software Foundation; either version
;; 2 of the License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be
;; useful, but WITHOUT ANY WARRANTY; without even the implied
;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;; PURPOSE. See the GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public
;; License along with this program; if not, write to the Free
;; Software Foundation, Inc., 59 Temple Place, Suite 330,
;; Boston, MA 02111-1307 USA
;;****************************************************************************
(SETQ *LOAD-VERBOSE* T)
#+clisp (SETQ custom:*LOAD-echo* nil)
;; clean the imported packages:
(MAPC (LAMBDA (USED) (UNUSE-PACKAGE USED "COMMON-LISP-USER"))
(REMOVE (FIND-PACKAGE "COMMON-LISP")
(COPY-SEQ (PACKAGE-USE-LIST "COMMON-LISP-USER"))))
#+clisp
(when (string= (LISP-IMPLEMENTATION-VERSION) "2.33.83"
:end1 (min (length (LISP-IMPLEMENTATION-VERSION)) 7))
(EXT:WITHOUT-PACKAGE-LOCK ("COMMON-LISP")
(let ((oldload (function cl:load)))
(fmakunbound 'cl:load)
(defun cl:load (filespec &key (verbose *load-verbose*)
(print *load-print*)
(if-does-not-exist t)
(external-format :default))
(handler-case (funcall oldload filespec :verbose verbose
:print print :if-does-not-exist if-does-not-exist
:external-format external-format)
(SYSTEM::SIMPLE-PARSE-ERROR
()
(funcall oldload (translate-logical-pathname filespec)
:verbose verbose
:print print :if-does-not-exist if-does-not-exist
:external-format external-format)))))))
;; (DEFUN SCONC (&REST ARGS)
;; (apply (function CONCATENATE)
;; 'string
;; (mapcar (lambda (item) (typecase item
;; (pathname (namestring item))
;; (otherwise (string item)))) ARGS)));;SCONC
;; COM.INFORMATIMAGO.COMMON-LISP packages depends only on themselves,
;; from the current directory.
(progn
(defvar *directories* '())
(defun get-directory (key &optional (subpath ""))
(unless *directories*
(with-open-file (dirs (make-pathname :name "DIRECTORIES" :type "TXT"
:version nil :case :common
:defaults (user-homedir-pathname)))
(loop
:for k = (read dirs nil dirs)
:until (eq k dirs)
:do (push (string-trim " " (read-line dirs)) *directories*)
:do (push (intern (substitute #\- #\_ (string k))
"KEYWORD") *directories*))))
(unless (getf *directories* key)
(error "~S: No directory keyed ~S" 'get-directory key))
(merge-pathnames subpath (getf *directories* key) nil)))
;; Load COM.INFORMATIMAGO.COMMON-LISP.PACKAGE:
(defparameter *translations*
(loop
:for (file translations)
:in (list (list (get-directory :share-lisp "packages/com/informatimago/common-lisp/package.lisp")
(list (LIST (make-pathname
:host "PACKAGES"
:directory '(:absolute :wild-inferiors)
:name :wild :type :wild :version :wild)
(merge-pathnames
(make-pathname :case :common
:directory '(:relative :wild-inferiors)
:name :wild :type :wild :version :wild)
(get-directory :share-lisp "packages/")
nil))))
(list (get-directory :lisp-sources "common-lisp/package.lisp")
(list (LIST (make-pathname
:host "PACKAGES"
:directory '(:absolute "COM" "INFORMATIMAGO" :wild-inferiors)
:name :wild :type :wild :version :wild)
(merge-pathnames
(make-pathname :case :common
:directory '(:relative :wild-inferiors)
:name :wild :type :wild :version :wild)
(get-directory :lisp-sources)
nil))))
(list "/usr/local/share/lisp/packages/com/informatimago/common-lisp/package.lisp"
(list (LIST (make-pathname
:host "PACKAGES"
:directory '(:absolute :wild-inferiors)
:name :wild :type :wild :version :wild)
(make-pathname
:case :common
:directory '(:absolute "USR" "LOCAL" "SHARE" "LISP" "PACKAGES"
:wild-inferiors)
:name :wild :type :wild :version :wild)))))
:until (ignore-errors (load file))
:finally (return translations)))
;; Import DEFINE-PACKAGE, and add translations:
(IMPORT 'PACKAGE:DEFINE-PACKAGE)
(SETF (LOGICAL-PATHNAME-TRANSLATIONS "PACKAGES")
(HANDLER-CASE (LOGICAL-PATHNAME-TRANSLATIONS "PACKAGES")
(ERROR NIL)))
(apply (function PACKAGE:ADD-TRANSLATIONS) *translations*)
;; #+sbcl (setf (logical-pathname-translations "PACKAGES")
;; (sort (copy-seq (logical-pathname-translations "PACKAGES"))
;; (lambda (a b) (< (length (second a)) (length (second b))))))
;;;; init.lisp -- -- ;;;;