changeset 285: |
0029791b33dd |
parent: |
597f34d43df7
|
child: |
237756e1358b |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Thu, 18 Apr 2024 21:03:49 -0400 |
permissions: |
-rwxr-xr-x |
description: |
x run |
1 #!/usr/local/bin/sbcl --script 12 (require 'sb-concurrency) 13 (require 'sb-rotate-byte) 14 (require 'sb-introspect) 19 (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname)))) 20 (when (probe-file quicklisp-init) 21 (load quicklisp-init))) 23 (unless (asdf:find-system :cl-ppcre nil) 24 (ql:quickload :cl-ppcre) 25 ;; (asdf:load-asd (probe-file #P"ext/cl-ppcre.asd")) 28 (asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/std.asd"))) 29 (asdf:load-system :std) 32 (:use :cl :std :std/named-readtables) 33 (:export :*core-path* :*lisp-path* :*lib-path* :*std-path* :*ffi-path* :*stash-path* :*app-path* :*bin-path*)) 37 (defvar *core-path* (directory-namestring #.(or *load-truename* *compile-file-truename* (error "run me as an executable!")))) 39 (defvar *lisp-path* (merge-pathnames "lisp/" *core-path*)) 40 (defvar *app-path* (merge-pathnames "app/" *lisp-path*)) 41 (defvar *bin-path* (merge-pathnames "bin/" *app-path*)) 42 (defvar *lib-path* (merge-pathnames "lib/" *lisp-path*)) 43 (defvar *std-path* (merge-pathnames "std/" *lisp-path*)) 44 (defvar *ffi-path* (merge-pathnames "ffi/" *lisp-path*)) 45 (defvar *stash-path* (merge-pathnames ".stash/" *core-path*)) 47 (push *core-path* asdf:*central-registry*) 48 (push *lisp-path* ql:*local-project-directories*) 49 (push *lib-path* ql:*local-project-directories*) 50 (push *bin-path* ql:*local-project-directories*) 51 (push *ffi-path* ql:*local-project-directories*) 53 (ql:register-local-projects) 55 (unless (asdf:find-system :log nil) 56 (asdf:load-asd (probe-file (merge-pathnames "log/log.asd" *lib-path*)))) 58 (asdf:load-system :log) 61 (unless (asdf:find-system :rocksdb nil) 62 (asdf:load-asd (probe-file (merge-pathnames "rocksdb/rocksdb.asd" *ffi-path*))) 63 (asdf:load-system :rocksdb)) 65 (unless (asdf:find-system :cli nil) 66 (asdf:load-asd (probe-file (merge-pathnames "cli/cli.asd" *lib-path*)))) 68 (asdf:load-system :cli) 71 (defun done () (print :OK)) 73 (defmethod asdf:perform ((o asdf:image-op) (c asdf:system)) 74 (uiop:dump-image (merge-pathnames (car (last (std::ssplit #\/ (asdf:component-name c)))) *stash-path*) :executable t :compression t)) 76 (defun compile-std (&optional force save) 77 (asdf:compile-system :std :force force) 78 (asdf:load-system :std :force force) 79 (when save (sb-ext:save-lisp-and-die (merge-pathnames "std.core" *stash-path*) :compression nil))) 81 (defun compile-prelude (&optional force save) 83 (asdf:compile-system :prelude :force force) 84 ;; (rocksdb:load-rocksdb save) 85 (when save (sb-ext:save-lisp-and-die (merge-pathnames "prelude.core" *stash-path*) :compression 19))) 87 (defun save-foreign (name exports &rest args) 88 (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args))) 90 (sb-alien:define-alien-callable compile-prelude sb-alien:void () (compile-prelude)) 91 (sb-alien:define-alien-callable compile-std sb-alien:void () (compile-std)) 94 #-(or sbcl cl) (error "unsupported Lisp compiler") 95 (setq *print-level* 32 97 ;; collect args from shell 98 (defvar *args* (cdr sb-ext:*posix-argv*)) 101 (help "x --- core build tool 102 x.lisp [CMD] [OPTS...] 121 (defun parse-flag (arg) 123 (if (or (characterp k) (= (length k) 1)) 124 (case (char-downcase (character k)) 128 (if (char-equal (aref arg 0) #\-) 129 (if (= (length arg) 2) ;; short 131 (if (char-equal (aref arg 1) #\-) ;; long 133 (error "invalid flag")))))) 135 ;; (defun parse-arg (arg)) 137 (defun x-build (&optional args) 138 (let ((name (car args))) 139 (ensure-directories-exist *stash-path*) 140 (info! "saving executable to:" (merge-pathnames name *stash-path*)) 141 (let ((sys (sb-int:keywordicate (format nil "BIN/~A" (string-upcase name))))) 145 (defun x-run (&optional args) 147 (let* ((name (car args)) 148 (path (merge-pathnames name *stash-path*))) 149 (unless (probe-file path) 150 (sb-ext:run-program "x" (list "build" name) :wait t)) 151 (sb-ext:run-program path (cdr args) :output t)))) 153 (defun x-test (&optional args) 155 (let ((name (car args))) 157 (ql:quickload (format nil "~A/TESTS" name)) 158 (ignore-some-conditions (warning) (asdf:test-system name))))) 160 (defun x-parse-args () 163 (println "Welcome to CORE/X") 164 (use-package :cl-user) 165 (use-package :sb-ext) 166 (use-package :std-user) 167 (sb-impl::toplevel-repl nil)) 168 (let ((cmd (pop *args*))) 170 ((equal cmd "build") (setq *thunk* #'x-build)) 171 ((equal cmd "run") (setq *thunk* #'x-run)) 172 ((equal cmd "test") (setq *thunk* #'x-test)) 173 ((equal cmd "save") (setq *thunk* #'x-save)) 174 (t (princ (getflag (parse-flag cmd))) (terpri) (sb-ext:exit :code 0)))))) 178 (let ((*args* (cdr sb-ext:*posix-argv*))) 180 (log:info! "running command" *thunk* *args*) 181 (funcall *thunk* *args*))) 183 (defun x-save (&optional args) 185 (let ((name (car args))) 186 (info! "saving core to:" (merge-pathnames name *stash-path*)) 188 ("prelude" (compile-prelude t)) 189 ("std" (compile-std t)))) 192 (info! "saving self to ./x") 195 (with-open-file (f (merge-pathnames "x.lisp" *core-path*)) 198 (with-output-to-string (s) 201 (sb-ext:save-lisp-and-die "x" 203 ;; :callable-exports '("compile_std" "compile_prelude") 206 :save-runtime-options t))))