From 157f4368b440536001959ad58167b09357273edc Mon Sep 17 00:00:00 2001 From: dos-reis Date: Sat, 8 Sep 2007 14:15:37 +0000 Subject: * configure.ac.pamphlet (axiom_optimize_options): New substitued variable. Genrate src/lisp/core.lisp at configure time. * configure.ac: Regenerate. * configure: Likewise. * config/setup-dep.mk ($(top_builddir)/src/lisp/core.lisp): New rule. src/lisp/ * Makefile.pamphlet (fasl_ext): New. Factor out the logic for computing file extensions. (FASLS): Rename from CORE. Use it to compute the list of files to load. ($(OUT)/lisp$(EXEEXT)): Adjust. (base-lisp$(EXEEXT)): sb-cltl2 module is no longer need. (core.lisp): Now depend on core.lisp.in. Regenerate if necessary. (mostlyclean-local): Remove FASLs too. * Makefile.in: Regenerate. * core.lisp.in: New. * core.lisp.pamphlet: Move content to core.lisp.in. Remove. --- src/lisp/core.lisp.in | 743 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 743 insertions(+) create mode 100644 src/lisp/core.lisp.in (limited to 'src/lisp/core.lisp.in') diff --git a/src/lisp/core.lisp.in b/src/lisp/core.lisp.in new file mode 100644 index 00000000..8722220c --- /dev/null +++ b/src/lisp/core.lisp.in @@ -0,0 +1,743 @@ +;; Ô 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 "quit" + "fatalError" + "internalError" + "error" + "errorCount" + "countError" + "warn" + + "%hasFeature" + + "$hostPlatform" + "$buildPlatform" + "$targetPlatform" + + "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@") + +;; 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 +;; --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 |quit| 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 |quit| (&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 "`quit' 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) + (|quit| 1)) + +(defun |internalError| (msg) + (|countError|) + (|diagnosticMessage| "internal error" msg) + (|quit| 1)) + +(defun |error| (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 -*- +;; +;; 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|) + (|quit| (funcall '|main| command-args))) + + ;; Huh, the main entry point was not defined. + (|fatalError| "missing definition for main function") + (|quit| 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)) + (|quit|))) + + +;; +;; -*- 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) + ;; If no argument was specified on command line, then pretend + ;; we must act as the underlying Lisp system's REPL. This is hard + ;; to do portabl and correctly, for obvious reasons So what follows + ;; is an approximation, good enough for now. FIXME: revisit this + ;; gorss hack. + (unless (or options args) + ;; GCL called us through system::*top-level-hook* which we set + ;; in a previous life. Now unset it, otherwise, it will call + ;; us again, and we will find ourselves in the same place + ;; again, again, until death follows. + #+:gcl (setq system::*top-level-hook* nil) + (funcall |$originalLispTopLevel|)) + + (dolist (opt options) + (cond ((eq (car opt) (|Option| "help")) ; print help, get out of here + (|helpHandler| prog-name)) + + ((null args) ; we must have at least one arg + (|printUsage| prog-name) + (|quit| 1)) + + ((|useFileType?| (car opt)) ; process based on file type + (dolist (f args) + (let* ((file-type (|getFileType| f)) + (opt-name (car opt)) + (request (cons opt-name file-type))) + (|handleRequest| prog-name request options f)))) + + ((stringp (cdr opt)) ; option value + (when (|hasHandler?| (car opt)) + (|handleRequest| prog-name (car opt) options args))) + + (t ; assume we must execute this + (|handleRequest| prog-name (car opt) options args))))) + + + +;; +;; -*- --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 " --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) + (|quit|)) + +(|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)) + (|quit|)) + +(|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 + (|error| "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) + (|error| "Lisp code contained errors")) + + (warning-p + (|warn| "Lisp code contained warnings"))) + result)) + +(defun |compileLispHandler| (prog-name options file) + (declare (ignore prog-name)) + (let ((out-file (|getOutputPathname| options + (|compileFilePathname| file)))) + (|compileLispFile| 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) + + ;; Push into the system's preferred namespace. Ideally, this should + ;; be run of initialization code if needed. However, a curiously + ;; nasty bug in GCL prevents us from expressing the natural semantics + ;; in a clean way. + (when (boundp '|$sysScope|) + (setq *package* (find-package (symbol-value '|$sysScope|)))) + + (|handleCommandLine| (car command-args) options args) + (|quit| (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*)) -- cgit v1.2.3