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/ChangeLog | 14 + src/lisp/Makefile.in | 15 +- src/lisp/Makefile.pamphlet | 15 +- src/lisp/core.lisp.in | 743 ++++++++++++++++++++++++++++++++++++++++ src/lisp/core.lisp.pamphlet | 809 -------------------------------------------- 5 files changed, 773 insertions(+), 823 deletions(-) create mode 100644 src/lisp/core.lisp.in delete mode 100644 src/lisp/core.lisp.pamphlet (limited to 'src') diff --git a/src/lisp/ChangeLog b/src/lisp/ChangeLog index b4b96645..a60858fd 100644 --- a/src/lisp/ChangeLog +++ b/src/lisp/ChangeLog @@ -1,3 +1,17 @@ +2007-09-08 Gabriel Dos Reis + + * 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. + 2007-09-08 Gabriel Dos Reis * core.lisp.pamphlet (|%hasFeature|): New. diff --git a/src/lisp/Makefile.in b/src/lisp/Makefile.in index 26087819..b1dba434 100644 --- a/src/lisp/Makefile.in +++ b/src/lisp/Makefile.in @@ -26,7 +26,8 @@ COBJEXT = $(if $(findstring mingw, $(target)),$(OBJEXT),lo) ## code from core.lisp. However, the general interface compiler::link ## that GCL provides for that task is unsupported on Windows platforms. ## So, we instruct GCL so load the source file instead. -CORE = $(if $(findstring mingw, $(target)),core.lisp,core.$(FASLEXT)) +fasl_ext = $(if $(findstring mingw, $(target)),.lisp,.$(FASLEXT)) +FASLS = $(patsubst %,"%", $(addsuffix $(fasl_ext),core)) .PHONY: all all-lisp all: all-ax all-lisp @@ -58,7 +59,7 @@ ifeq (@axiom_lisp_flavor@,gcl) ' (compiler::*ld* (concatenate (quote string) ' \ ' $(GCL_LTLD) ' \ ' sys-ld))) ' \ - '(compiler::link (quote ("$(CORE)")) "lisp$(EXEEXT)" ' \ + '(compiler::link (quote ($(FASLS))) "lisp$(EXEEXT)" ' \ ' (format nil "(progn (let ((*load-path* (cons ~S *load-path*))'\ ' (si::*load-types* ~S))' \ ' (compiler::emit-fn t))' \ @@ -75,22 +76,22 @@ endif base-lisp$(EXEEXT): core.$(FASLEXT) $(AXIOM_LISP) \ - $(eval_flags) '(progn #+:sbcl (require :sb-cltl2))' \ - $(eval_flags) '(load "$<")' \ + $(eval_flags) '(load "core")' \ $(eval_flags) '(|AxiomCore|::|link| "$@" (quote nil) (function |AxiomCore|::|topLevel|))' -core.lisp: $(srcdir)/core.lisp.pamphlet - $(axiom_build_document) --tangle --output=$@ $< +core.lisp: $(srcdir)/core.lisp.in + cd $(top_builddir) && \ + $(SHELL) ./config.status src/lisp/sys-conf.lisp core.$(FASLEXT): core.lisp $(AXIOM_LISP) $(quiet_flags) \ - $(eval_flags) '(progn #+:sbcl (require :sb-cltl2))' \ $(eval_flags) '(progn #-:ecl (compile-file "$<"))' \ $(eval_flags) '(progn #+:ecl (progn (require (quote cmp)) (compile-file "$<" :system-p t) (c::build-fasl "$@" :lisp-files (quote ("core.$(OBJEXT)")))))' \ $(eval_flags) '(quit)' mostlyclean-local: + rm -f *.$(FASLEXT) @rm -f $(OUT)/lisp$(EXEEXT) lisp$(EXEEXT) @rm -f stamp diff --git a/src/lisp/Makefile.pamphlet b/src/lisp/Makefile.pamphlet index 59031546..b5bb04c4 100644 --- a/src/lisp/Makefile.pamphlet +++ b/src/lisp/Makefile.pamphlet @@ -46,7 +46,7 @@ ifeq (@axiom_lisp_flavor@,gcl) ' (compiler::*ld* (concatenate (quote string) ' \ ' $(GCL_LTLD) ' \ ' sys-ld))) ' \ - '(compiler::link (quote ("$(CORE)")) "lisp$(EXEEXT)" ' \ + '(compiler::link (quote ($(FASLS))) "lisp$(EXEEXT)" ' \ ' (format nil "(progn (let ((*load-path* (cons ~S *load-path*))'\ ' (si::*load-types* ~S))' \ ' (compiler::emit-fn t))' \ @@ -63,16 +63,15 @@ endif base-lisp$(EXEEXT): core.$(FASLEXT) $(AXIOM_LISP) \ - $(eval_flags) '(progn #+:sbcl (require :sb-cltl2))' \ - $(eval_flags) '(load "$<")' \ + $(eval_flags) '(load "core")' \ $(eval_flags) '(|AxiomCore|::|link| "$@" (quote nil) (function |AxiomCore|::|topLevel|))' -core.lisp: $(srcdir)/core.lisp.pamphlet - $(axiom_build_document) --tangle --output=$@ $< +core.lisp: $(srcdir)/core.lisp.in + cd $(top_builddir) && \ + $(SHELL) ./config.status src/lisp/sys-conf.lisp core.$(FASLEXT): core.lisp $(AXIOM_LISP) $(quiet_flags) \ - $(eval_flags) '(progn #+:sbcl (require :sb-cltl2))' \ $(eval_flags) '(progn #-:ecl (compile-file "$<"))' \ $(eval_flags) '(progn #+:ecl (progn (require (quote cmp)) (compile-file "$<" :system-p t) (c::build-fasl "$@" :lisp-files (quote ("core.$(OBJEXT)")))))' \ $(eval_flags) '(quit)' @@ -108,7 +107,8 @@ COBJEXT = $(if $(findstring mingw, $(target)),$(OBJEXT),lo) ## code from core.lisp. However, the general interface compiler::link ## that GCL provides for that task is unsupported on Windows platforms. ## So, we instruct GCL so load the source file instead. -CORE = $(if $(findstring mingw, $(target)),core.lisp,core.$(FASLEXT)) +fasl_ext = $(if $(findstring mingw, $(target)),.lisp,.$(FASLEXT)) +FASLS = $(patsubst %,"%", $(addsuffix $(fasl_ext),core)) .PHONY: all all-lisp all: all-ax all-lisp @@ -122,6 +122,7 @@ stamp: $(OUT)/lisp$(EXEEXT) <> mostlyclean-local: + rm -f *.$(FASLEXT) @rm -f $(OUT)/lisp$(EXEEXT) lisp$(EXEEXT) @rm -f stamp 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*)) diff --git a/src/lisp/core.lisp.pamphlet b/src/lisp/core.lisp.pamphlet deleted file mode 100644 index 2e12ebc9..00000000 --- a/src/lisp/core.lisp.pamphlet +++ /dev/null @@ -1,809 +0,0 @@ -%% 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" - - "%hasFeature" - - "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)) - -(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|) -@ - - -\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} - -\subsectionFeature tests} - -<>= -(defun |%hasFeature| (f) - (member f *features* :test #'eq)) -@ - -\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} -- cgit v1.2.3