1.1--- a/tools/prepare-image.lisp Thu Jun 15 22:01:40 2023 -0400
1.2+++ b/tools/prepare-image.lisp Sun Jun 18 22:25:28 2023 -0400
1.3@@ -3,30 +3,15 @@
1.4 ;; For SBCL, if you don't have SBCL_HOME set, then we won't be able to require this later.
1.5 #+sbcl
1.6 (require 'sb-introspect)
1.7-
1.8-(when (probe-file "tools/asdf.lisp")
1.9- (format t "Compiling asdf..~%")
1.10- (let ((output (compile-file "tools/asdf.lisp" :verbose nil :print nil)))
1.11- (load output))
1.12- (provide "asdf"))
1.13-
1.14+#-sbcl
1.15 (require "asdf")
1.16
1.17 #+sbcl
1.18 (require "sb-sprof")
1.19
1.20-#+nil
1.21-(push (pathname (format nil "~a/local-projects/poiu/" (namestring (uiop:getcwd))))
1.22- asdf:*central-registry*)
1.23-
1.24-(defvar *asdf-root-guesser* nil)
1.25-
1.26-(defparameter *cwd* (merge-pathnames
1.27- *default-pathname-defaults*
1.28- (uiop:getcwd)))
1.29+(defvar *cwd* (uiop:getcwd))
1.30
1.31 (defun update-output-translations (root)
1.32- "This function is called dynamically from deliver-utils/common.lisp!"
1.33 (asdf:initialize-output-translations
1.34 `(:output-translations
1.35 :inherit-configuration
1.36@@ -43,69 +28,6 @@
1.37 (asdf:register-preloaded-system :sb-rotate-byte)
1.38 (asdf:register-preloaded-system :sb-cltl2))
1.39
1.40-(defun %read-version (file)
1.41- (let ((key "version: "))
1.42- (loop for line in (uiop:read-file-lines file)
1.43- if (string= key line :end2 (length key))
1.44- return (subseq line (length key)))))
1.45-
1.46-(defun init-quicklisp ()
1.47- (let ((version (%read-version "quicklisp/dists/quicklisp/distinfo.txt")))
1.48- (let ((quicklisp-loc (ensure-directories-exist
1.49- (merge-pathnames
1.50- (format nil "build/quicklisp/~a/" version)
1.51- *cwd*)))
1.52- (src (merge-pathnames
1.53- "quicklisp/"
1.54- *cwd*)))
1.55- (flet ((safe-copy-file (path &optional (dest path))
1.56- (let ((src (merge-pathnames
1.57- path
1.58- "quicklisp/"))
1.59- (dest (merge-pathnames
1.60- dest
1.61- quicklisp-loc)))
1.62- (format t "Copying: ~a to ~a~%" src dest)
1.63-
1.64- (when (equal src dest)
1.65- (error "Trying to overwrite the same file"))
1.66- (unless (uiop:file-exists-p dest)
1.67- (uiop:copy-file
1.68- src
1.69- (ensure-directories-exist
1.70- dest))))))
1.71- (loop for name in
1.72- (append (directory
1.73- (merge-pathnames
1.74- "quicklisp/quicklisp/*.lisp"
1.75- *cwd*))
1.76- (directory
1.77- (merge-pathnames
1.78- "quicklisp/quicklisp/*.asd"
1.79- *cwd*)))
1.80- do (safe-copy-file name
1.81- (format nil "quicklisp/~a.~a"
1.82- (pathname-name name)
1.83- (pathname-type name))))
1.84- (loop for name in (directory
1.85- (merge-pathnames
1.86- "quicklisp/*.lisp"
1.87- *cwd*))
1.88- do (safe-copy-file name
1.89- (format nil "~a.lisp"
1.90- (pathname-name name))))
1.91- (safe-copy-file "setup.lisp")
1.92- (safe-copy-file "quicklisp/version.txt")
1.93- (safe-copy-file "dists/quicklisp/distinfo.txt")
1.94- (safe-copy-file "dists/quicklisp/enabled.txt")
1.95- (safe-copy-file "dists/quicklisp/preference.txt"))
1.96- (load (merge-pathnames
1.97- "setup.lisp"
1.98- quicklisp-loc)))))
1.99-
1.100-(init-quicklisp)
1.101-
1.102-#+nil
1.103 (ql:update-all-dists :prompt nil)
1.104
1.105 ;; is the package name already loaded as a feature? uhh look it up
1.106@@ -117,28 +39,11 @@
1.107 (when (probe-file dir)
1.108 (push dir ql:*local-project-directories*)))))
1.109 #-demo
1.110- (push-src-dir "local-projects")
1.111- (push-src-dir "src")
1.112- (push-src-dir "third-party")
1.113- (push-src-dir "lisp")))
1.114-
1.115-
1.116-(defun update-root (cwd)
1.117- (update-output-translations cwd)
1.118- (update-project-directories cwd))
1.119+ (push-src-dir ".")
1.120+ (push-src-dir "vendor")))
1.121
1.122 (update-project-directories *cwd*)
1.123
1.124-(defun maybe-asdf-prepare ()
1.125- (when *asdf-root-guesser*
1.126- (update-root (funcall *asdf-root-guesser*))))
1.127-
1.128-(compile 'maybe-asdf-prepare)
1.129-
1.130-(defun unprepare-asdf (root-guesser)
1.131- "This function is called dynamically from deliver-utils/common.lisp!"
1.132- (setf *asdf-root-guesser* root-guesser))
1.133-
1.134 (defun maybe-configure-proxy ()
1.135 (let ((proxy (uiop:getenv "HTTP_PROXY")))
1.136 (when (and proxy (> (length proxy) 0))
1.137@@ -146,15 +51,9 @@
1.138
1.139 (maybe-configure-proxy)
1.140
1.141-
1.142 (ql:quickload "log4cl")
1.143 (ql:quickload "prove-asdf")
1.144
1.145 (log:info "*local-project-directories: ~S" ql:*local-project-directories*)
1.146
1.147-;; (ql:quickload :cl-ppcre)
1.148-;; make sure we have build asd
1.149-#+nil
1.150-(push (pathname (format nil "~a/build-utils/" *cwd*))
1.151- asdf:*central-registry*)
1.152 (ql:register-local-projects)
