changelog shortlog graph tags branches changeset files revisions annotate raw help

Mercurial > core / x.lisp

changeset 286: 237756e1358b
parent: 0029791b33dd
child: 609931bd65ba
author: Richard Westhaver <ellis@rwest.io>
date: Thu, 18 Apr 2024 21:58:20 -0400
permissions: -rwxr-xr-x
description: enforcing log level (todo), rt finessing to get x to test instead of fail 
     1 #!/usr/local/bin/sbcl --script
     2 ;;; core build tool
     3 
     4 ;; 
     5 #|
     6 x.lisp
     7 |#
     8 (require 'asdf)
     9 (require 'sb-posix)
    10 (require 'sb-cover)
    11 (require 'sb-sprof)
    12 (require 'sb-concurrency)
    13 (require 'sb-rotate-byte)
    14 (require 'sb-introspect)
    15 (require 'sb-grovel)
    16 (require 'sb-cltl2)
    17 
    18 #-quicklisp
    19 (let ((quicklisp-init (merge-pathnames "quicklisp/setup.lisp" (user-homedir-pathname))))
    20   (when (probe-file quicklisp-init)
    21     (load quicklisp-init)))
    22 
    23 (unless (asdf:find-system :cl-ppcre nil)
    24   (ql:quickload :cl-ppcre)
    25   ;; (asdf:load-asd (probe-file #P"ext/cl-ppcre.asd"))
    26   )
    27 
    28 (asdf:load-asd (probe-file (merge-pathnames "std.asd" "lisp/std/std.asd")))
    29 (asdf:load-system :std)
    30 
    31 (defpackage :x
    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*))
    34 
    35 (in-package :x)
    36 
    37 (defvar *core-path* (directory-namestring #.(or *load-truename* *compile-file-truename* (error "run me as an executable!"))))
    38 
    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*))
    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 t))
    75 
    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)))
    80 
    81 (defun compile-prelude (&optional force save)
    82   ;; (compile-std)
    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)))
    86 
    87 (defun save-foreign (name exports &rest args)
    88   (apply #'sb-ext:save-lisp-and-die name (append `(:executable nil :callable-exports ,exports) args)))
    89 
    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))
    92 
    93 (defvar *thunk* nil)
    94 #-(or sbcl cl) (error "unsupported Lisp compiler")
    95 (setq *print-level* 32
    96       *print-length* 64)
    97 ;; collect args from shell
    98 (defvar *args* (cdr sb-ext:*posix-argv*))
    99 (defvar *flags*
   100   '((version "0.1.0")
   101     (help "x --- core build tool
   102 x.lisp [CMD] [OPTS...]
   103 CMDS:
   104 build
   105 run
   106 test
   107 save
   108 OPTS:
   109 --version/v
   110 --help/h
   111 ")))
   112 
   113 (defun getflag (k)
   114   (cadar
   115    (member
   116     (string-upcase k)
   117     *flags*
   118     :test #'string=
   119     :key #'car)))
   120 
   121 (defun parse-flag (arg)
   122   (flet ((f (k)
   123            (if (or (characterp k) (= (length k) 1))
   124                (case (char-downcase (character k))
   125                  (#\v "VERSION")
   126                  (#\h "HELP"))
   127                k)))
   128     (if (char-equal (aref arg 0) #\-)
   129         (if (= (length arg) 2) ;; short
   130             (f (aref arg 1))
   131             (if (char-equal (aref arg 1) #\-) ;; long
   132                 (f (subseq arg 2))
   133                 (error "invalid flag"))))))
   134 
   135 ;; (defun parse-arg (arg))
   136 
   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)))))
   142       (ql:quickload sys)
   143       (asdf:make sys))))
   144 
   145 (defun x-run (&optional args)
   146   (if 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))))
   152 
   153 (defun x-test (&optional args)
   154   (if args
   155       (let ((name (car args)))
   156         (ql:quickload name)
   157         (ql:quickload (format nil "~A/TESTS" name))
   158         (ignore-some-conditions (warning) (asdf:test-system name)))))
   159 
   160 (defun x-parse-args ()
   161   (if (null *args*)
   162       (progn
   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*)))
   169         (cond
   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))))))
   175 
   176 (defun x-init ()
   177   (in-package :x)
   178   (let ((*args* (cdr sb-ext:*posix-argv*))
   179         (*log-level* :info))
   180     (x-parse-args)
   181     (log:info! "running command" *thunk* *args*)
   182     (funcall *thunk* *args*)))
   183 
   184 (defun x-save (&optional args)
   185   (if args
   186       (let ((name (car args)))
   187         (info! "saving core to:" (merge-pathnames name *stash-path*))
   188         (string-case (name)
   189           ("prelude" (compile-prelude t))
   190           ("std" (compile-std t))))
   191       ;; self save
   192       (progn
   193         (info! "saving self to ./x")
   194         (eval
   195          (read-from-string
   196           (with-open-file (f (merge-pathnames "x.lisp" *core-path*))
   197             ;; skip shebang
   198             (read-line f t)
   199             (with-output-to-string (s)
   200               (copy-stream f s)))
   201           nil))
   202         (sb-ext:save-lisp-and-die "x"
   203                                   :toplevel #'x-init
   204                                   ;; :callable-exports '("compile_std" "compile_prelude")
   205                                   :purify t
   206                                   :executable t
   207                                   :save-runtime-options t))))
   208 
   209 (x-save)