changeset 396: |
6f2796285c41 |
parent: |
88a6edf5291b
|
child: |
96020a698c0b |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Sun, 02 Jun 2024 19:23:41 -0400 |
permissions: |
-rwxr-xr-x |
description: |
bug fix, messing with org 9.7 features |
1 #!/usr/bin/env -S sbcl --script 10 (require 'sb-concurrency) 12 #-(or sbcl cl) (error "unsupported Lisp compiler") 15 (let ((quicklisp-init "/usr/local/share/lisp/quicklisp/setup.lisp")) 16 (when (probe-file quicklisp-init) 17 (load quicklisp-init))) 19 (unless (asdf:find-system :cl-ppcre nil) 20 (ql:quickload :cl-ppcre) 21 ;; (asdf:load-asd (probe-file #P"ext/cl-ppcre.asd")) 24 (asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/"))) 25 (asdf:load-system :std) 28 (:use :cl :std :std/named-readtables) 29 (:export :*core-path* :*lisp-path* :*lib-path* :*std-path* :*ffi-path* :*stash-path* :*web-path* :*bin-path* 30 :*compression-level*)) 33 (require 'sb-rotate-byte) 34 (require 'sb-introspect) 39 (use-package :sb-gray) 40 ;; (require 'sb-aclrepl) 41 (sb-ext:enable-debugger) 42 (defvar *core-path* (directory-namestring #.(or *load-truename* *compile-file-truename* (error "run me as an executable!")))) 44 (defvar *lisp-path* (merge-pathnames "lisp/" *core-path*)) 45 (defvar *bin-path* (merge-pathnames "bin/" *lisp-path*)) 46 (defvar *web-path* (merge-pathnames "web/" *lisp-path*)) 47 (defvar *lib-path* (merge-pathnames "lib/" *lisp-path*)) 48 (defvar *std-path* (merge-pathnames "std/" *lisp-path*)) 49 (defvar *ffi-path* (merge-pathnames "ffi/" *lisp-path*)) 50 (defvar *stash-path* (merge-pathnames ".stash/" *core-path*)) 52 (defvar *compression-level* nil) 54 (push *core-path* asdf:*central-registry*) 55 (push *lisp-path* ql:*local-project-directories*) 56 (push *lib-path* ql:*local-project-directories*) 57 (push *bin-path* ql:*local-project-directories*) 58 (push *ffi-path* ql:*local-project-directories*) 60 (ql:register-local-projects) 62 (unless (asdf:find-system :log nil) 63 (asdf:load-asd (probe-file (merge-pathnames "log/log.asd" *lib-path*)))) 65 (asdf:load-system :log) 68 (unless (asdf:find-system :rocksdb nil) 69 (asdf:load-asd (probe-file (merge-pathnames "rocksdb/rocksdb.asd" *ffi-path*))) 70 (asdf:load-system :rocksdb)) 72 (unless (asdf:find-system :cli nil) 73 (asdf:load-asd (probe-file (merge-pathnames "cli/cli.asd" *lib-path*)))) 75 (asdf:load-system :cli) 78 (defun done () (print :OK)) 80 (defmethod asdf:perform ((o asdf:image-op) (c asdf:system)) 81 (uiop:dump-image (merge-pathnames (car (last (std::ssplit #\/ (asdf:component-name c)))) *stash-path*) :executable t :compression *compression-level*)) 83 (defun compile-std (&optional force save) 84 (asdf:compile-system :std :force force) 85 (asdf:load-system :std :force force) 86 (when save (sb-ext:save-lisp-and-die (merge-pathnames "std.core" *stash-path*) :compression *compression-level*))) 88 (defun compile-prelude (&optional force save) 90 (asdf:compile-system :prelude :force force) 91 (asdf:load-system :prelude :force force) 92 ;; (rocksdb:load-rocksdb save) 93 (when save (sb-ext:save-lisp-and-die (merge-pathnames "prelude.core" *stash-path*) :compression *compression-level*))) 95 (defun compile-user (&optional force save) 96 (asdf:compile-system :user :force force) 97 (asdf:load-system :user :force force) 98 (when save (sb-ext:save-lisp-and-die (merge-pathnames "user.core" *stash-path*) :compression *compression-level*))) 100 (defun save-foreign (name exports &rest args) 101 (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args))) 103 (sb-alien:define-alien-callable compile-prelude sb-alien:void () (compile-prelude)) 104 (sb-alien:define-alien-callable compile-std sb-alien:void () (compile-std)) 105 (sb-alien:define-alien-callable compile-user sb-alien:void () (compile-user)) 109 (setq *print-level* 32 111 ;; collect args from shell 112 (defvar *args* (cdr sb-ext:*posix-argv*)) 115 (help "x --- core build tool 137 (defun parse-flag (arg) 139 (if (or (characterp k) (= (length k) 1)) 140 (case (char-downcase (character k)) 144 (if (char-equal (aref arg 0) #\-) 145 (if (= (length arg) 2) ;; short 147 (if (char-equal (aref arg 1) #\-) ;; long 149 (bail "invalid flag")))))) 151 ;; (defun parse-arg (arg)) 152 (defun x-compile (args) 154 (let ((name (car args))) 156 (asdf:compile-system name :force t)) 157 (compile-prelude t nil))) 160 (format t "saving ~A to: ~A~%" name (merge-pathnames name *stash-path*)) 161 (let ((sys (sb-int:keywordicate (format nil "BIN/~A" (string-upcase name))))) 163 (push :ssl *features*) 164 (std/sys:forget-shared-objects) 167 (defun x-build (args) 169 (let ((name (car args))) 170 (ensure-directories-exist *stash-path*) 172 (std:wait-for-threads (mapcar 174 (sb-thread:make-thread 176 (sb-ext:run-program "x" (list "build" x) :wait t :output t)) 178 (list "skel" "rdb" "organ" "homer" "packy"))))) 182 (let ((name (car args))) 183 (ensure-directories-exist *stash-path*) 184 (format t "saving core to: ~A~%" (merge-pathnames name *stash-path*)) 186 ("prelude" (compile-prelude t t)) 187 ("std" (compile-std t t)) 188 ("user" (compile-user t t)))) 190 (sb-ext:run-program "x.lisp" nil :input t :output t))) 192 (asdf:load-asd (probe-file (merge-pathnames "log.asd" "lisp/lib/log/"))) 193 (asdf:load-asd (probe-file (merge-pathnames "rt.asd" "lisp/lib/rt/"))) 194 (asdf:load-system :log) 195 (asdf:load-system :rt) 200 (let ((name (car args))) 202 (ql:quickload (string-upcase (format nil "~A/tests" name))) 203 (rt:do-tests (string-upcase name) t)) 204 (bail "missing arg"))) 208 (let* ((name (car args)) 209 (path (merge-pathnames name *stash-path*))) 210 (unless (probe-file path) 211 (sb-ext:run-program "x" (list "build" name) :wait t :output t)) 212 (sb-ext:run-program path (cdr args) :output t)) 213 (bail "missing arg"))) 215 (defun %install (name) 216 (let ((path (merge-pathnames name *stash-path*))) 217 (unless (probe-file path) 218 (sb-ext:run-program "x" (list "build" name) :wait t :output t)) 219 (sb-ext:run-program "/bin/sudo" 220 (list "install" "-C" "-m" "755" (namestring path) "/usr/local/bin/") 224 (format t "installed ~A to ~A~%" name (merge-pathnames name "/usr/local/bin/")))) 226 (defun x-install (args) 229 (list "skel" "rdb" "organ" "homer" "packy")))) 231 (defun x-parse-args () 234 (println "Welcome to CORE/X") 235 (use-package :cl-user) 236 (use-package :sb-ext) 237 (use-package :std-user) 238 (sb-impl::toplevel-repl nil)) 239 (let ((cmd (pop *args*))) 241 ((equal cmd "compile") (setq *thunk* #'x-compile)) 242 ((equal cmd "build") (setq *thunk* #'x-build)) 243 ((equal cmd "run") (setq *thunk* #'x-run)) 244 ((equal cmd "test") (setq *thunk* #'x-test)) 245 ((equal cmd "save") (setq *thunk* #'x-save)) 246 ((equal cmd "install") (setq *thunk* #'x-install)) 247 (t (princ (getflag (parse-flag cmd))) (terpri) (sb-ext:exit :code 0)))))) 251 (let ((*args* (cdr sb-ext:*posix-argv*)) 254 (log:debug! "running command" *thunk* *args*) 255 (funcall *thunk* *args*))) 257 (format t "saving self to ./x~%") 258 (sb-ext:save-lisp-and-die 261 ;; :callable-exports '("compile_std" "compile_prelude") 264 :save-runtime-options t)