%% Oh Emacs, this is a -*- Lisp -*- file, despite apperance \documentclass{article} \usepackage{axiom} \title{\File{src/lisp/core.lisp} Pamphlet} \author{Gabriel Dos~Reis} \begin{document} \maketitle \begin{abstract} This pamphlet defines the core of the system utilities for building Boot and Axiom executable.. It essentially etablishes a namespace (package \Code{AxiomCore}) and defines some macros and functions that need to be present during during compilation and executable image construction. \end{abstract} \section{The [[AxiomCore]] package} <>= (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" "getCommandLineArguments" "processCommandLine" "handleCommandLine" "$originalLispTopLevel" "link" "installDriver" "associateRequestWithFileType" "ensureTrailingSlash" "getOutputPathname" "loadPathname" "compileLispFile" "compileLispHandler" "Option" "IMPORT-MODULE" )) (in-package "AxiomCore") @ \section{Base Lisp system top level entry point} <>= ;; 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) @ \section{File types} <>= (defconstant |$LispFileType| "lisp") ;; Extenstion of FASL files. (defconstant |$faslType| (pathname-type (compile-file-pathname "foo.lisp"))) (defconstant |$BootFileType| "boot") (defconstant |$LibraryFileType| "spad") (defconstant |$ScriptFileType| "input") @ \subsection{File type canonilization} <>= (defun |getFileType|(file) (let ((file-type (pathname-type file))) (cond ((or (equal "clisp" file-type) (equal "lsp" file-type)) |$LispFileType|) (t file-type)))) @ \section{Drivers table} \subsection{The 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)) @ \subsection{Obtaining a driver for a request} <>= ;; Look up the driver that can handle REQUEST. Returns nil when ;; no driver exists. (defun |getDriver| (request) (gethash request |$driverTable|)) @ \subsection{Installing a driver for a request} <>= (defun |installDriver| (request driver) (when (|getDriver| request) (|internalError| "attempt to override driver")) (setf (gethash request |$driverTable|) driver)) @ <>= ;; Register DRIVER for a REQUEST (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))) @ \subsection{Making names for options} <>= (defun |Option| (msg) (intern msg (find-package "AxiomCore"))) @ \subsection{Parsing command line options} <>= ;; 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))) @ \section{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. \subsection{Pathname of output program} <>= (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))) @ \subsection{User-supplied main entry point} <>= (defun |getMainEntryPoint| (options) (|getOptionValue| (|Option| "main") options)) @ \subsection{Saving Lisp image to disk} <>= ;; 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")) @ \section{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")) @ \section{Basic diagnostic routines} <>= ;; Basic diagnostic machinery: ;; 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)))) @ \section{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)))) @ \section{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))) @ \section{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|))) @ \section{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))))) @ \subsection{The \verb!--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|) @ \subsection{The \verb!--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|) @ \subsection{The \verb!--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|) @ \section{Compiling Lisp source files} <>= (declaim (inline |compileFilePathname|)) (defun |compileFilePathname| (file) #-:ecl (compile-file-pathname file) #+:ecl (compile-file-pathname file :type :object)) ;; 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) (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) (|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|) @ \section{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))))) @ \section{File system} \subsection{Directory name} <>= ;; 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 "/")))) @ \section{Modules in Axiom} \subsection{Module load directories} <>= ;; List of directories to search for FASLs. (defparameter |$LoadDirectories| nil) @ \subsection{Keeping track of imported modules} \subsubsection{List of imported modules} <>= ;; List of FASLs imported (defparameter |$ImportedModules| nil) @ \subsubsection{Updating the list of imported modules} <>= ;; 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|)) @ \subsection{Load pathname} <>= ;; 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|)) @ \subsection{Module import} <>= (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)))) @ \subsection{Lisp implementation-dependent support} \subsubsection{SBCL} <>= #+ :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*)) @ \section{Putting it all together} <<*>>= <> ;(proclaim '(optimize safety)) <> @ \section{License} <>= ;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; 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. @ \end{document}