;; Ô 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 OpenAxiom 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 "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=: specify as the root directory ;; --sysalg=: specify 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) (let ((output-option (assoc (|Option| "output") options))) (when 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)))) (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 OpenAxiom 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. ;; Note, despite the name LISP-FILEs, we do not expect bare Lisp source ;; files here. We do insist on FASLs. There is no check for that at ;; this point. You have been warned. (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 (mapcar #'|compileFilePathname| lisp-files) :epilogue-code `(,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= set to the root directory of running system") (write-line " --sysalg= set to the algebra directory of running system") (write-line " --compile compile file") (write-line " --output= set output file to ") (write-line " --load-directory= use 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| (or (|getOutputPathname| options) "a.out") 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 with a 2-step ;; compilation process for ECL: ;; (1) compile as object code; ;; (2) build a FASL from the result of (1). (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 (|compileFilePathname| (or (|getOutputPathname| options) 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*))