changeset 362: |
b1f78dffbcdd |
parent: |
09f056e9a789
|
child: |
49c3f3d11432 |
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Thu, 23 May 2024 18:23:38 -0400 |
permissions: |
-rwxr-xr-x |
description: |
rustls work, fixed https bugs |
1 #!/usr/local/bin/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) 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 ;; (rocksdb:load-rocksdb save) 92 (when save (sb-ext:save-lisp-and-die (merge-pathnames "prelude.core" *stash-path*) :compression *compression-level*))) 94 (defun save-foreign (name exports &rest args) 95 (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args))) 97 (sb-alien:define-alien-callable compile-prelude sb-alien:void () (compile-prelude)) 98 (sb-alien:define-alien-callable compile-std sb-alien:void () (compile-std)) 102 (setq *print-level* 32 104 ;; collect args from shell 105 (defvar *args* (cdr sb-ext:*posix-argv*)) 108 (help "x --- core build tool 130 (defun parse-flag (arg) 132 (if (or (characterp k) (= (length k) 1)) 133 (case (char-downcase (character k)) 137 (if (char-equal (aref arg 0) #\-) 138 (if (= (length arg) 2) ;; short 140 (if (char-equal (aref arg 1) #\-) ;; long 142 (bail "invalid flag")))))) 144 ;; (defun parse-arg (arg)) 145 (defun x-compile (args) 147 (let ((name (car args))) 149 (asdf:compile-system name :force t)) 150 (compile-prelude t nil))) 153 (format t "saving ~A to: ~A~%" name (merge-pathnames name *stash-path*)) 154 (let ((sys (sb-int:keywordicate (format nil "BIN/~A" (string-upcase name))))) 158 (defun x-build (args) 160 (let ((name (car args))) 161 (ensure-directories-exist *stash-path*) 163 (std:wait-for-threads (mapcar 165 (sb-thread:make-thread 167 (sb-ext:run-program "x" (list "build" x) :wait t :output t)) 169 (list "skel" "rdb" "organ" "homer" "packy"))))) 173 (let ((name (car args))) 174 (ensure-directories-exist *stash-path*) 175 (format t "saving core to: ~A~%" (merge-pathnames name *stash-path*)) 177 ("prelude" (compile-prelude t t)) 178 ("std" (compile-std t t)))) 180 (sb-ext:run-program "x.lisp" nil :input t :output t))) 182 (asdf:load-asd (probe-file (merge-pathnames "log.asd" "lisp/lib/log/"))) 183 (asdf:load-asd (probe-file (merge-pathnames "rt.asd" "lisp/lib/rt/"))) 184 (asdf:load-system :log) 185 (asdf:load-system :rt) 190 (let ((name (car args))) 191 (ql:quickload (string-upcase (format nil "~A/tests" name))) 192 (rt:do-tests (string-upcase name) t)) 193 (bail "missing arg"))) 197 (let* ((name (car args)) 198 (path (merge-pathnames name *stash-path*))) 199 (unless (probe-file path) 200 (sb-ext:run-program "x" (list "build" name) :wait t :output t)) 201 (sb-ext:run-program path (cdr args) :output t)) 202 (bail "missing arg"))) 204 (defun %install (name) 205 (let ((path (merge-pathnames name *stash-path*))) 206 (unless (probe-file path) 207 (sb-ext:run-program "x" (list "build" name) :wait t :output t)) 208 (sb-ext:run-program "/bin/sudo" 209 (list "install" "-C" "-m" "755" (namestring path) "/usr/local/bin/") 213 (format t "installed ~A to ~A~%" name (merge-pathnames name "/usr/local/bin/")))) 215 (defun x-install (args) 218 (list "skel" "rdb" "organ" "homer" "packy")))) 220 (defun x-parse-args () 223 (println "Welcome to CORE/X") 224 (use-package :cl-user) 225 (use-package :sb-ext) 226 (use-package :std-user) 227 (sb-impl::toplevel-repl nil)) 228 (let ((cmd (pop *args*))) 230 ((equal cmd "compile") (setq *thunk* #'x-compile)) 231 ((equal cmd "build") (setq *thunk* #'x-build)) 232 ((equal cmd "run") (setq *thunk* #'x-run)) 233 ((equal cmd "test") (setq *thunk* #'x-test)) 234 ((equal cmd "save") (setq *thunk* #'x-save)) 235 ((equal cmd "install") (setq *thunk* #'x-install)) 236 (t (princ (getflag (parse-flag cmd))) (terpri) (sb-ext:exit :code 0)))))) 240 (let ((*args* (cdr sb-ext:*posix-argv*)) 243 (log:debug! "running command" *thunk* *args*) 244 (funcall *thunk* *args*))) 246 (format t "saving self to ./x~%") 247 (sb-ext:save-lisp-and-die 250 ;; :callable-exports '("compile_std" "compile_prelude") 253 :save-runtime-options t)