static-link.lisp - clic - Clic is an command line interactive client for gopher written in Common LISP
(HTM) git clone git://bitreich.org/clic/ git://enlrupgkhuxnvlhsf6lc3fziv5h2hhfrinws65d7roiv6bfj7d652fid.onion/clic/
(DIR) Log
(DIR) Files
(DIR) Refs
(DIR) Tags
(DIR) README
(DIR) LICENSE
---
static-link.lisp (4750B)
---
1 ;; FIXME: arrange packages so that this can be moved in ASDF some time later?
2
3 (in-package #:cffi-toolchain)
4
5 (defun static-ops-enabled-p ()
6 (ensure-toolchain-parameters)
7 (and (or *linkkit-start* *linkkit-end*) t))
8
9 (defclass static-runtime-op (monolithic-bundle-op link-op selfward-operation) ()
10 (:documentation "Create a Lisp runtime linkable library for the system and its dependencies."))
11 (defmethod bundle-type ((o static-runtime-op)) :program)
12 (defmethod selfward-operation ((o static-runtime-op)) 'monolithic-lib-op)
13
14 (defmethod output-files ((o static-runtime-op) (s system))
15 #-(or ecl mkcl)
16 (list (subpathname (component-pathname s)
17 (strcat (coerce-name s) "-runtime")
18 :type (bundle-pathname-type :program))))
19
20 (defmethod perform ((o static-runtime-op) (s system))
21 (link-lisp-executable
22 (output-file o s)
23 (link-all-library (first (input-files o s)))))
24
25 (defclass static-image-op (image-op) ()
26 (:documentation "Create a statically linked standalone image for the system."))
27 #-(or ecl mkcl) (defmethod selfward-operation ((o static-image-op)) '(load-op static-runtime-op))
28 #+(or ecl mkcl) (defmethod gather-operation ((o static-image-op)) 'compile-op)
29 #+(or ecl mkcl) (defmethod gather-operation ((o static-image-op)) :object)
30
31 (defclass static-program-op (program-op static-image-op) ()
32 (:documentation "Create a statically linked standalone executable for the system."))
33
34 ;; Problem? Its output may conflict with the program-op output :-/
35
36 #-(or ecl mkcl)
37 (defmethod perform ((o static-image-op) (s system))
38 #-(or clisp sbcl) (error "Not implemented yet")
39 #+(or clisp sbcl)
40 (let* ((name (coerce-name s))
41 (runtime (output-file 'static-runtime-op s))
42 (image
43 #+clisp (implementation-file "base/lispinit.mem")
44 #+sbcl (subpathname (lisp-implementation-directory) "sbcl.core"))
45 (output (output-file o s))
46 (child-op (if (typep o 'program-op) 'program-op 'image-op)))
47 (with-temporary-output (tmp output)
48 (apply 'invoke runtime
49 #+clisp "-M" #+sbcl "--core" image
50 `(#+clisp ,@'("--silent" "-ansi" "-norc" "-x")
51 #+sbcl ,@'("--noinform" "--non-interactive" "--no-sysinit" "--no-userinit" "--eval")
52 ,(with-safe-io-syntax (:package :asdf)
53 (let ((*print-pretty* nil)
54 (*print-case* :downcase))
55 (format
56 ;; This clever staging allows to put things in a single form,
57 ;; as required for CLISP not to print output for the first form,
58 ;; yet allow subsequent forms to rely on packages defined by former forms.
59 nil "'(~@{#.~S~^ ~})"
60 '(require "asdf")
61 '(in-package :asdf)
62 `(progn
63 (setf asdf:*central-registry* ',asdf:*central-registry*)
64 (initialize-source-registry ',asdf::*source-registry-parameter*)
65 (initialize-output-translations ',asdf::*output-translations-parameter*)
66 (upgrade-asdf)
67 ,@(if-let (ql-home
68 (symbol-value (find-symbol* '*quicklisp-home* 'ql-setup nil)))
69 `((load ,(subpathname ql-home "setup.lisp"))))
70 (load-system "cffi-grovel")
71 ;; We force the (final step of the) operation to take place
72 (defmethod operation-done-p
73 ((operation ,child-op) (system (eql (find-system ,name))))
74 nil)
75 ;; Some implementations (notably SBCL) die as part of dumping an image,
76 ;; so redirect output-files to desired destination, for this processs might
77 ;; never otherwise get a chance to move the file to destination.
78 (defmethod output-files
79 ((operation ,child-op) (system (eql (find-system ,name))))
80 (values (list ,tmp) t))
81 (operate ',child-op ,name)
82 (quit))))))))))
83
84 #+(or ecl mkcl)
85 (defmethod perform ((o static-image-op) (s system))
86 (let (#+ecl
87 (c::*ld-flags*
88 (format nil "-Wl,--export-dynamic ~@[ ~A~]"
89 c::*ld-flags*)))
90 (call-next-method)))
91
92 ;; Allow for :static-FOO-op in ASDF definitions.
93 (setf (find-class 'asdf::static-runtime-op) (find-class 'static-runtime-op)
94 (find-class 'asdf::static-image-op) (find-class 'static-image-op)
95 (find-class 'asdf::static-program-op) (find-class 'static-program-op))