lisp-invocation.lisp 9.81 KB
Newer Older
1
2
3
;;; Lisp implementations
#+xcvb (module (:build-depends-on ("/asdf")))

4
5
(uiop:define-package :lisp-invocation/lisp-invocation
  (:nicknames :lisp-invocation)
6
7
  (:use :cl :uiop)
  (:export
8
9
   #:lisp-implementation
   #:simple-lisp-implementation
10
   #:define-lisp-implementation
11
12
   #:get-lisp-implementation
   #:ensure-path-executable
13
   #:lisp-implementation-implementation-type
14
15
16
17
18
19
20
   #:lisp-implementation-fullname
   #:lisp-implementation-name
   #:lisp-implementation-feature
   #:lisp-implementation-flags
   #:lisp-implementation-eval-flag
   #:lisp-implementation-load-flag
   #:lisp-implementation-arguments-end
21
   #:lisp-implementation-environment-variable
22
23
24
25
26
27
   #: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
28
   #:lisp-implementation-invoker
29
30
   #:lisp-environment-variable-name
   #:lisp-invocation-arglist
31
   #:lisp-implementation-invocation-arglist
32
   #:invoke-lisp #:invoke-lisp-directly #:invoke-lisp-via-script
33
   #:register-lisp-implementation
34
   #:register-lisp-implementation*
35
36
37
38
39
40
41
42
   #:quit-form
   #:save-image-form))

(in-package :lisp-invocation)

(defvar *lisp-implementations* (make-hash-table :test 'equal)
  "Dictionary of known Lisp implementations")

43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
(defclass lisp-implementation ()
  (;; the first also names the environment variable for the lisp-path, as per cl-launch
   (identifiers :initarg :identifiers :reader lisp-implementation-identifiers)))

(defmethod lisp-implementation-implementation-type ((impl lisp-implementation))
  (first (lisp-implementation-identifiers impl)))

(defclass simple-lisp-implementation (lisp-implementation)
  ((fullname :initarg :fullname :reader lisp-implementation-fullname)
   (name :initarg :name :reader lisp-implementation-name)
   (feature :initarg :feature :reader lisp-implementation-feature)
   (environment-variable :initform nil :initarg :environment-variable :reader lisp-implementation-environment-variable)
   (flags :initarg :flags :reader lisp-implementation-flags)
   (eval-flag :initarg :eval-flag :reader lisp-implementation-eval-flag)
   (load-flag :initarg :load-flag :reader lisp-implementation-load-flag)
   (arguments-end :initarg :arguments-end :reader lisp-implementation-arguments-end)
   (image-flag :initarg :image-flag :reader lisp-implementation-image-flag)
   (image-executable-p :initarg :image-executable-p :reader lisp-implementation-image-executable-p)
   (default-image :initform nil :initarg :default-image :reader lisp-implementation-default-image)
   (standalone-executable :initarg :standalone-executable :reader lisp-implementation-standalone-executable)
   (argument-control :initarg :argument-control :reader lisp-implementation-argument-control)
   (disable-debugger :initarg :disable-debugger :reader lisp-implementation-disable-debugger)
   (directory-variable :initform nil :initarg :directory-variable :reader lisp-implementation-directory-variable)
   ;; fasl-type cfasl-type
   (invoker :initform nil :initarg :invoker :reader lisp-implementation-invoker)
   (quit-format :initarg :quit-format :reader lisp-implementation-quit-format)
   (dump-format :initarg :dump-format :reader lisp-implementation-dump-format)))

(defmacro define-lisp-implementation (key (&optional class) &rest keys)
  `(apply 'register-lisp-implementation ',class ',key ',keys))

(defun register-lisp-implementation (class identifiers &rest keys)
75
76
77
  "Register the lisp implementation identified by the IDENTIFIERS argument (a
keyword or list of keywords), with given option KEYS."
  (let* ((identifiers (ensure-list identifiers))
78
79
         (implementation (apply #'make-instance (or class 'simple-lisp-implementation)
                                :identifiers identifiers keys)))
80
    (dolist (id identifiers)
81
      (assert (keywordp id))
82
83
      (setf (gethash id *lisp-implementations*) implementation))))

84
85
86
87
(defun register-lisp-implementation* (x)
  "Register the lisp implementation described by the list X, which consists of a name
followed by a plist of keywords and arguments."
  (apply 'register-lisp-implementation x))
88

89
90
91
(defun get-lisp-implementation (&optional (implementation-type (implementation-type)))
  (or (gethash implementation-type *lisp-implementations*)
      (error "Unknown Lisp implementation type ~S" implementation-type)))
92
93
94
95
96
97
98
99
100

(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)))))

101
(defun lisp-environment-variable-name (&key (type (implementation-type)) prefix suffix)
102
103
104
  (let* ((implementation (get-lisp-implementation type))
         (name (or (lisp-implementation-environment-variable implementation)
                (first (lisp-implementation-identifiers implementation)))))
105
106
107
    (when (eq prefix t) (setf prefix "X"))
    (when (eq suffix t) (setf prefix "_OPTIONS"))
    (format nil "~@[~A~]~:@(~A~)~@[~A~]" prefix name suffix)))
108

109
110
111
112
113
114
115
116
(defun lisp-invocation-arglist (&rest keys &key implementation-type &allow-other-keys)
  (apply 'lisp-implementation-invocation-arglist
         (get-lisp-implementation implementation-type)
         (remove-plist-key :implementation-type keys)))

(defmethod lisp-implementation-invocation-arglist
    ((implementation simple-lisp-implementation)
     &key
117
118
       lisp-path
       (lisp-flags :default)
119
       (image-path nil image-path-p)
120
121
122
123
       load
       eval
       arguments
       debugger
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
       cross-compile
       console)
  (declare (ignore console))
  (nest
   (with-slots (name flags disable-debugger load-flag eval-flag
                image-flag default-image image-executable-p standalone-executable
                arguments-end argument-control)
       implementation)
   (let ((implementation-type (lisp-implementation-implementation-type implementation)))
    (unless image-path-p (setf image-path default-image)))
   (append
    (when (or (null image-path) (not image-executable-p))
      (ensure-list
       (or
        (when (consp lisp-path) lisp-path)
        (ensure-path-executable lisp-path)
        (getenvp (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)))))
            (ensure-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)))))
166

167
168
169
170
171
172
173
174
175
176
(defun lisp-invoker (&optional (implementation-type (implementation-type)))
  (or (lisp-implementation-invoker (get-lisp-implementation implementation-type))
      'invoke-lisp-directly))

(defun invoke-lisp
    (&rest keys
     &key (implementation-type (implementation-type))
       lisp-path
       (lisp-flags :default)
       image-path
177
       console
178
179
180
181
182
183
184
       load
       eval
       arguments
       debugger
       cross-compile
       (run-program 'run-program)
       run-program-args)
185
186
  (declare (ignore lisp-path lisp-flags image-path console load eval arguments debugger
                   cross-compile run-program run-program-args))
187
188
189
190
191
192
193
194
195
  (apply (lisp-invoker implementation-type)
         keys))

(defun invoke-lisp-directly
    (&rest keys
     &key (implementation-type (implementation-type))
       lisp-path
       (lisp-flags :default)
       image-path
196
       console
197
198
199
200
201
202
203
204
       load
       eval
       arguments
       debugger
       cross-compile
       (run-program 'run-program)
       run-program-args)
  (declare (ignore implementation-type lisp-path lisp-flags image-path
205
                   console load eval arguments debugger cross-compile))
206
207
208
209
210
211
212
213
214
215
  (apply run-program
         (apply 'lisp-invocation-arglist (remove-plist-keys '(:run-program :run-program-args) keys))
         run-program-args))

(defun invoke-lisp-via-script
    (&rest keys
     &key implementation-type
       lisp-path
       lisp-flags
       image-path
216
       console
217
218
219
220
221
222
223
224
       load
       eval
       arguments
       debugger
       cross-compile
       (run-program 'run-program)
       run-program-args)
  (declare (ignore implementation-type lisp-path lisp-flags image-path debugger cross-compile
225
                   console run-program run-program-args))
226
227
228
229
230
231
232
233
234
235
236
237
238
  (with-temporary-file (:stream s :pathname p :type "lisp")
    (when arguments
      (format s "(unless (find-package :uiop/image) (defpackage :uiop/image (:use :cl)))~%~
                 (defparameter uiop/image::*command-line-arguments* '~S)~%"
              arguments))
    (loop :for l :in (ensure-list load) :do (format s "(cl:load ~S)~%" l))
    (format s "~@[~A~]~%" eval)
    :close-stream
    (apply 'invoke-lisp-directly
           :load (native-namestring p)
           (remove-plist-keys '(:load :eval) keys))))


239
240
241
242
243
244
245
246
247
248
249
250
;;; 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))