 |
timage.lisp - clic - Clic is an command line interactive client for gopher writ… |
 |
git clone git://bitreich.org/clic/ git://hg6vgqziawt5s4dj.onion/clic/ |
 |
Log |
|
Files |
|
Refs |
|
Tags |
|
LICENSE |
|
--- |
|
timage.lisp (22867B) |
|
--- |
|
1 ;;;; -------------------------------------------------------------------… |
|
2 ;;;; Starting, Stopping, Dumping a Lisp image |
|
3 |
|
4 (uiop/package:define-package :uiop/image |
|
5 (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :ui… |
|
6 (:export |
|
7 #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-argum… |
|
8 #:command-line-arguments #:raw-command-line-arguments #:setup-command… |
|
9 #:*lisp-interaction* |
|
10 #:fatal-condition #:fatal-condition-p |
|
11 #:handle-fatal-condition |
|
12 #:call-with-fatal-condition-handler #:with-fatal-condition-handler |
|
13 #:*image-restore-hook* #:*image-prelude* #:*image-entry-point* |
|
14 #:*image-postlude* #:*image-dump-hook* |
|
15 #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-conditio… |
|
16 #:shell-boolean-exit |
|
17 #:register-image-restore-hook #:register-image-dump-hook |
|
18 #:call-image-restore-hook #:call-image-dump-hook |
|
19 #:restore-image #:dump-image #:create-image |
|
20 )) |
|
21 (in-package :uiop/image) |
|
22 |
|
23 (with-upgradability () |
|
24 (defvar *lisp-interaction* t |
|
25 "Is this an interactive Lisp environment, or is it batch processing?… |
|
26 |
|
27 (defvar *command-line-arguments* nil |
|
28 "Command-line arguments") |
|
29 |
|
30 (defvar *image-dumped-p* nil ; may matter as to how to get to command-… |
|
31 "Is this a dumped image? As a standalone executable?") |
|
32 |
|
33 (defvar *image-restore-hook* nil |
|
34 "Functions to call (in reverse order) when the image is restored") |
|
35 |
|
36 (defvar *image-restored-p* nil |
|
37 "Has the image been restored? A boolean, or :in-progress while resto… |
|
38 |
|
39 (defvar *image-prelude* nil |
|
40 "a form to evaluate, or string containing forms to read and evaluate |
|
41 when the image is restarted, but before the entry point is called.") |
|
42 |
|
43 (defvar *image-entry-point* nil |
|
44 "a function with which to restart the dumped image when execution is… |
|
45 |
|
46 (defvar *image-postlude* nil |
|
47 "a form to evaluate, or string containing forms to read and evaluate |
|
48 before the image dump hooks are called and before the image is dumped.") |
|
49 |
|
50 (defvar *image-dump-hook* nil |
|
51 "Functions to call (in order) when before an image is dumped")) |
|
52 |
|
53 (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) |
|
54 (deftype fatal-condition () |
|
55 `(and serious-condition #+clozure (not ccl:process-reset)))) |
|
56 |
|
57 ;;; Exiting properly or im- |
|
58 (with-upgradability () |
|
59 (defun quit (&optional (code 0) (finish-output t)) |
|
60 "Quits from the Lisp world, with the given exit status if provided. |
|
61 This is designed to abstract away the implementation specific quit forms… |
|
62 (when finish-output ;; essential, for ClozureCL, and for standard co… |
|
63 (finish-outputs)) |
|
64 #+(or abcl xcl) (ext:quit :status code) |
|
65 #+allegro (excl:exit code :quiet t) |
|
66 #+(or clasp ecl) (si:quit code) |
|
67 #+clisp (ext:quit code) |
|
68 #+clozure (ccl:quit code) |
|
69 #+cormanlisp (win32:exitprocess code) |
|
70 #+(or cmucl scl) (unix:unix-exit code) |
|
71 #+gcl (system:quit code) |
|
72 #+genera (error "~S: You probably don't want to Halt Genera. (code: … |
|
73 #+lispworks (lispworks:quit :status code :confirm nil :return nil :i… |
|
74 #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's… |
|
75 #+mkcl (mk-ext:quit :exit-code code) |
|
76 #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil)) |
|
77 (quit (find-symbol* :quit :sb-ext nil))) |
|
78 (cond |
|
79 (exit `(,exit :code code :abort (not finish-output))) |
|
80 (quit `(,quit :unix-status code :recklessly-p (not fini… |
|
81 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispwork… |
|
82 (not-implemented-error 'quit "(called with exit code ~S)" code)) |
|
83 |
|
84 (defun die (code format &rest arguments) |
|
85 "Die in error with some error message" |
|
86 (with-safe-io-syntax () |
|
87 (ignore-errors |
|
88 (format! *stderr* "~&~?~&" format arguments))) |
|
89 (quit code)) |
|
90 |
|
91 (defun raw-print-backtrace (&key (stream *debug-io*) count condition) |
|
92 "Print a backtrace, directly accessing the implementation" |
|
93 (declare (ignorable stream count condition)) |
|
94 #+abcl |
|
95 (loop :for i :from 0 |
|
96 :for frame :in (sys:backtrace (or count most-positive-fixnum))… |
|
97 (safe-format! stream "~&~D: ~A~%" i frame)) |
|
98 #+allegro |
|
99 (let ((*terminal-io* stream) |
|
100 (*standard-output* stream) |
|
101 (tpl:*zoom-print-circle* *print-circle*) |
|
102 (tpl:*zoom-print-level* *print-level*) |
|
103 (tpl:*zoom-print-length* *print-length*)) |
|
104 (tpl:do-command "zoom" |
|
105 :from-read-eval-print-loop nil |
|
106 :count (or count t) |
|
107 :all t)) |
|
108 #+(or clasp ecl mkcl) |
|
109 (let* ((top (si:ihs-top)) |
|
110 (repeats (if count (min top count) top)) |
|
111 (backtrace (loop :for ihs :from 0 :below top |
|
112 :collect (list (si::ihs-fun ihs) |
|
113 (si::ihs-env ihs))))) |
|
114 (loop :for i :from 0 :below repeats |
|
115 :for frame :in (nreverse backtrace) :do |
|
116 (safe-format! stream "~&~D: ~S~%" i frame))) |
|
117 #+clisp |
|
118 (system::print-backtrace :out stream :limit count) |
|
119 #+(or clozure mcl) |
|
120 (let ((*debug-io* stream)) |
|
121 #+clozure (ccl:print-call-history :count count :start-frame-number… |
|
122 #+mcl (ccl:print-call-history :detailed-p nil) |
|
123 (finish-output stream)) |
|
124 #+(or cmucl scl) |
|
125 (let ((debug:*debug-print-level* *print-level*) |
|
126 (debug:*debug-print-length* *print-length*)) |
|
127 (debug:backtrace (or count most-positive-fixnum) stream)) |
|
128 #+gcl |
|
129 (let ((*debug-io* stream)) |
|
130 (ignore-errors |
|
131 (with-safe-io-syntax () |
|
132 (if condition |
|
133 (conditions::condition-backtrace condition) |
|
134 (system::simple-backtrace))))) |
|
135 #+lispworks |
|
136 (let ((dbg::*debugger-stack* |
|
137 (dbg::grab-stack nil :how-many (or count most-positive-fixnu… |
|
138 (*debug-io* stream) |
|
139 (dbg:*debug-print-level* *print-level*) |
|
140 (dbg:*debug-print-length* *print-length*)) |
|
141 (dbg:bug-backtrace nil)) |
|
142 #+mezzano |
|
143 (let ((*standard-output* stream)) |
|
144 (sys.int::backtrace count)) |
|
145 #+sbcl |
|
146 (sb-debug:print-backtrace :stream stream :count (or count most-posit… |
|
147 #+xcl |
|
148 (loop :for i :from 0 :below (or count most-positive-fixnum) |
|
149 :for frame :in (extensions:backtrace-as-list) :do |
|
150 (safe-format! stream "~&~D: ~S~%" i frame))) |
|
151 |
|
152 (defun print-backtrace (&rest keys &key stream count condition) |
|
153 "Print a backtrace" |
|
154 (declare (ignore stream count condition)) |
|
155 (with-safe-io-syntax (:package :cl) |
|
156 (let ((*print-readably* nil) |
|
157 (*print-circle* t) |
|
158 (*print-miser-width* 75) |
|
159 (*print-length* nil) |
|
160 (*print-level* nil) |
|
161 (*print-pretty* t)) |
|
162 (ignore-errors (apply 'raw-print-backtrace keys))))) |
|
163 |
|
164 (defun print-condition-backtrace (condition &key (stream *stderr*) cou… |
|
165 "Print a condition after a backtrace triggered by that condition" |
|
166 ;; We print the condition *after* the backtrace, |
|
167 ;; for the sake of who sees the backtrace at a terminal. |
|
168 ;; It is up to the caller to print the condition *before*, with some… |
|
169 (print-backtrace :stream stream :count count :condition condition) |
|
170 (when condition |
|
171 (safe-format! stream "~&Above backtrace due to this condition:~%~A… |
|
172 condition))) |
|
173 |
|
174 (defun fatal-condition-p (condition) |
|
175 "Is the CONDITION fatal?" |
|
176 (typep condition 'fatal-condition)) |
|
177 |
|
178 (defun handle-fatal-condition (condition) |
|
179 "Handle a fatal CONDITION: |
|
180 depending on whether *LISP-INTERACTION* is set, enter debugger or die" |
|
181 (cond |
|
182 (*lisp-interaction* |
|
183 (invoke-debugger condition)) |
|
184 (t |
|
185 (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition) |
|
186 (print-condition-backtrace condition :stream *stderr*) |
|
187 (die 99 "~A" condition)))) |
|
188 |
|
189 (defun call-with-fatal-condition-handler (thunk) |
|
190 "Call THUNK in a context where fatal conditions are appropriately ha… |
|
191 (handler-bind ((fatal-condition #'handle-fatal-condition)) |
|
192 (funcall thunk))) |
|
193 |
|
194 (defmacro with-fatal-condition-handler ((&optional) &body body) |
|
195 "Execute BODY in a context where fatal conditions are appropriately … |
|
196 `(call-with-fatal-condition-handler #'(lambda () ,@body))) |
|
197 |
|
198 (defun shell-boolean-exit (x) |
|
199 "Quit with a return code that is 0 iff argument X is true" |
|
200 (quit (if x 0 1)))) |
|
201 |
|
202 |
|
203 ;;; Using image hooks |
|
204 (with-upgradability () |
|
205 (defun register-image-restore-hook (hook &optional (call-now-p t)) |
|
206 "Regiter a hook function to be run when restoring a dumped image" |
|
207 (register-hook-function '*image-restore-hook* hook call-now-p)) |
|
208 |
|
209 (defun register-image-dump-hook (hook &optional (call-now-p nil)) |
|
210 "Register a the hook function to be run before to dump an image" |
|
211 (register-hook-function '*image-dump-hook* hook call-now-p)) |
|
212 |
|
213 (defun call-image-restore-hook () |
|
214 "Call the hook functions registered to be run when restoring a dumpe… |
|
215 (call-functions (reverse *image-restore-hook*))) |
|
216 |
|
217 (defun call-image-dump-hook () |
|
218 "Call the hook functions registered to be run before to dump an imag… |
|
219 (call-functions *image-dump-hook*))) |
|
220 |
|
221 |
|
222 ;;; Proper command-line arguments |
|
223 (with-upgradability () |
|
224 (defun raw-command-line-arguments () |
|
225 "Find what the actual command line for this process was." |
|
226 #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later! |
|
227 #+allegro (sys:command-line-arguments) ; default: :application t |
|
228 #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:… |
|
229 #+clisp (coerce (ext:argv) 'list) |
|
230 #+clozure ccl:*command-line-argument-list* |
|
231 #+(or cmucl scl) extensions:*command-line-strings* |
|
232 #+gcl si:*command-args* |
|
233 #+(or genera mcl mezzano) nil |
|
234 #+lispworks sys:*line-arguments-list* |
|
235 #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i… |
|
236 #+sbcl sb-ext:*posix-argv* |
|
237 #+xcl system:*argv* |
|
238 #-(or abcl allegro clasp clisp clozure cmucl ecl gcl genera lispwork… |
|
239 (not-implemented-error 'raw-command-line-arguments)) |
|
240 |
|
241 (defun command-line-arguments (&optional (arguments (raw-command-line-… |
|
242 "Extract user arguments from command-line invocation of current proc… |
|
243 Assume the calling conventions of a generated script that uses -- |
|
244 if we are not called from a directly executable image." |
|
245 (block nil |
|
246 #+abcl (return arguments) |
|
247 ;; SBCL and Allegro already separate user arguments from implement… |
|
248 #-(or sbcl allegro) |
|
249 (unless (eq *image-dumped-p* :executable) |
|
250 ;; LispWorks command-line processing isn't transparent to the us… |
|
251 ;; unless you create a standalone executable; in that case, |
|
252 ;; we rely on cl-launch or some other script to set the argument… |
|
253 #+lispworks (return *command-line-arguments*) |
|
254 ;; On other implementations, on non-standalone executables, |
|
255 ;; we trust cl-launch or whichever script starts the program |
|
256 ;; to use -- as a delimiter between implementation arguments and… |
|
257 #-lispworks (setf arguments (member "--" arguments :test 'string… |
|
258 (rest arguments))) |
|
259 |
|
260 (defun argv0 () |
|
261 "On supported implementations (most that matter), or when invoked by… |
|
262 return a string that for the name with which the program was invoked, i.… |
|
263 Otherwise, return NIL." |
|
264 (cond |
|
265 ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 ! |
|
266 ;; NB: not currently available on ABCL, Corman, Genera, MCL |
|
267 (or #+(or allegro clisp clozure cmucl gcl lispworks sbcl scl xcl) |
|
268 (first (raw-command-line-arguments)) |
|
269 #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0))) |
|
270 (t ;; argv[0] is the name of the interpreter. |
|
271 ;; The wrapper script can export __CL_ARGV0. cl-launch does as of… |
|
272 (getenvp "__CL_ARGV0")))) |
|
273 |
|
274 (defun setup-command-line-arguments () |
|
275 (setf *command-line-arguments* (command-line-arguments))) |
|
276 |
|
277 (defun restore-image (&key |
|
278 (lisp-interaction *lisp-interaction*) |
|
279 (restore-hook *image-restore-hook*) |
|
280 (prelude *image-prelude*) |
|
281 (entry-point *image-entry-point*) |
|
282 (if-already-restored '(cerror "RUN RESTORE-IMA… |
|
283 "From a freshly restarted Lisp image, restore the saved Lisp environ… |
|
284 by setting appropriate variables, running various hooks, and calling any… |
|
285 |
|
286 If the image has already been restored or is already being restored, as … |
|
287 call the IF-ALREADY-RESTORED error handler (by default, a continuable er… |
|
288 immediately to the surrounding restore process if allowed to continue. |
|
289 |
|
290 Then, comes the restore process itself: |
|
291 First, call each function in the RESTORE-HOOK, |
|
292 in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK. |
|
293 Second, evaluate the prelude, which is often Lisp text that is read, |
|
294 as per EVAL-INPUT. |
|
295 Third, call the ENTRY-POINT function, if any is specified, with no argum… |
|
296 |
|
297 The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that i… |
|
298 any unhandled error leads to a backtrace and an exit with an error statu… |
|
299 If LISP-INTERACTION is NIL, the process also exits when no error occurs: |
|
300 if neither restart nor entry function is provided, the program will exit… |
|
301 if a function was provided, the program will exit after the function ret… |
|
302 with status 0 if and only if the primary return value of result is gener… |
|
303 and with status 1 if this value is NIL. |
|
304 |
|
305 If LISP-INTERACTION is true, unhandled errors will take you to the debug… |
|
306 of the function will be returned rather than interpreted as a boolean de… |
|
307 (when *image-restored-p* |
|
308 (if if-already-restored |
|
309 (call-function if-already-restored "Image already ~:[being ~;~… |
|
310 (eq *image-restored-p* t)) |
|
311 (return-from restore-image))) |
|
312 (with-fatal-condition-handler () |
|
313 (setf *lisp-interaction* lisp-interaction) |
|
314 (setf *image-restore-hook* restore-hook) |
|
315 (setf *image-prelude* prelude) |
|
316 (setf *image-restored-p* :in-progress) |
|
317 (call-image-restore-hook) |
|
318 (standard-eval-thunk prelude) |
|
319 (setf *image-restored-p* t) |
|
320 (let ((results (multiple-value-list |
|
321 (if entry-point |
|
322 (call-function entry-point) |
|
323 t)))) |
|
324 (if lisp-interaction |
|
325 (values-list results) |
|
326 (shell-boolean-exit (first results))))))) |
|
327 |
|
328 |
|
329 ;;; Dumping an image |
|
330 |
|
331 (with-upgradability () |
|
332 (defun dump-image (filename &key output-name executable |
|
333 (postlude *image-postlude*) |
|
334 (dump-hook *image-dump-hook*) |
|
335 #+clozure prepend-symbols #+clozure (pur… |
|
336 #+sbcl compression |
|
337 #+(and sbcl os-windows) application-type) |
|
338 "Dump an image of the current Lisp environment at pathname FILENAME,… |
|
339 |
|
340 First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT,… |
|
341 the functions in DUMP-HOOK, in reverse order of registration by REGISTE… |
|
342 |
|
343 If EXECUTABLE is true, create an standalone executable program that call… |
|
344 |
|
345 Pass various implementation-defined options, such as PREPEND-SYMBOLS and… |
|
346 or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." |
|
347 ;; Note: at least SBCL saves only global values of variables in the … |
|
348 ;; so make sure things you want to dump are NOT just local bindings … |
|
349 (declare (ignorable filename output-name executable)) |
|
350 (setf *image-dumped-p* (if executable :executable t)) |
|
351 (setf *image-restored-p* :in-regress) |
|
352 (setf *image-postlude* postlude) |
|
353 (standard-eval-thunk *image-postlude*) |
|
354 (setf *image-dump-hook* dump-hook) |
|
355 (call-image-dump-hook) |
|
356 (setf *image-restored-p* nil) |
|
357 #-(or clisp clozure (and cmucl executable) lispworks sbcl scl) |
|
358 (when executable |
|
359 (not-implemented-error 'dump-image "dumping an executable")) |
|
360 #+allegro |
|
361 (progn |
|
362 (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :ten… |
|
363 (excl:dumplisp :name filename :suppress-allegro-cl-banner t)) |
|
364 #+clisp |
|
365 (apply #'ext:saveinitmem filename |
|
366 :quiet t |
|
367 :start-package *package* |
|
368 :keep-global-handlers nil |
|
369 :executable (if executable 0 t) ;--- requires clisp 2.48 or l… |
|
370 (when executable |
|
371 (list |
|
372 ;; :parse-options nil ;--- requires a non-standard patch t… |
|
373 :norc t :script nil :init-function #'restore-image))) |
|
374 #+clozure |
|
375 (flet ((dump (prepend-kernel) |
|
376 (ccl:save-application filename :prepend-kernel prepend-kern… |
|
377 :toplevel-function (when exe… |
|
378 ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-s… |
|
379 (if prepend-symbols |
|
380 (with-temporary-file (:prefix "ccl-symbols-" :direction :outpu… |
|
381 (require 'elf) |
|
382 (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path) |
|
383 (dump path)) |
|
384 (dump t))) |
|
385 #+(or cmucl scl) |
|
386 (progn |
|
387 (ext:gc :full t) |
|
388 (setf ext:*batch-mode* nil) |
|
389 (setf ext::*gc-run-time* 0) |
|
390 (apply 'ext:save-lisp filename |
|
391 :allow-other-keys t ;; hush SCL and old versions of CMUCL |
|
392 #+(and cmucl executable) :executable #+(and cmucl executabl… |
|
393 (when executable '(:init-function restore-image :process-co… |
|
394 :quiet t :load-init-file nil :site-init … |
|
395 #+gcl |
|
396 (progn |
|
397 (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) |
|
398 (si::save-system filename)) |
|
399 #+lispworks |
|
400 (if executable |
|
401 (lispworks:deliver 'restore-image filename 0 :interface nil) |
|
402 (hcl:save-image filename :environment nil)) |
|
403 #+sbcl |
|
404 (progn |
|
405 ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow a… |
|
406 (setf sb-ext::*gc-run-time* 0) |
|
407 (apply 'sb-ext:save-lisp-and-die filename |
|
408 :executable t ;--- always include the runtime that goes wit… |
|
409 (append |
|
410 (when compression (list :compression compression)) |
|
411 ;;--- only save runtime-options for standalone executables |
|
412 (when executable (list :toplevel #'restore-image :save-run… |
|
413 #+(and sbcl os-windows) ;; passing :application-type :gui … |
|
414 ;; the default is :console - only works with SBCL 1.1.15 o… |
|
415 (when application-type (list :application-type application… |
|
416 #-(or allegro clisp clozure cmucl gcl lispworks sbcl scl) |
|
417 (not-implemented-error 'dump-image)) |
|
418 |
|
419 (defun create-image (destination lisp-object-files |
|
420 &key kind output-name prologue-code epilogue-code… |
|
421 (prelude () preludep) (postlude () postludep) |
|
422 (entry-point () entry-point-p) build-args no-ui… |
|
423 (declare (ignorable destination lisp-object-files extra-object-files… |
|
424 prologue-code epilogue-code prelude preludep pos… |
|
425 entry-point entry-point-p build-args no-uiop)) |
|
426 "On ECL, create an executable at pathname DESTINATION from the speci… |
|
427 ;; Is it meaningful to run these in the current environment? |
|
428 ;; only if we also track the object files that constitute the "curre… |
|
429 ;; and otherwise simulate dump-image, including quitting at the end. |
|
430 #-(or clasp ecl mkcl) (not-implemented-error 'create-image) |
|
431 #+(or clasp ecl mkcl) |
|
432 (let ((epilogue-code |
|
433 (if no-uiop |
|
434 epilogue-code |
|
435 (let ((forms |
|
436 (append |
|
437 (when epilogue-code `(,epilogue-code)) |
|
438 (when postludep `((setf *image-postlude* ',postlu… |
|
439 (when preludep `((setf *image-prelude* ',prelude)… |
|
440 (when entry-point-p `((setf *image-entry-point* '… |
|
441 (case kind |
|
442 ((:image) |
|
443 (setf kind :program) ;; to ECL, it's just anot… |
|
444 `((setf *image-dumped-p* t) |
|
445 (si::top-level #+(or clasp ecl) t) (quit))) |
|
446 ((:program) |
|
447 `((setf *image-dumped-p* :executable) |
|
448 (shell-boolean-exit |
|
449 (restore-image)))))))) |
|
450 (when forms `(progn ,@forms)))))) |
|
451 #+(or clasp ecl mkcl) |
|
452 (check-type kind (member :dll :shared-library :lib :static-library |
|
453 :fasl :fasb :program)) |
|
454 (apply #+clasp 'cmp:builder #+clasp kind |
|
455 #+(or ecl mkcl) |
|
456 (ecase kind |
|
457 ((:dll :shared-library) |
|
458 #+ecl 'c::build-shared-library #+mkcl 'compiler:build-sh… |
|
459 ((:lib :static-library) |
|
460 #+ecl 'c::build-static-library #+mkcl 'compiler:build-st… |
|
461 ((:fasl #+ecl :fasb) |
|
462 #+ecl 'c::build-fasl #+mkcl 'compiler:build-fasl) |
|
463 #+mkcl ((:fasb) 'compiler:build-bundle) |
|
464 ((:program) |
|
465 #+ecl 'c::build-program #+mkcl 'compiler:build-program)) |
|
466 (pathname destination) |
|
467 #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files |
|
468 (append lisp-object-files #+(or clasp ecl) extra-object-fil… |
|
469 #+ecl :init-name |
|
470 #+ecl (getf build-args :init-name) |
|
471 (append |
|
472 (when prologue-code `(:prologue-code ,prologue-code)) |
|
473 (when epilogue-code `(:epilogue-code ,epilogue-code)) |
|
474 #+mkcl (when extra-object-files `(:object-files ,extra-obj… |
|
475 build-args))))) |
|
476 |
|
477 |
|
478 ;;; Some universal image restore hooks |
|
479 (with-upgradability () |
|
480 (map () 'register-image-restore-hook |
|
481 '(setup-stdin setup-stdout setup-stderr |
|
482 setup-command-line-arguments setup-temporary-directory |
|
483 #+abcl detect-os))) |
