1.1--- a/x.lisp Mon Sep 16 21:28:33 2024 -0400
1.2+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
1.3@@ -1,319 +0,0 @@
1.4-#!/usr/bin/env -S sbcl --no-sysinit --no-userinit --script
1.5-;;; core build tool
1.6-
1.7-;;
1.8-
1.9-;;; Code:
1.10-(in-package :cl-user)
1.11-#-(or sbcl cl) (error "unsupported Lisp compiler")
1.12-#-quicklisp
1.13-(let ((quicklisp-init (or (probe-file #p"~/.stash/quicklisp/setup.lisp")
1.14- (probe-file #p"/usr/local/share/lisp/quicklisp/setup.lisp")
1.15- (probe-file #p "~/quicklisp/setup.lisp"))))
1.16- (when (probe-file quicklisp-init)
1.17- (load quicklisp-init)))
1.18-(require 'sb-rotate-byte)
1.19-(require 'sb-introspect)
1.20-(require 'sb-grovel)
1.21-(require 'sb-cltl2)
1.22-(require 'sb-cover)
1.23-(require 'sb-sprof)
1.24-
1.25-(asdf:load-system (asdf:find-system :cl-ppcre))
1.26-(asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/")))
1.27-(asdf:load-system :std)
1.28-
1.29-(defpackage :x
1.30- (:use :cl :std :std/named-readtables :cl-user)
1.31- (:export :*core-path* :*lisp-path* :*lib-path* :*std-path* :*ffi-path* :*stash-path* :*web-path* :*bin-path*
1.32- :*compression-level*))
1.33-
1.34-(in-package :x)
1.35-(use-package :sb-gray)
1.36-;; (require 'sb-aclrepl)
1.37-(sb-ext:enable-debugger)
1.38-(defvar *core-path* (directory-namestring #.(or *load-truename* *compile-file-truename* (error "run me as an executable!"))))
1.39-
1.40-(defvar *lisp-path* (merge-pathnames "lisp/" *core-path*))
1.41-(defvar *bin-path* (merge-pathnames "bin/" *lisp-path*))
1.42-(defvar *web-path* (merge-pathnames "web/" *lisp-path*))
1.43-(defvar *lib-path* (merge-pathnames "lib/" *lisp-path*))
1.44-(defvar *std-path* (merge-pathnames "std/" *lisp-path*))
1.45-(defvar *ffi-path* (merge-pathnames "ffi/" *lisp-path*))
1.46-(defvar *stash-path* (merge-pathnames ".stash/" *core-path*))
1.47-
1.48-(defvar *compression-level* nil)
1.49-
1.50-(push *core-path* asdf:*central-registry*)
1.51-(push *lisp-path* ql:*local-project-directories*)
1.52-(push *lib-path* ql:*local-project-directories*)
1.53-(push *bin-path* ql:*local-project-directories*)
1.54-(push *ffi-path* ql:*local-project-directories*)
1.55-
1.56-(ql:register-local-projects)
1.57-
1.58-(unless (asdf:find-system :log nil)
1.59- (asdf:load-asd (probe-file (merge-pathnames "log/log.asd" *lib-path*))))
1.60-
1.61-(asdf:load-system :log)
1.62-(use-package :log)
1.63-
1.64-(unless (asdf:find-system :rocksdb nil)
1.65- (asdf:load-asd (probe-file (merge-pathnames "rocksdb/rocksdb.asd" *ffi-path*)))
1.66- (asdf:load-system :rocksdb))
1.67-
1.68-(unless (asdf:find-system :cli nil)
1.69- (asdf:load-asd (probe-file (merge-pathnames "cli/cli.asd" *lib-path*))))
1.70-
1.71-(asdf:load-system :cli)
1.72-(use-package :cli)
1.73-
1.74-(defun done () (print :OK))
1.75-
1.76-(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
1.77- (uiop:dump-image (merge-pathnames (car (last (std::ssplit #\/ (asdf:component-name c)))) *stash-path*) :executable t :compression *compression-level*))
1.78-
1.79-(defun compile-std (&optional force save)
1.80- (ql:quickload :std)
1.81- (when save
1.82- (in-package :std-user)
1.83- (sb-ext:save-lisp-and-die (merge-pathnames "std.core" *stash-path*) :compression *compression-level*)))
1.84-
1.85-(defun compile-prelude (&optional force save)
1.86- ;; (compile-std)
1.87- (asdf:compile-system :prelude :force force)
1.88- (asdf:load-system :prelude :force force)
1.89- ;; (rocksdb:load-rocksdb save)
1.90- (when save
1.91- (in-package :std-user)
1.92- (use-package :cl-user)
1.93- (sb-ext:save-lisp-and-die (merge-pathnames "prelude.core" *stash-path*) :compression *compression-level*)))
1.94-
1.95-(defun compile-user (&optional force save compression (name "user.core"))
1.96- (asdf:compile-system :user :force force)
1.97- (asdf:load-system :user :force force)
1.98- (when save
1.99- (in-package :user)
1.100- (use-package :cl-user)
1.101- (sb-ext:save-lisp-and-die (merge-pathnames name *stash-path*) :compression (or compression *compression-level*))))
1.102-
1.103-
1.104-(defun compile-tests (&optional force save)
1.105- (asdf:compile-system :core/tests :force force)
1.106- (asdf:load-system :core/tests :force force)
1.107- (when save
1.108- (in-package :core/tests)
1.109- (sb-ext:save-lisp-and-die (merge-pathnames "tests.core" *stash-path*) :compression *compression-level*)))
1.110-
1.111-(defun compile-core (&optional force save)
1.112- (asdf:compile-system :core :force force)
1.113- (asdf:load-system :core :force force)
1.114- (when save
1.115- (in-package :core)
1.116- (sb-ext:save-lisp-and-die (merge-pathnames "core.core" *stash-path*) :compression *compression-level*)))
1.117-
1.118-(defun save-foreign (name exports &rest args)
1.119- (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args)))
1.120-
1.121-(sb-alien:define-alien-callable compile-prelude sb-alien:void () (compile-prelude))
1.122-(sb-alien:define-alien-callable compile-std sb-alien:void () (compile-std))
1.123-(sb-alien:define-alien-callable compile-user sb-alien:void () (compile-user))
1.124-
1.125-(defvar *thunk* nil)
1.126-
1.127-(setq *print-level* 32
1.128- *print-length* 64)
1.129-;; collect args from shell
1.130-(defvar *args* (cdr sb-ext:*posix-argv*))
1.131-(defvar *flags*
1.132- '((version "0.1.0")
1.133- (help "x.lisp --- core build tool
1.134-x.lisp [CMD]
1.135-CMDS:
1.136-test
1.137-compile
1.138-build
1.139-make
1.140-test
1.141-run
1.142-save
1.143-install")))
1.144-
1.145-(defun getflag (k)
1.146- (cadar
1.147- (member
1.148- (string-upcase k)
1.149- *flags*
1.150- :test #'string=
1.151- :key #'car)))
1.152-
1.153-(defun bail (msg)
1.154- (log::fatal! msg))
1.155-
1.156-(defun parse-flag (arg)
1.157- (flet ((f (k)
1.158- (if (or (characterp k) (= (length k) 1))
1.159- (case (char-downcase (character k))
1.160- (#\v "VERSION")
1.161- (#\h "HELP"))
1.162- k)))
1.163- (if (char-equal (aref arg 0) #\-)
1.164- (if (= (length arg) 2) ;; short
1.165- (f (aref arg 1))
1.166- (if (char-equal (aref arg 1) #\-) ;; long
1.167- (f (subseq arg 2))
1.168- (bail "invalid flag"))))))
1.169-
1.170-;; (defun parse-arg (arg))
1.171-(defun x-compile (args)
1.172- (if args
1.173- (let ((name (car args)))
1.174- (ql:quickload name)
1.175- (asdf:compile-system name :force t))
1.176- (compile-prelude t nil)))
1.177-
1.178-(defun %build (name)
1.179- (format t "saving ~A to: ~A~%" name (merge-pathnames name *stash-path*))
1.180- (let ((sys (sb-int:keywordicate (format nil "BIN/~A" (string-upcase name)))))
1.181- (ql:quickload sys)
1.182- (push :ssl *features*)
1.183- ;; (std/sys:forget-shared-objects)
1.184- (asdf:make sys)))
1.185-
1.186-(defun x-build (args)
1.187- (if args
1.188- (let ((name (car args)))
1.189- (ensure-directories-exist *stash-path*)
1.190- (%build name))
1.191- (std:wait-for-threads (mapcar
1.192- (lambda (x)
1.193- (sb-thread:make-thread
1.194- (lambda ()
1.195- (sb-ext:run-program "x.lisp" (list "build" x) :wait t :output t))
1.196- :name x))
1.197- (list "skel" "rdb" "organ" "homer" "packy")))))
1.198-
1.199-(defun stash-output (name)
1.200- (let* ((sys (asdf:find-system name))
1.201- (fasl (make-pathname
1.202- :name (asdf/system:component-build-pathname sys)
1.203- :type (if (string-equal name "std")
1.204- "lisp"
1.205- "fasl"))))
1.206- (uiop:rename-file-overwriting-target
1.207- (merge-pathnames fasl (asdf:system-source-directory sys))
1.208- (merge-pathnames fasl *stash-path*))))
1.209-
1.210-(defun %make (name)
1.211- (let ((sys (sb-int:keywordicate (string-upcase name))))
1.212- (std/sys:forget-shared-objects)
1.213- (asdf:load-system sys)
1.214- (in-package :std-user)
1.215- (asdf:make sys)
1.216- (stash-output sys)
1.217- (println :OK)))
1.218-
1.219-(defun x-make (args)
1.220- (if args
1.221- (let ((name (car args)))
1.222- (ensure-directories-exist *stash-path*)
1.223- (%make name))
1.224- (std:wait-for-threads (mapcar
1.225- (lambda (x)
1.226- (sb-thread:make-thread
1.227- (lambda ()
1.228- (sb-ext:run-program "x.lisp" (list "make" x) :wait t :output t))
1.229- :name x))
1.230- (list "core" "user" "prelude" "core/tests" "core/bench" "core/lib" "core/ffi")))))
1.231-
1.232-(defun x-save (args)
1.233- (if args
1.234- (let ((name (car args)))
1.235- (ensure-directories-exist *stash-path*)
1.236- (format t "saving core to: ~A~%" (merge-pathnames name *stash-path*))
1.237- (string-case (name)
1.238- ("prelude" (compile-prelude t t))
1.239- ("core" (compile-core t t))
1.240- ("std" (compile-std t t))
1.241- ("user" (compile-user t t))
1.242- ("infra" (compile-user t t 22 "infra.core"))
1.243- ("tests" (compile-tests t t))))
1.244- ;; (sb-ext:run-program "x.lisp" nil :input t :output t)
1.245- ))
1.246-
1.247-(asdf:load-asd (probe-file (merge-pathnames "log.asd" "lisp/lib/log/")))
1.248-(asdf:load-asd (probe-file (merge-pathnames "rt.asd" "lisp/lib/rt/")))
1.249-(asdf:load-system :log)
1.250-(asdf:load-system :rt)
1.251-(ql:quickload :rt)
1.252-
1.253-(defun x-test (args)
1.254- (if args
1.255- (let ((name (car args)))
1.256- (ql:quickload :rt)
1.257- (ql:quickload (string-upcase (format nil "~A/tests" name)))
1.258- (rt:do-tests (string-upcase name) t))
1.259- (bail "missing arg")))
1.260-
1.261-(defun x-run (args)
1.262- (if args
1.263- (let* ((name (car args))
1.264- (path (merge-pathnames name *stash-path*)))
1.265- (unless (probe-file path)
1.266- (sb-ext:run-program "x" (list "build" name) :wait t :output t))
1.267- (sb-ext:run-program path (cdr args) :output t))
1.268- (bail "missing arg")))
1.269-
1.270-(defun %install (name)
1.271- (let ((path (merge-pathnames name *stash-path*)))
1.272- (unless (probe-file path)
1.273- (sb-ext:run-program "x" (list "build" name) :wait t :output t))
1.274- (sb-ext:run-program "/bin/sudo"
1.275- (list "install" "-C" "-m" "755" (namestring path) "/usr/local/bin/")
1.276- :input t
1.277- :wait t
1.278- :output t)
1.279- (format t "installed ~A to ~A~%" name (merge-pathnames name "/usr/local/bin/"))))
1.280-
1.281-(defun x-install (args)
1.282- (mapc #'%install
1.283- (or args
1.284- (list "skel" "rdb" "organ" "homer" "packy"))))
1.285-
1.286-(defun x-parse-args ()
1.287- (if (null *args*)
1.288- (progn
1.289- (println "Welcome to CORE/X")
1.290- (use-package :cl-user)
1.291- (use-package :sb-ext)
1.292- (use-package :std-user)
1.293- (sb-impl::toplevel-repl nil))
1.294- (let ((cmd (pop *args*)))
1.295- (cond
1.296- ((equal cmd "compile") (setq *thunk* #'x-compile))
1.297- ((equal cmd "build") (setq *thunk* #'x-build))
1.298- ((equal cmd "run") (setq *thunk* #'x-run))
1.299- ((equal cmd "test") (setq *thunk* #'x-test))
1.300- ((equal cmd "save") (setq *thunk* #'x-save))
1.301- ((equal cmd "make") (setq *thunk* #'x-make))
1.302- ((equal cmd "install") (setq *thunk* #'x-install))
1.303- (t (princ (getflag (parse-flag cmd))) (terpri) (sb-ext:exit :code 0))))))
1.304-
1.305-(defun x-init ()
1.306- (in-package :x)
1.307- (let ((*args* (cdr sb-ext:*posix-argv*))
1.308- (*log-level* :info))
1.309- (x-parse-args)
1.310- (log:debug! "running command" *thunk* *args*)
1.311- (funcall *thunk* *args*)))
1.312-
1.313-;; (format t "saving self to ./x~%")
1.314-;; (sb-ext:save-lisp-and-die
1.315-;; "x"
1.316-;; :toplevel #'x-init
1.317-;; ;; :callable-exports '("compile_std" "compile_prelude")
1.318-;; :purify nil
1.319-;; :executable t
1.320-;; :save-runtime-options t)
1.321-
1.322-(x-init)
