changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / x.lisp

changeset 397: a79d494b0e9c
parent: 88a6edf5291b
child: 96020a698c0b
author: Richard Westhaver <ellis@rwest.io>
date: Sun, 02 Jun 2024 20:11:01 -0400
permissions: -rwxr-xr-x
description: org id updates 
     1 #!/usr/bin/env -S sbcl --script
     2 ;;; core build tool
     3 
     4 ;; 
     5 #|
     6 x.lisp
     7 |#
     8 (require 'asdf)
     9 ;; (require 'sb-posix)
    10 (require 'sb-concurrency)
    11 
    12 #-(or sbcl cl) (error "unsupported Lisp compiler")
    13 
    14 #-quicklisp
    15 (let ((quicklisp-init "/usr/local/share/lisp/quicklisp/setup.lisp"))
    16   (when (probe-file quicklisp-init)
    17     (load quicklisp-init)))
    18 
    19 (unless (asdf:find-system :cl-ppcre nil)
    20   (ql:quickload :cl-ppcre)
    21   ;; (asdf:load-asd (probe-file #P"ext/cl-ppcre.asd"))
    22   )
    23 
    24 (asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/")))
    25 (asdf:load-system :std)
    26 
    27 (defpackage :x
    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*))
    31 
    32 (in-package :x)
    33 (require 'sb-rotate-byte)
    34 (require 'sb-introspect)
    35 (require 'sb-grovel)
    36 (require 'sb-cltl2)
    37 (require 'sb-cover)
    38 (require 'sb-sprof)
    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!"))))
    43 
    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*))
    51 
    52 (defvar *compression-level* nil)
    53 
    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*)
    59 
    60 (ql:register-local-projects)
    61 
    62 (unless (asdf:find-system :log nil)
    63   (asdf:load-asd (probe-file (merge-pathnames "log/log.asd" *lib-path*))))
    64 
    65 (asdf:load-system :log)
    66 (use-package :log)
    67 
    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))
    71 
    72 (unless (asdf:find-system :cli nil)
    73   (asdf:load-asd (probe-file (merge-pathnames "cli/cli.asd" *lib-path*))))
    74 
    75 (asdf:load-system :cli)
    76 (use-package :cli)
    77 
    78 (defun done () (print :OK))
    79 
    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*))
    82 
    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*)))
    87 
    88 (defun compile-prelude (&optional force save)
    89   ;; (compile-std)
    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*)))
    94 
    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*)))
    99 
   100 (defun save-foreign (name exports &rest args)
   101   (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args)))
   102 
   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))
   106 
   107 (defvar *thunk* nil)
   108 
   109 (setq *print-level* 32
   110       *print-length* 64)
   111 ;; collect args from shell
   112 (defvar *args* (cdr sb-ext:*posix-argv*))
   113 (defvar *flags*
   114   '((version "0.1.0")
   115     (help "x --- core build tool
   116 x.lisp [CMD]
   117 CMDS:
   118 test
   119 compile
   120 build
   121 test
   122 run
   123 save
   124 install")))
   125 
   126 (defun getflag (k)
   127   (cadar
   128    (member
   129     (string-upcase k)
   130     *flags*
   131     :test #'string=
   132     :key #'car)))
   133 
   134 (defun bail (msg)
   135   (log::fatal! msg))
   136 
   137 (defun parse-flag (arg)
   138   (flet ((f (k)
   139            (if (or (characterp k) (= (length k) 1))
   140                (case (char-downcase (character k))
   141                  (#\v "VERSION")
   142                  (#\h "HELP"))
   143                k)))
   144     (if (char-equal (aref arg 0) #\-)
   145         (if (= (length arg) 2) ;; short
   146             (f (aref arg 1))
   147             (if (char-equal (aref arg 1) #\-) ;; long
   148                 (f (subseq arg 2))
   149                 (bail "invalid flag"))))))
   150 
   151 ;; (defun parse-arg (arg))
   152 (defun x-compile (args)
   153   (if args
   154       (let ((name (car args)))
   155         (ql:quickload name)
   156         (asdf:compile-system name :force t))
   157       (compile-prelude t nil)))
   158 
   159 (defun %build (name)
   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)))))
   162     (ql:quickload sys)
   163     (push :ssl *features*)
   164     (std/sys:forget-shared-objects)
   165     (asdf:make sys)))
   166 
   167 (defun x-build (args)
   168   (if args
   169       (let ((name (car args)))
   170         (ensure-directories-exist *stash-path*)
   171         (%build name))
   172       (std:wait-for-threads (mapcar
   173                              (lambda (x)
   174                                (sb-thread:make-thread
   175                                 (lambda ()
   176                                   (sb-ext:run-program "x" (list "build" x) :wait t :output t))
   177                                 :name x))
   178                              (list "skel" "rdb" "organ" "homer" "packy")))))
   179 
   180 (defun x-save (args)
   181   (if args
   182       (let ((name (car args)))
   183         (ensure-directories-exist *stash-path*)
   184         (format t "saving core to: ~A~%" (merge-pathnames name *stash-path*))
   185         (string-case (name)
   186           ("prelude" (compile-prelude t t))
   187           ("std" (compile-std t t))
   188           ("user" (compile-user t t))))
   189       ;; self save
   190       (sb-ext:run-program "x.lisp" nil :input t :output t)))
   191 
   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)
   196 (ql:quickload :rt)
   197 
   198 (defun x-test (args)
   199   (if args
   200       (let ((name (car args)))
   201         (ql:quickload :rt)
   202         (ql:quickload (string-upcase (format nil "~A/tests" name)))
   203         (rt:do-tests (string-upcase name) t))
   204       (bail "missing arg")))
   205 
   206 (defun x-run (args)
   207   (if args
   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")))
   214 
   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/")
   221                         :input t
   222                         :wait t
   223                         :output t)
   224     (format t "installed ~A to ~A~%" name (merge-pathnames name "/usr/local/bin/"))))
   225 
   226 (defun x-install (args)
   227   (mapc #'%install
   228         (or args
   229             (list "skel" "rdb" "organ" "homer" "packy"))))
   230 
   231 (defun x-parse-args ()
   232   (if (null *args*)
   233       (progn
   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*)))
   240         (cond
   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))))))
   248 
   249 (defun x-init ()
   250   (in-package :x)
   251   (let ((*args* (cdr sb-ext:*posix-argv*))
   252         (*log-level* :info))
   253     (x-parse-args)
   254     (log:debug! "running command" *thunk* *args*)
   255     (funcall *thunk* *args*)))
   256 
   257 (format t "saving self to ./x~%")
   258 (sb-ext:save-lisp-and-die
   259  "x"
   260  :toplevel #'x-init
   261  ;; :callable-exports '("compile_std" "compile_prelude")
   262  :purify nil
   263  :executable t
   264  :save-runtime-options t)