path: root/src/lisp/core.lisp.in

;; � Emacs, this is a -*- Lisp -*- file, despite apperance
;; 
;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
;; All rights reserved.
;; 
;; Copyright (C) 2007, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;;     - Redistributions of source code must retain the above copyright
;;       notice, this list of conditions and the following disclaimer.
;;
;;     - Redistributions in binary form must reproduce the above copyright
;;       notice, this list of conditions and the following disclaimer in
;;       the documentation and/or other materials provided with the
;;       distribution.
;;
;;     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
;;       names of its contributors may be used to endorse or promote products
;;       derived from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


;; 
;; -*- Abstract -*-
;; 
;;  This pamphlet defines the core of the system utilities for building
;;  Boot and Axiom executable.  It essentially etablishes a namespace
;;  (package AxiomCore) and defines some macros and functions
;;  that need to be present during during compilation and executable
;;  image construction.
;; 


(defpackage "AxiomCore"
  #+:common-lisp (:use "COMMON-LISP")
  #-:common-lisp (:use "SYSTEM" "LISP" "USER")
  ;; For GCL we need to explicitly use the DEFPACKAGE, otherwise the
  ;; image obtained from compiler link will not work.  The root cause
  ;; is a non-ANSI compliant organization of GCL's implementation.
  #+:gcl (:use "DEFPACKAGE")
  (:export "coreQuit"
           "fatalError"
           "internalError"
           "coreError"
           "errorCount"
           "countError"
           "warn"
           
           "%hasFeature"
	   "%systemOptions"
	   "%systemArguments"
	   
	   "$hostPlatform"
	   "$buildPlatform"
	   "$targetPlatform"

	   "$systemInstallationDirectory"

           "getCommandLineArguments"
           "processCommandLine"
           "handleCommandLine"
           "$originalLispTopLevel"
           "link"
           "installDriver"
           "associateRequestWithFileType"
           "ensureTrailingSlash"
           "getOutputPathname"
           "loadPathname"
           "compileLispFile"
           "compileLispHandler"
           "Option"

           "IMPORT-MODULE"
           ))

(in-package "AxiomCore")

;; 
;; -*- Configuration Constants -*-
;; 

;; The canonical triplets for host, build, and target.   For the moment,
;; they are all identical, for we don't support cross compilation yet.
(defconstant |$hostPlatform| "@host@")
(defconstant |$buildPlatform| "@build@")
(defconstant |$targetPlatform| "@target@")

;; The directory that contains the final installation directory, as
;; specified at configuration time (or in exoteric cases, as overriden
;; on the Make command line). 
(defconstant |$systemInstallationDirectory| 
  "@open_axiom_installdir@/")

;; Lisp compiler optimization settings.
(proclaim '(optimize @axiom_optimize_options@))

;; 
;; -*- Hosting Lisp System -*-
;; 

;; The top level read-eval-print loop function of the base
;; Lisp system we are using.  This is a very brittle way
;; of achieving something conceptually simple.  
(defconstant |$originalLispTopLevel|
  #+:ecl #'si::top-level
  #+:gcl #'si::top-level
  #+:sbcl #'sb-impl::toplevel-init
  #+clisp #'system::main-loop)

;; Lisp source file extension.
(defconstant |$LispFileType| "lisp")

;; Extenstion of FASL files.
(defconstant |$faslType|
  (pathname-type (compile-file-pathname "foo.lisp")))

;; 
;; -*- OpenAxiom source file extensions -*-
;; 

(defconstant |$BootFileType| "boot")
(defconstant |$LibraryFileType| "spad")
(defconstant |$ScriptFileType| "input")

;; Canonalize source file extensions
(defun |getFileType|(file)
  (let ((file-type (pathname-type file)))
    (cond ((or (equal "clisp" file-type)
               (equal "lsp" file-type))
           |$LispFileType|)
          (t file-type))))


;; 
;; -*- OpenAxiom Driver Table -*-
;; 

;; Global map from requests  to drivers.
;; Ideally we want to handle
;;    --help: just print a help menu and exit
;;    --version: Print version information and exit
;;    --system=<dir>: specify <dir> as the root directory
;;    --sysalg=<dir>: specify <dir> as directory containing algebras
;;    --compile: boot or lisp files
;;    --translate: boot files
;;    --make: boot, lisp, or fasl files
(defparameter |$driverTable| (make-hash-table :test #'equal :size 5))


;; Look up the driver that can handle REQUEST.  Returns nil when
;; no driver exists.
(defun |getDriver| (request)
  (gethash request |$driverTable|))

;; Associate DRIVER with REQUEST.
(defun |installDriver| (request driver)
  (when (|getDriver| request) 
    (|internalError| "attempt to override driver"))
  (setf (gethash request |$driverTable|) driver))

;; Register DRIVER for a REQUEST for a file with FILE-TYPE extension.
(defun |associateRequestWithFileType| (request file-type driver)
  ;; If a driver is already installed, it must be non-null. 
  ;; We don't allow overriding at the moment.
  (let ((key (cons request file-type)))
    (unless (|useFileType?| request)
      (setf (get request 'use-file-type) t))
    (|installDriver| key driver)))


;; 
;; -*- OpenAxiom Command Line Parsing -*-
;; 

;; Return a symbol object represensing option named OPT, without leading
;; double dash (--).
(defun |Option| (opt)
  (intern opt (find-package "AxiomCore")))

;; Returns a pair (name . value) if OPTION if of the form "--name=value",
;; where name is a symbol and value is a string.  Otherwise, if
;; OPTION is of the form "--name", returns the symbol name.
(defun |parseOption| (option)
  (setq option (subseq option 2))
  (let ((p (position #\= option)))
    (if p
        (cons (|Option| (subseq option 0 p)) (subseq option (1+ p)))
      (|Option| option))))

;; Returns the value specified for OPTION. Otherwise, return nil
(defun |getOptionValue| (opt options)
  (let ((val (assoc opt options)))
    (cond (val (cdr val))
          (t nil))))

;; Walk through the command line arguments ARGV, separating options
;; of the form --opt or --opt=val into an a-list, and the rest
;; of the command line into a list.  The processing stop as soon as
;; a non-option form is encountered. OPTIONS-SO-FAR accumulates the
;; the list of processed options.
(defun |processCommandLine| (argv options-so-far)
  (if (and argv
           (equal "--" (subseq (car argv) 0 2)))
      (let ((option (|parseOption| (car argv))))
        (cond ((symbolp option)
               (|processCommandLine| (cdr argv)
                                     (cons (cons option t) options-so-far)))
              ((consp option) 
               (|processCommandLine| (cdr argv) (cons option options-so-far)))
              (t (|internalError|
                  (format nil "processCommandLine: unknown option ~S"
                          option)))))
    (values options-so-far argv)))


;; 
;; -*- Building New Lisp Images -*-
;; 
;; At many points, the build machinery makes new Lisp images that
;; are the results of augmenting a given Lisp image with new 
;; Lisp files (either compiled or in source form).  For most Lisp
;; implementations, this is done by loading the Lisp files in the 
;; current image and dumping the result on disk as an executable.


(defun |getOutputPathname| (options &optional (default-output "a.out"))
  (let ((output-option (assoc (|Option| "output") options)))
    (if output-option
        ;; If an output file name was specified on the command line, it
        ;; is so relative to the current workding directory.  In 
        ;; particular we want to prevent overly zelous SBCL to mess
        ;; around with the output file when we call compile-file-pathname. 
        ;; The SBCL-specific hack below does not work all the time, but in
        ;; most cases, it is OK.
        #+:sbcl (merge-pathnames (cdr output-option)
                                 *default-pathname-defaults*)
        #-:sbcl (cdr output-option)
        default-output)))


(defun |getMainEntryPoint| (options)
  (|getOptionValue| (|Option| "main") options))

;; Save current image on disk as executable and quit.
(defun |saveCore| (core-image &optional (entry-point nil))
  ;; When building the Axiom system, and in many other cases I suspect,
  ;; the main entry point is some function in a package not known to
  ;; the Lisp system at compile time, so we have delayed the 
  ;; evaluation of the entry point in a form of a suspension.  At this
  ;; point we must have all data needed to complete the evaluation.
  (when (consp entry-point)
    (setq entry-point (apply (car entry-point) 
                             (cdr entry-point))))
  #+:sbcl (if (null entry-point)
              (sb-ext::save-lisp-and-die core-image :executable t)
            (sb-ext::save-lisp-and-die core-image 
                                       :toplevel entry-point
                                       :executable t))
  #+:gcl (progn 
           (when entry-point 
             (setq si::*top-level-hook* entry-point))
           (system::save-system core-image))
  #+:clisp (progn 
             (if entry-point
                 (ext::saveinitmem core-image 
                                   :init-function entry-point
                                   :executable t
                                   :norc t
                                   )
               (ext::saveinitmem core-image 
                                 :executable t
                                 :norc t
                                 ))
             (ext::quit))
  (error "don't know how to save Lisp image"))


;; 
;; -*- Program Termination -*-
;; 
;; When working in batch mode, we need to return so-called `exit status'
;; to the calling shell.  Common Lisp has no provision for that ---
;; not even exiting from the toplevel read-eval-print loop.  Most
;; Lisp implementations provide an `exit' function as extensions, though
;; they don't agree on the exact spelling, therefore on the API.

;; The function |coreQuit| is our abstractions over those variabilties.
;; It takes an optional small integer value, the exit status code to
;; return to the calling shell.  When no exit status code is specified,
;; it would return $0$, meaning that everything is OK.
(defun |coreQuit| (&optional (status 0))
  #+:sbcl (sb-ext:quit :unix-status status)
  #+:clisp (ext:quit status)
  #+:gcl (si::bye status)
  #+:ecl (ext:quit status)
  #-(or :sbcl :clisp :gcl :ecl) 
  (error "`coreQuit' not implemented for this Lisp"))


;; 
;; -*- Basic Diagnostic Routines -*-
;; 
;;    For the most basic batch stuff, we want:
;;       (1) fatal error: output message and exit with nonzero status
;;       (2) internal error: same.  This is for use on reporting internal
;;           consistency error.
(defun |diagnosticMessage|(prefix msg)
  (let ((text (concatenate 'string prefix ": " msg)))
    (write-line text *error-output*)))

;; Keep count of number of hard errors.
(defparameter |$errorCount| 0)

(defun |errorCount| nil
  |$errorCount|)

(defun |countError| nil
  (setq |$errorCount| (1+ |$errorCount|)))

(defun |fatalError| (msg)
  (|countError|)
  (|diagnosticMessage| "fatal error" msg)
  (|coreQuit| 1))

(defun |internalError| (msg)
  (|countError|)
  (|diagnosticMessage| "internal error" msg)
  (|coreQuit| 1))

(defun |coreError| (msg)
  (|countError|)
  (|diagnosticMessage| "error"
   (cond ((consp msg) 
          (reduce #'(lambda (x y)
                      (concatenate 'string x y))
                  msg :initial-value ""))
         (t msg))))

(defun |warn| (msg)
  (|diagnosticMessage| "warning"
   (cond ((consp msg) 
          (reduce #'(lambda (x y)
                      (concatenate 'string x y))
                  msg :initial-value ""))
         (t msg))))

;; 
;; -*- Command Line Arguments -*-

(defparameter |$sysOpts| nil)
(defparameter |$sysArgs| nil)

(defun |%systemOptions| ()
  |$sysOpts|)

(defun |%systemArguments| ()
  |$sysArgs|)

;; 
;; Ideally, we would just like to have a traditional command line
;; passing mechanism from the shell to the application.  That 
;; mechanism works fine with GCL.  Some Lisp implementations such as
;; SBCL or CLISP will insist on processing the command lines.  Some
;; such CLISP will barfle when they hit an option they don't 
;; understand.  Which is silly.  It seems like the only common ground,
;; as ever, is to go with the most annoying behaviour and penalize
;; the good "citizen", sensible, Lisp implementations interfaces.
;; Consequently, we have standardize on the the following practice:
;; always issue a double bash (--) after the command line, and afterwards
;; supply options and other arguments.  The double dash has the effect
;; of disuading the underlying lisp implementation of trying to
;; process whatever comes after as options.  

;; Command line arguments: equivalent of traditional `argv[]' from
;;  systems programming world.
(defun |getCommandLineArguments| nil
  #-(or :gcl :sbcl :clisp :ecl) 
  (|fatalError| "don't know how to get command line args")
  (let* ((all-args  
          #+:ecl (ext:command-args)
          #+:gcl si::*command-args*
          #+:sbcl sb-ext::*posix-argv*
          #+:clisp (coerce (ext::argv) 'list))
         (args (member "--" all-args :test #'equal)))
    (cons (car all-args) (if args (cdr args) args))))


;; 
;; -*- Program Startup -*-
;; 

;; The top level entry point to most saved Lisp image.
(defun |main| nil
  (setq *package* (find-package "BOOT"))
  ;; Existing system programming practive, and POSIX, have it
  ;; that the first argument on the command line is the name
  ;; of the current instantiation of the program.
  ;; We require at least two arguments:
  ;;    (0) the program name
  ;;    (1) either one of --help or --version, or
  ;;        a filename.
  (let ((command-args (|getCommandLineArguments|)))
    (when (null command-args) 
      (|internalError| "empty command line args"))
    (when (fboundp '|main|)
      (|coreQuit| (funcall '|main| command-args)))

    ;; Huh, the main entry point was not defined.
    (|fatalError| "missing definition for main function")
    (|coreQuit| 1)))


;; 
;; -*- Building Standalone Executable -*-
;; 
;; Build a standalone excutable from LISP-FILES -- a list of
;; pathnames designating compiled source files (either FASLs, for
;; most Lisp systems, or object files for systems like ECL.)
;; ENTRY-POINT is the entry point of the program.  If not supplied, or
;; if null, then the entry entry is supposed to be the top level
;; read-eval-print loop of original Lisp system.
(defun |link| (core-image lisp-files &optional (entry-point nil))
  (if (and entry-point (stringp entry-point))
      (setq entry-point `(read-from-string ,entry-point)))
  #-:ecl (progn
           (mapcar #'(lambda (p) (|loadOrElse| p)) lisp-files)
           (|saveCore| core-image entry-point))
  #+:ecl (progn
           (unless entry-point
             (setq entry-point si::top-level))
           (c:build-program core-image 
                            :lisp-files lisp-files
                            :epilogue-code `(funcall ,entry-point))
           (|coreQuit|)))


;; 
;; -*- Handling Command Line Arguments -*-
;; 

(defun |handleRequest| (prog-name request options args)
  (let ((driver (|getDriver| request)))
    (when (null driver) 
      (|fatalError| (format nil "invalid option ~S" request)))
    (funcall driver prog-name options args)))
  
(defun |hasHandler?| (request)
  (|getDriver| request))

(defun |useFileType?| (request)
  (get request 'use-file-type))

(defun |handleCommandLine| (prog-name options args)
  (when (or options args)
  (dolist (opt options nil)
    (cond ((eq (car opt) (|Option| "help")) ; print help, get out of here
           (|helpHandler| prog-name))
       
	  ;; If we need to do an action based on the extension of 
	  ;; input file, make sure we have at least one.
          ((|useFileType?| (car opt))
	   (unless args
	     (|coreError| "missing input files")
	     (return t))
           (dolist (f args)
             (let* ((file-type (|getFileType| f))
                    (opt-name (car opt))
                    (request (cons opt-name file-type)))
               (unless (|handleRequest| prog-name request options f)
		 (return nil))))
	   (return t))

	  ;; In general, nothing is to be done for option value 
	  ;; specification.  However, some specifications may require
	  ;; some special handlers.
          ((stringp (cdr opt))
	   (when (|hasHandler?| (car opt))
	     (unless (|handleRequest| prog-name (car opt) options args)
	       (return nil))))
          
	  ;; By now, we are assumed to execute a driver associated
	  ;; with the option.  Hope one is installed...
	  (t (unless (|handleRequest| prog-name (car opt) options args)
	       (return nil))))))

)

;; 
;; -*- --help Handler -*-
;; 

;; Print help screen
(defun |printUsage| (prog-name)
  (write-line "usage:")
  (write-line 
   (concatenate 'string prog-name " -- [options] [files]"))
  (write-line "option:")
  (write-line "   --help                   print this message")
  (write-line "   --system=<dir>           set <dir> to the root directory of running system")
  (write-line "   --sysalg=<dir>           set <dir> to the algebra directory of running system")
  (write-line "   --compile                compile file")
  (write-line "   --output=<out>           set output file to <out>")
  (write-line "   --load-directory=<dir>   use <dir> as search path for modules")
  (write-line "   --make                   create an executable"))

(defun |helpHandler|(prog-name)
  (|printUsage| prog-name)
  (|coreQuit|))

(|installDriver| (|Option| "help") #'|helpHandler|)


;; 
;; -*- --make Handler -*-
;; 

(defun |makeHandler| (prog-name options args)
  (declare (ignore prog-name))
  (unless (> (length args) 0)
    (|fatalError| "--make requires at least one file"))

  (|link| (|getOutputPathname| options) args (|getMainEntryPoint| options))
  (|coreQuit|))

(|installDriver| (|Option| "make") #'|makeHandler|)


;; 
;; -*- --load-directory Handler -*-
;; 

;; Remember value specified for the --load-dircetory option.  Notice
;; that this is the direct handler for that option.  Consequently, it
;; passed all three arguments: PROG-NAME OPTIONS ARGS.  Only the second
;; argument is of interest.
(defun |recordLoadDirectory| (prog-name options args)
  (declare (ignore prog-name args)
           (special |$LoadDirectories|))
  (let ((load-option (assoc (|Option| "load-directory") options)))
    (unless load-option
      (|internalError| "`recordLoadDirectory' called without option"))
    (unless (cdr load-option)
      (|fatalError| "--load-directory option without value"))
    (pushnew (cdr load-option) |$LoadDirectories| :test #'equal)
    ))

(|installDriver| (|Option| "load-directory")  #'|recordLoadDirectory|)

;; 
;; -*- --compile Handler for Lisp Source Files -*-
;; 
(declaim (inline |compileFilePathname|))
(defun |compileFilePathname| (file)
  #-:ecl (compile-file-pathname file)
  #+:ecl (compile-file-pathname file :type :object))

(defun |currentDirectoryName| nil
  (let* ((dir (namestring (truename "")))
         (n (1- (length dir))))
    (if (char= (char dir n) #\/)
        (subseq dir 0 n)
      dir)))    

;; Compile Lisp source files to target object code.  Most of the time
;; this function is called externally to accomplish just that: compile
;; a Lisp file.  So, by default, we exit the read-eval-print loop after
;; the task is done.
;; 
;; NOTE: The Lisp system ECL has an interesting compilation and program
;; build model.  It distinguishes between FASL files (results of 
;; compilation usable as operand to LOAD) and object files (result of
;; compilation usable to build standalone programs).  We are primarily
;; interested in producing compiled files that can be used to produce
;; standalone programs.  Consequently we must convince ECL to produce
;; object files.  Notice that when program components require that
;; previously compiled files be loaded in the startup environment, 
;; the system will load the FASL file.  So, we end up compiling
;; twice: once as object code, once as FASL.  That is surely wrong.  There
;; me be ways to build one from the one with less work.
(defun |compileLispFile| (file out-file)
  ;; When OUT-FILE does not have a specified parent directory, it is
  ;; implied that the compiled file is placed in the current directory.
  ;; This is a very common convention on traditional systems and
  ;; environments.  However GCL would insist to pick the parent
  ;; directory from FILE, which clearly is bogus.  
  ;; Consequently, we must convince GCL to do what we expected.
  #+gcl (when (and (pathname-directory file)
                   (not (pathname-directory out-file)))
          (setq out-file 
                (make-pathname :name (pathname-name out-file)
                               :type (pathname-type out-file)
                               :directory (list (|currentDirectoryName|)))))

  (multiple-value-bind (result warning-p failure-p) 
                       #-:ecl (compile-file file :output-file out-file)
                       #+:ecl (multiple-value-prog1
                               (compile-file file 
                                             :output-file out-file 
                                             :system-p t)
                               (c::build-fasl 
                                (compile-file-pathname out-file)
                                :lisp-files `(,out-file)))
                       (unless result
                         (|coreError| "compilation of Lisp code failed"))
                       (cond ((and failure-p)
                              ;; Since we believe the source code must
                              ;; be fixed, we don't want to leave
                              ;; the generated FASL behing us, as that
                              ;; would confuse both user and tools.
                              (delete-file result)
                              (|coreError| "Lisp code contained errors"))

                             (warning-p
                              (|warn| "Lisp code contained warnings")))
                       result))

(defun |compileLispHandler| (prog-name options in-file)
  (declare (ignore prog-name))
  (let ((out-file (|getOutputPathname| options 
                                       (|compileFilePathname| in-file))))
    (|compileLispFile| in-file out-file)))

(|associateRequestWithFileType| (|Option| "compile") |$LispFileType|
 #'|compileLispHandler|)


;; 
;; -*- Predefined System Entry Point -*-
;; 

;; The top level entry point to most saved Lisp image.
(defun |topLevel|()
  (setq *package* (find-package "AxiomCore"))
  (let ((command-args (|getCommandLineArguments|)))
    (when (null command-args) 
      (|internalError| "empty command line args"))
    ;; Existing system programming practive, and POSIX, have it
    ;; that the first argument on the command line is the name
    ;; of the current instantiation of the program.
    ;; We require at least two arguments:
    ;;    (0) the program name
    ;;    (1) either one of --help or --version, or
    ;;        a filename.
    (multiple-value-bind 
     (options args) (|processCommandLine| (cdr command-args) nil)

     (setq |$sysOpts| options)
     (setq |$sysArgs| args)
                        
     ;; Run the system-specific initialization.
     (when (fboundp '|%sysInit|)
       (funcall '|%sysInit|))
     
     (when (|handleCommandLine| (car command-args) options args)
       (|coreQuit| (if (> (|errorCount|) 0) 1 0))))))


;; 
;; -*- Filesystem Utilities -*-
;; 

;; Make sure that directory name DIR ends with a slash.
(defun |ensureTrailingSlash| (dir)
  (let ((l (length dir)))
    (unless (> l 0)
      (|fatalError| "null directory name"))
    (if (char= (char dir (- l 1)) #\/)
        dir
      (concatenate 'string dir "/"))))


;; 
;; -*- Modules in OpenAxiom -*-
;; 

;; List of directories to search for FASLs.
(defparameter |$LoadDirectories| nil)
;; List of FASLs imported

(defparameter |$ImportedModules| nil)
;; Return true if MODULE is known to have been imported or loaded.

(defun |alreadyLoaded?| (module)
  (member (namestring module) |$ImportedModules| :test #'equal))

;; Remember that MODULE is imported or loaded.
(defun |noteLoadUnit| (module)
  (pushnew (namestring module) |$ImportedModules|))

;; We are searching for MODULE (currently a FASL) in DIRECTORY.  So, this
;; function returns a (tentative) pathname designating that module.
(defun |loadPathname| (module dir)
  (setq dir (|ensureTrailingSlash| dir))
  (make-pathname :directory (pathname-directory dir)
                 :name module
                 #-:ecl :type #-:ecl |$faslType|))

(defun |loadIfPresent| (module)
  (if (|alreadyLoaded?| module)
      module
    (when (load module :if-does-not-exist nil)
      (|noteLoadUnit| module)
      module)))

(defun |loadOrElse| (module)
  (if (|alreadyLoaded?| module)
      module
    (when (load module :if-does-not-exist :error)
      (|noteLoadUnit| module)
      module)))

(defun do-import-module (module directories)
  (unless directories
    (|fatalError| 
     (format nil 
             "module ~S not found in search path ~S"
             module 
             |$LoadDirectories|)))
  (let ((p (|loadPathname| module (car directories))))
    (unless (|loadIfPresent| p)
      (do-import-module module (cdr directories)))))

(defun |importModule| (module)
  (do-import-module module |$LoadDirectories|))

(defmacro import-module (module)
  `(progn (eval-when 
           #+:common-lisp (:compile-toplevel :load-toplevel :execute)
           #-:common-lisp (compile load eval)
                     (|importModule| ,module))))


;; 
;; -*- Feature Tests in Boot -*-
;; 

(defun |%hasFeature| (f)
  (member f *features* :test #'eq))

;; -*- Lisp Implementatiom-dependen Supports -*-

#+ :sbcl
(defun shoe-provide-module(name)
  (load name)
  (provide name))

#+ :sbcl
(eval-when (:load-toplevel :execute)
   (pushnew #'shoe-provide-module sb-ext:*module-provider-functions*))