changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / x.lisp

changeset 648: 926d95e5fdc7
parent: d7ca8ff34865
child: af486e0a40c9
author: Richard Westhaver <ellis@rwest.io>
date: Thu, 12 Sep 2024 16:48:47 -0400
permissions: -rwxr-xr-x
description: cli/multi and slime-cape fixes 
     1 #!/usr/bin/env -S sbcl --no-sysinit --no-userinit --script
     2 ;;; core build tool
     3 
     4 ;; 
     5 
     6 ;;; Code:
     7 (in-package :cl-user)
     8 #-(or sbcl cl) (error "unsupported Lisp compiler")
     9 #-quicklisp
    10 (let ((quicklisp-init (or (probe-file #p"~/.stash/quicklisp/setup.lisp")
    11                           (probe-file #p"/usr/local/share/lisp/quicklisp/setup.lisp")
    12                           (probe-file #p "~/quicklisp/setup.lisp"))))
    13   (when (probe-file quicklisp-init)
    14     (load quicklisp-init)))
    15 (require 'sb-rotate-byte)
    16 (require 'sb-introspect)
    17 (require 'sb-grovel)
    18 (require 'sb-cltl2)
    19 (require 'sb-cover)
    20 (require 'sb-sprof)
    21 
    22 (asdf:load-system (asdf:find-system :cl-ppcre))
    23 (asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/")))
    24 (asdf:load-system :std)
    25 
    26 (defpackage :x
    27   (:use :cl :std :std/named-readtables :cl-user)
    28   (:export :*core-path* :*lisp-path* :*lib-path* :*std-path* :*ffi-path* :*stash-path* :*web-path* :*bin-path*
    29            :*compression-level*))
    30 
    31 (in-package :x)
    32 (use-package :sb-gray)
    33 ;; (require 'sb-aclrepl)
    34 (sb-ext:enable-debugger)
    35 (defvar *core-path* (directory-namestring #.(or *load-truename* *compile-file-truename* (error "run me as an executable!"))))
    36 
    37 (defvar *lisp-path* (merge-pathnames "lisp/" *core-path*))
    38 (defvar *bin-path* (merge-pathnames "bin/" *lisp-path*))
    39 (defvar *web-path* (merge-pathnames "web/" *lisp-path*))
    40 (defvar *lib-path* (merge-pathnames "lib/" *lisp-path*))
    41 (defvar *std-path* (merge-pathnames "std/" *lisp-path*))
    42 (defvar *ffi-path* (merge-pathnames "ffi/" *lisp-path*))
    43 (defvar *stash-path* (merge-pathnames ".stash/" *core-path*))
    44 
    45 (defvar *compression-level* nil)
    46 
    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*)
    52 
    53 (ql:register-local-projects)
    54 
    55 (unless (asdf:find-system :log nil)
    56   (asdf:load-asd (probe-file (merge-pathnames "log/log.asd" *lib-path*))))
    57 
    58 (asdf:load-system :log)
    59 (use-package :log)
    60 
    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))
    64 
    65 (unless (asdf:find-system :cli nil)
    66   (asdf:load-asd (probe-file (merge-pathnames "cli/cli.asd" *lib-path*))))
    67 
    68 (asdf:load-system :cli)
    69 (use-package :cli)
    70 
    71 (defun done () (print :OK))
    72 
    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 *compression-level*))
    75 
    76 (defun compile-std (&optional force save)
    77   (ql:quickload :std)
    78   (when save
    79     (in-package :std-user)
    80     (sb-ext:save-lisp-and-die (merge-pathnames "std.core" *stash-path*) :compression *compression-level*)))
    81 
    82 (defun compile-prelude (&optional force save)
    83   ;; (compile-std)
    84   (asdf:compile-system :prelude :force force)
    85   (asdf:load-system :prelude :force force)
    86   ;; (rocksdb:load-rocksdb save)
    87   (when save
    88     (in-package :std-user)
    89     (use-package :cl-user)
    90     (sb-ext:save-lisp-and-die (merge-pathnames "prelude.core" *stash-path*) :compression *compression-level*)))
    91 
    92 (defun compile-user (&optional force save compression (name "user.core"))
    93   (asdf:compile-system :user :force force)
    94   (asdf:load-system :user :force force)
    95   (when save
    96     (in-package :user)
    97     (use-package :cl-user)
    98     (sb-ext:save-lisp-and-die (merge-pathnames name *stash-path*) :compression (or compression *compression-level*))))
    99 
   100 
   101 (defun compile-tests (&optional force save)
   102   (asdf:compile-system :core/tests :force force)
   103   (asdf:load-system :core/tests :force force)
   104   (when save
   105     (in-package :core/tests)
   106     (sb-ext:save-lisp-and-die (merge-pathnames "tests.core" *stash-path*) :compression *compression-level*)))
   107 
   108 (defun compile-core (&optional force save)
   109   (asdf:compile-system :core :force force)
   110   (asdf:load-system :core :force force)
   111   (when save
   112     (in-package :core)
   113     (sb-ext:save-lisp-and-die (merge-pathnames "core.core" *stash-path*) :compression *compression-level*)))
   114 
   115 (defun save-foreign (name exports &rest args)
   116   (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args)))
   117 
   118 (sb-alien:define-alien-callable compile-prelude sb-alien:void () (compile-prelude))
   119 (sb-alien:define-alien-callable compile-std sb-alien:void () (compile-std))
   120 (sb-alien:define-alien-callable compile-user sb-alien:void () (compile-user))
   121 
   122 (defvar *thunk* nil)
   123 
   124 (setq *print-level* 32
   125       *print-length* 64)
   126 ;; collect args from shell
   127 (defvar *args* (cdr sb-ext:*posix-argv*))
   128 (defvar *flags*
   129   '((version "0.1.0")
   130     (help "x.lisp --- core build tool
   131 x.lisp [CMD]
   132 CMDS:
   133 test
   134 compile
   135 build
   136 make
   137 test
   138 run
   139 save
   140 install")))
   141 
   142 (defun getflag (k)
   143   (cadar
   144    (member
   145     (string-upcase k)
   146     *flags*
   147     :test #'string=
   148     :key #'car)))
   149 
   150 (defun bail (msg)
   151   (log::fatal! msg))
   152 
   153 (defun parse-flag (arg)
   154   (flet ((f (k)
   155            (if (or (characterp k) (= (length k) 1))
   156                (case (char-downcase (character k))
   157                  (#\v "VERSION")
   158                  (#\h "HELP"))
   159                k)))
   160     (if (char-equal (aref arg 0) #\-)
   161         (if (= (length arg) 2) ;; short
   162             (f (aref arg 1))
   163             (if (char-equal (aref arg 1) #\-) ;; long
   164                 (f (subseq arg 2))
   165                 (bail "invalid flag"))))))
   166 
   167 ;; (defun parse-arg (arg))
   168 (defun x-compile (args)
   169   (if args
   170       (let ((name (car args)))
   171         (ql:quickload name)
   172         (asdf:compile-system name :force t))
   173       (compile-prelude t nil)))
   174 
   175 (defun %build (name)
   176   (format t "saving ~A to: ~A~%" name (merge-pathnames name *stash-path*))
   177   (let ((sys (sb-int:keywordicate (format nil "BIN/~A" (string-upcase name)))))
   178     (ql:quickload sys)
   179     (push :ssl *features*)
   180     ;; (std/sys:forget-shared-objects)
   181     (asdf:make sys)))
   182 
   183 (defun x-build (args)
   184   (if args
   185       (let ((name (car args)))
   186         (ensure-directories-exist *stash-path*)
   187         (%build name))
   188       (std:wait-for-threads (mapcar
   189                              (lambda (x)
   190                                (sb-thread:make-thread
   191                                 (lambda ()
   192                                   (sb-ext:run-program "x.lisp" (list "build" x) :wait t :output t))
   193                                 :name x))
   194                              (list "skel" "rdb" "organ" "homer" "packy")))))
   195 
   196 (defun stash-output (name)
   197   (let* ((sys (asdf:find-system name))
   198          (fasl (make-pathname
   199                 :name (asdf/system:component-build-pathname sys)
   200                 :type (if (string-equal name "std")
   201                           "lisp"
   202                           "fasl"))))
   203     (uiop:rename-file-overwriting-target
   204      (merge-pathnames fasl (asdf:system-source-directory sys))
   205      (merge-pathnames fasl *stash-path*))))
   206 
   207 (defun %make (name)
   208   (let ((sys (sb-int:keywordicate (string-upcase name))))
   209     (std/sys:forget-shared-objects)
   210     (asdf:load-system sys)
   211     (in-package :std-user)
   212     (asdf:make sys)
   213     ()
   214     (stash-output sys)
   215     (println :OK)))
   216 
   217 (defun x-make (args)
   218   (if args
   219       (let ((name (car args)))
   220         (ensure-directories-exist *stash-path*)
   221         (%make name))
   222       (std:wait-for-threads (mapcar
   223                              (lambda (x)
   224                                (sb-thread:make-thread
   225                                 (lambda ()
   226                                   (sb-ext:run-program "x.lisp" (list "make" x) :wait t :output t))
   227                                 :name x))
   228                              (list "core" "user" "prelude" "core/tests" "core/bench" "core/lib" "core/ffi")))))
   229 
   230 (defun x-save (args)
   231   (if args
   232       (let ((name (car args)))
   233         (ensure-directories-exist *stash-path*)
   234         (format t "saving core to: ~A~%" (merge-pathnames name *stash-path*))
   235         (string-case (name)
   236           ("prelude" (compile-prelude t t))
   237           ("core" (compile-core t t))
   238           ("std" (compile-std t t))
   239           ("user" (compile-user t t))
   240           ("infra" (compile-user t t 22 "infra.core"))
   241           ("tests" (compile-tests t t))))
   242       ;; (sb-ext:run-program "x.lisp" nil :input t :output t)
   243       ))
   244 
   245 (asdf:load-asd (probe-file (merge-pathnames "log.asd" "lisp/lib/log/")))
   246 (asdf:load-asd (probe-file (merge-pathnames "rt.asd" "lisp/lib/rt/")))
   247 (asdf:load-system :log)
   248 (asdf:load-system :rt)
   249 (ql:quickload :rt)
   250 
   251 (defun x-test (args)
   252   (if args
   253       (let ((name (car args)))
   254         (ql:quickload :rt)
   255         (ql:quickload (string-upcase (format nil "~A/tests" name)))
   256         (rt:do-tests (string-upcase name) t))
   257       (bail "missing arg")))
   258 
   259 (defun x-run (args)
   260   (if args
   261       (let* ((name (car args))
   262              (path (merge-pathnames name *stash-path*)))
   263         (unless (probe-file path)
   264           (sb-ext:run-program "x" (list "build" name) :wait t :output t))
   265         (sb-ext:run-program path (cdr args) :output t))
   266       (bail "missing arg")))
   267 
   268 (defun %install (name)
   269   (let ((path (merge-pathnames name *stash-path*)))
   270     (unless (probe-file path)
   271       (sb-ext:run-program "x" (list "build" name) :wait t :output t))
   272     (sb-ext:run-program "/bin/sudo"
   273                         (list "install" "-C" "-m" "755" (namestring path) "/usr/local/bin/")
   274                         :input t
   275                         :wait t
   276                         :output t)
   277     (format t "installed ~A to ~A~%" name (merge-pathnames name "/usr/local/bin/"))))
   278 
   279 (defun x-install (args)
   280   (mapc #'%install
   281         (or args
   282             (list "skel" "rdb" "organ" "homer" "packy"))))
   283 
   284 (defun x-parse-args ()
   285   (if (null *args*)
   286       (progn
   287         (println "Welcome to CORE/X")
   288         (use-package :cl-user)
   289         (use-package :sb-ext)
   290         (use-package :std-user)
   291         (sb-impl::toplevel-repl nil))
   292       (let ((cmd (pop *args*)))
   293         (cond
   294           ((equal cmd "compile") (setq *thunk* #'x-compile))
   295           ((equal cmd "build") (setq *thunk* #'x-build))
   296           ((equal cmd "run") (setq *thunk* #'x-run))
   297           ((equal cmd "test") (setq *thunk* #'x-test))
   298           ((equal cmd "save") (setq *thunk* #'x-save))
   299           ((equal cmd "make") (setq *thunk* #'x-make))
   300           ((equal cmd "install") (setq *thunk* #'x-install))
   301           (t (princ (getflag (parse-flag cmd))) (terpri) (sb-ext:exit :code 0))))))
   302 
   303 (defun x-init ()
   304   (in-package :x)
   305   (let ((*args* (cdr sb-ext:*posix-argv*))
   306         (*log-level* :info))
   307     (x-parse-args)
   308     (log:debug! "running command" *thunk* *args*)
   309     (funcall *thunk* *args*)))
   310 
   311 ;; (format t "saving self to ./x~%")
   312 ;; (sb-ext:save-lisp-and-die
   313 ;;  "x"
   314 ;;  :toplevel #'x-init
   315 ;;  ;; :callable-exports '("compile_std" "compile_prelude")
   316 ;;  :purify nil
   317 ;;  :executable t
   318 ;; :save-runtime-options t)
   319 
   320 (x-init)