Commit 8e2c135e authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Spawn lisp-invocation off of xcvb.

parents
Copyright (c) 2008-2011 ITA Software, Inc.
Copyright (c) 2011-2012 Google, Inc.
Permission is hereby granted, free of charge,
to any person obtaining a copy of
this software and associated documentation files (the "Software"),
to deal in the Software without restriction, including without limitation
the rights to use, copy, modify, merge, publish, distribute, sublicense,
and/or sell copies of the Software, and
to permit persons to whom the Software is furnished to do so,
subject to the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE
FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
DEALINGS IN THE SOFTWARE.
;;; -*- mode: lisp -*-
(module
(:fullname "lisp-invocation"
:author ("Francois-Rene Rideau")
:maintainer "Francois-Rene Rideau"
:licence "MIT" ;; MIT-style license. See LICENSE
:description "Lisp invocation"
:long-description "Invoke another Common Lisp as a separate (possibly remote) process
from your current Common Lisp image."
:build-depends-on ((:asdf "asdf")) ;; actually, UIOP
:depends-on ("lisp-invocation")
:supersedes-asdf ("lisp-invocation")
:build-image nil))
;;; -*- mode: lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; Free Software available under an MIT-style license. See LICENSE ;;;
;;; ;;;
;;; Copyright (c) 2008-2012 ITA Software, Inc. All rights reserved. ;;;
;;; ;;;
;;; Original author: Francois-Rene Rideau ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :asdf)
(defsystem :lisp-invocation
:author ("Francois-Rene Rideau")
:maintainer "Francois-Rene Rideau"
:licence "MIT"
:description "Invoking Lisp subprocesses from Lisp"
:long-description "lisp-invocation allows you to portably execute Lisp code
as subprocesses of a current Lisp process.
All known command-line accessible Common Lisp implementations are supported."
:depends-on (#-asdf3 :uiop)
:components
((:file "lisp-invocation")))
;;; Lisp implementations
#+xcvb (module (:build-depends-on ("/asdf")))
(defpackage :lisp-invocation
(:use :cl :uiop)
(:export
#:get-lisp-implementation
#:ensure-path-executable
#:lisp-implementation-fullname
#:lisp-implementation-name
#:lisp-implementation-feature
#:lisp-implementation-flags
#:lisp-implementation-eval-flag
#:lisp-implementation-load-flag
#:lisp-implementation-arguments-end
#:lisp-implementation-image-flag
#:lisp-implementation-image-executable-p
#:lisp-implementation-standalone-executable
#:lisp-implementation-argument-control
#:lisp-implementation-disable-debugger
#:lisp-implementation-directory-variable
#:lisp-environment-variable-name
#:lisp-invocation-arglist
#:quit-form
#:save-image-form))
(in-package :lisp-invocation)
(defvar *lisp-implementations* (make-hash-table :test 'equal)
"Dictionary of known Lisp implementations")
(defstruct (lisp-implementation)
identifiers
fullname
name
feature
flags
eval-flag
load-flag
arguments-end
image-flag
image-executable-p
standalone-executable
argument-control
disable-debugger
directory-variable
;; fasl-type cfasl-type
quit-format
dump-format)
(defmacro define-lisp-implementation (key () &rest keys)
`(apply 'register-lisp-implementation ',key ',keys))
(defun register-lisp-implementation (key &rest keys)
(let* ((identifiers (if (consp key) key (list key)))
(implementation (apply #'make-lisp-implementation :identifiers identifiers keys)))
(dolist (id identifiers)
(setf (gethash id *lisp-implementations*) implementation))))
(defun get-lisp-implementation (&optional (implementation-type (implementation-type)))
(or (gethash implementation-type *lisp-implementations*)
(error "Unknown Lisp implementation type ~S" implementation-type)))
(define-lisp-implementation :abcl ()
:fullname "Armed Bear Common Lisp"
:name "abcl"
:feature :abcl
:flags ("--noinform" "--noinit" "--nosystem")
:eval-flag "--eval"
:load-flag "--load"
:arguments-end "--"
:image-flag nil
:image-executable-p t
:standalone-executable nil
:argument-control t
:disable-debugger ("--batch") ;; ???
:quit-format "(ext:quit :status ~A)"
:dump-format nil)
(define-lisp-implementation (:allegro :acl) ()
:fullname "Allegro CL"
:name "alisp"
:feature :allegro
:flags ("-qq") ; on windows, +c ? On Allegro 5 and earlier, -Q and/or -QQ ?
:eval-flag "-e"
:load-flag "-L"
; :quit-flags ("-kill")
:arguments-end "--"
:image-flag "-I"
:image-executable-p nil
:standalone-executable nil
:argument-control t
:disable-debugger ("-batch") ; see also -#D -#C -#!
:quit-format "(excl:exit ~A :quiet t)"
:dump-format "(progn (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) (excl:dumplisp :name ~A :suppress-allegro-cl-banner t))")
(define-lisp-implementation (:clozure :ccl) () ;; demand 1.4 or later.
:fullname "Clozure Common Lisp"
;; formerly OpenMCL, forked from MCL, formerly Macintosh Common Lisp, nee Coral Common Lisp
;; Random note: (finish-output) is essential for ccl, that won't do it by default,
;; unlike the other lisp implementations tested.
:name "ccl"
:feature :clozure
:flags ("--no-init" "--quiet")
:eval-flag "--eval" ; -e
:load-flag "--load"
:image-flag "--image-name" ; -I
:image-executable-p t
:standalone-executable t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ("--batch")
:directory-variable "CCL_DEFAULT_DIRECTORY"
:quit-format "(let ((x ~A)) (finish-output *standard-output*) (finish-output *error-output*) (ccl:quit x))"
:dump-format "(save-application ~S :prepend-kernel t)")
(define-lisp-implementation :clisp ()
:fullname "GNU CLISP"
:name "clisp"
:feature :clisp
:flags ("-norc" "--quiet" "--quiet")
:eval-flag "-x"
:load-flag "-i"
:arguments-end "--"
:image-executable-p t
:image-flag "-M"
:standalone-executable t ;; requires clisp 2.48 or later
:argument-control t ;; *BUT* even a standalone-executable always accepts --clisp-x and such.
:disable-debugger ("-on-error" "exit") ;; otherwise, -on-error debug
:quit-format "(ext:quit ~A)"
:dump-format "(ext:saveinitmem ~S :quiet t :executable t)")
(define-lisp-implementation (:cmucl :cmu) ()
:fullname "CMU CL"
:name "cmucl"
:feature :cmu
:flags ("-quiet" "-noinit")
:eval-flag "-eval"
:load-flag "-load"
:arguments-end "--"
:image-executable-p t
:image-flag "-core"
:argument-control t
:disable-debugger ("-batch")
:quit-format "(unix:unix-exit ~A)"
:dump-format "(extensions:save-lisp ~S :executable t)")
(define-lisp-implementation (:corman :cormanlisp) () ;; someone please add more complete support
:fullname "Corman Lisp"
:name () ;; There's a clconsole.exe, but what are the options?
:feature :cormanlisp
:quit-format "(win:exitprocess ~A)")
(define-lisp-implementation :ecl () ;; demand 10.4.2 or later.
:fullname "Embeddable Common-Lisp"
:name "ecl"
:feature :ecl
:flags ("-norc")
:eval-flag "-eval" ; -e
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ()
:quit-format "(si:quit ~A)"
:dump-format nil) ;; Cannot dump with ECL. Link instead.
(define-lisp-implementation :gcl () ;; Demand 2.7.0, if it is ever released. In ANSI mode.
:fullname "GNU Common Lisp"
:name "gcl" ;; we might export GCL_ANSI=t or something
:feature :gcl
:flags ()
:eval-flag "-eval" ; -e
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--" ;; -f ?
:disable-debugger ("-batch")
:quit-format "(lisp:quit ~A)"
:dump-format "(progn (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) (si::save-system ~A))")
(define-lisp-implementation (:lispworks :lw) ()
:fullname "LispWorks"
:name "lispworks" ;; This assumes you dumped a proper image for batch processing...
:feature :lispworks
:flags ("-site-init" "-" "-init" "-")
:eval-flag "-eval"
:load-flag "-load" ;; Is this what we want? See also -build as magic load.
:arguments-end nil ; What's the deal with THIS? "--"
:image-flag nil
:image-executable-p t
:standalone-executable t
:argument-control t
:disable-debugger ()
:quit-format "(lispworks:quit :status ~A :confirm nil :return nil :ignore-errors-p t)"
;; when you dump, you may also have to (system::copy-file ".../lwlicense" (make-pathname :name "lwlicense" :type nil :defaults filename))
:dump-format "(lispworks:deliver 'xcvb-driver:resume ~A 0 :interface nil)") ; "(hcl:save-image ~A :environment nil)"
(define-lisp-implementation :lispworks-personal ()
:fullname "LispWorks Personal Edition"
:name () ;; In LispWorks Personal, the slave worker executes you!
:feature :lispworks-personal-edition)
(define-lisp-implementation :mkcl ()
:fullname "ManKai Common-Lisp"
:name "mkcl"
:feature :mkcl
:flags ("-norc")
:eval-flag "-eval" ; -e
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ()
:quit-format "(mk-ext:quit :exit-code ~A)"
:dump-format nil) ;; Cannot dump with ECL. Link instead.
(define-lisp-implementation :sbcl ()
:fullname "Steel Bank Common Lisp"
:name "sbcl"
:feature :sbcl
:flags ("--noinform" "--no-userinit" "--no-sysinit") ;; minimize non-determinism form user's env
:eval-flag "--eval" ;; Note: SBCL's eval can only handle one form per argument.
:load-flag "--load"
:arguments-end "--end-toplevel-options"
:image-flag "--core"
:image-executable-p t
:standalone-executable t ;; requires sbcl 1.0.21.24 or later.
:argument-control t
:disable-debugger ("--disable-debugger")
:directory-variable "SBCL_HOME"
:quit-format "(let ((exit (find-symbol \"EXIT\" :sb-ext)) (quit (find-symbol \"QUIT\" :sb-ext)) (code ~A)) (cond (exit (funcall exit :code code)) (quit (funcall quit :unix-status code))))"
:dump-format "(sb-ext:save-lisp-and-die ~S :executable t)")
(define-lisp-implementation :scl ()
:fullname "Scieneer Common Lisp" ; use 1.3.9 or later
:name "scl"
:feature :scl
:flags ("-quiet" "-noinit")
:eval-flag "-eval"
:load-flag "-load"
:arguments-end "--"
:image-flag "-core"
:argument-control nil ;; cmucl will always scan all the arguments for -eval... EVIL!
:disable-debugger ("-batch")
:quit-format "(unix:unix-exit ~A)"
:dump-format "(extensions:save-lisp ~S)")
(define-lisp-implementation :xcl ()
:fullname "XCL"
:name "xcl"
:feature :xcl
:flags ("--no-userinit")
:eval-flag "--eval"
:load-flag "--load"
:arguments-end "--"
:image-flag nil
:image-executable-p nil
:standalone-executable nil
:disable-debugger ()
:quit-format "(ext:quit :status ~A)"
:dump-format nil)
(defun ensure-path-executable (x)
(when x
(let ((n (native-namestring x)))
(cond
((asdf::absolute-pathname-p x) n)
((asdf::os-unix-p) (format nil "./~A" n))
(t n)))))
(defun lisp-environment-variable-name (&key (type (implementation-type)) prefix)
(if (eq prefix t) (setf prefix "X"))
(format nil "~@[~A~]~:@(~A~)" prefix type))
(defun lisp-invocation-arglist
(&key (implementation-type (implementation-type))
lisp-path
(lisp-flags :default)
image-path
load
eval
arguments
debugger
(cross-compile t))
(with-slots (name flags disable-debugger load-flag eval-flag
image-flag image-executable-p standalone-executable
arguments-end argument-control)
(get-lisp-implementation implementation-type)
(append
(when (or (null image-path) (not image-executable-p))
(list (or
(when (consp lisp-path) lisp-path)
(ensure-path-executable lisp-path)
(getenv (lisp-environment-variable-name
:type implementation-type :prefix (when cross-compile "X")))
name)))
(when (and image-path (not image-executable-p))
(list image-flag))
(when image-path
(list
(if image-executable-p
(ensure-path-executable image-path)
image-path)))
(if (eq lisp-flags :default)
flags
lisp-flags)
(unless debugger
disable-debugger)
(mapcan (if load-flag
(lambda (x) (list load-flag (native-namestring x)))
(lambda (x) (list eval-flag (format nil "(load ~S)" (native-namestring x)))))
(if (listp load) load (list load)))
(when eval
(list eval-flag eval))
(when arguments
(unless argument-control
(error "Can't reliably pass arguments to Lisp implementation ~A" implementation-type))
(cons arguments-end arguments)))))
;;; Avoiding use of a compiled-in driver in the build process
(defun quit-form (&key code (implementation-type (implementation-type)))
"Returns the correct form to quit lisp, based on the value of lisp-implementation.
Can optionally be given a unix status CODE to exit with"
(format nil (slot-value (get-lisp-implementation implementation-type) 'quit-format)
(or code 0)))
(defun save-image-form (filepath &optional (implementation-type (implementation-type)))
"Returns the lisp form to save the lisp image to the given filepath"
(format nil (slot-value (get-lisp-implementation implementation-type) 'dump-format)
filepath))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment