# HG changeset patch # User Richard Westhaver # Date 1726017990 14400 # Node ID f901de70a80edb2b4cfc37158ceead5f8243419c # Parent f58f3b88c49efb9d925ab31fcd13ed3b656224c0 opt fixes and test updates diff -r f58f3b88c49e -r f901de70a80e emacs/default.el --- a/emacs/default.el Sun Sep 08 21:14:30 2024 -0400 +++ b/emacs/default.el Tue Sep 10 21:26:30 2024 -0400 @@ -223,6 +223,21 @@ (use-package company :ensure t) (use-package slime-repl-ansi-color :ensure t) +(defvar slime-toggle nil) +(defun slime-toggle () + "toggle between lisp file and slime-repl" + (interactive) + (cond + ((eq major-mode 'slime-repl-mode) + (setq slime-toggle (pop-to-buffer (or slime-toggle (read-buffer "lisp buffer: "))))) + ((not (eq major-mode 'slime-repl-mode)) + (if (slime-connected-p) + (progn + (setq slime-toggle (current-buffer)) + (slime-switch-to-output-buffer)) + (setq slime-toggle (current-buffer)) + (slime))))) + (use-package slime :ensure t :after (slime-cape slime-repl-ansi-color) @@ -235,6 +250,7 @@ ;; slime-enclosing-context ;; slime-media ;; slime-mrepl + slime-company slime-sbcl-exts slime-cape ;; ext slime-repl-ansi-color @@ -249,22 +265,8 @@ slime-asdf)) (put 'make-instance 'common-lisp-indent-function 1) (put 'reinitialize-instance 'common-lisp-indent-function 1) + (slime-company-init) (slime-setup) - (defvar slime-toggle nil) - (defun slime-toggle () - "toggle between lisp file and slime-repl" - (interactive) - (cond - ((eq major-mode 'slime-repl-mode) - (setq slime-toggle (pop-to-buffer (or slime-toggle (read-buffer "lisp buffer: "))))) - ((not (eq major-mode 'slime-repl-mode)) - (if (slime-connected-p) - (progn - (setq slime-toggle (current-buffer)) - (slime-switch-to-output-buffer)) - (setq slime-toggle (current-buffer)) - (slime))))) - ;; X11-only (mcclim requires clx) (defun clouseau-inspect (string) "Inspect a lisp value with Clouseau. make sure to load clouseau diff -r f58f3b88c49e -r f901de70a80e lisp/lib/cli/clap/cli.lisp --- a/lisp/lib/cli/clap/cli.lisp Sun Sep 08 21:14:30 2024 -0400 +++ b/lisp/lib/cli/clap/cli.lisp Tue Sep 10 21:26:30 2024 -0400 @@ -53,11 +53,12 @@ (t (make-cli :opt :name (format nil "~(~A~)" x) :global t)))) opts)) -(defun make-cmds (cmds) +(defun make-cmds (&rest cmds) "Make a vector of CLI-CMDs based on CMDS." (map 'vector (lambda (x) (etypecase x + (cli-cmd x) (string (make-cli :cmd :name x)) (list (apply #'make-cli :cmd x)) (t (make-cli :cmd :name (format nil "~(~A~)" x))))) @@ -78,7 +79,7 @@ (defmethod print-version ((self cli) &optional stream) (println (cli-version self) stream)) -(defmethod print-help ((self cli) &optional stream) +(defmethod print-help ((self cli) &optional (stream t)) (println (format nil "~A v~A --- ~A~%" (cli-name self) (cli-version self) (cli-description self)) stream) (print-usage self stream) ;; (terpri stream) @@ -86,12 +87,12 @@ (with-slots (opts cmds) self (unless (null opts) (loop for o across opts - do (iprintln (print-usage o) 2 stream))) + do (iprintln (print-usage o nil) 2 stream))) (terpri stream) (println "commands:" stream) (unless (null cmds) (loop for c across cmds - do (iprintln (print-usage c) 2 stream))))) + do (iprintln (print-usage c nil) 2 stream))))) (defmethod cli-equal :before ((a cli) (b cli)) "Return T if A is the same cli object as B. diff -r f58f3b88c49e -r f901de70a80e lisp/lib/cli/clap/cmd.lisp --- a/lisp/lib/cli/clap/cmd.lisp Sun Sep 08 21:14:30 2024 -0400 +++ b/lisp/lib/cli/clap/cmd.lisp Tue Sep 10 21:26:30 2024 -0400 @@ -144,29 +144,48 @@ for i below (length args) for (a . args) on args if (member i holes) - do (continue) ;; skip args which have been consumed already - else if (= (length a) 1) - collect (make-cli-node 'arg a) ; always treat single-char as arg - else if (short-opt-p a) ;; SHORT OPT - collect (if-let ((o (find-short-opts self (aref a 1) :recurse t))) - (%compose-short-opt (car o) a) - (make-cli-node 'arg a)) - else if (long-opt-p a) ;; LONG OPT - collect (if-let ((o (find-opts self (string-left-trim "-" a) :recurse t))) - (prog1 (%compose-long-opt (car o) args) - (push (1+ i) holes)) - (make-cli-node 'arg a)) - ;; OPT GROUP - else if (opt-group-p a) - collect nil + do (continue) ;; skip args which have been consumed already + else + if (= (length a) 1) + collect (make-cli-node 'arg a) ; always treat single-char as arg + else + if (short-opt-p a) ;; SHORT OPT + collect + (if-let ((o (find-short-opts self (aref a 1) :recurse t))) + (%compose-short-opt (car o) a) + (make-cli-node 'arg a)) + else + if (long-opt-p a) ;; LONG OPT + collect + (let ((o (find-opts self (string-left-trim "-" a) :recurse t)) + (has-eq (long-opt-has-eq-p a))) + (cond + ((and has-eq o) + (setf (cli-opt-val o) (cdr has-eq)) + (make-cli-node 'opt o)) + ((and (not has-eq) o) + (prog1 (%compose-long-opt (car o) args) + (push (1+ i) holes))) + ((and has-eq (not o)) + (warn 'warning "opt not recognized" a) + (let ((val (cdr has-eq))) + (make-cli-node 'opt (make-cli-opt :name (car has-eq) :kind (type-of val) :val val)))) + (t ;; (not o) (not has-eq) + (warn 'warning "opt not recognized" a) + (make-cli-node 'arg a)))) + ;; OPT GROUP + else + if (opt-group-p a) + collect nil ;; CMD - else - collect (let ((cmd (find-cmd self a))) - (if cmd - ;; TBD - (make-cli-node 'cmd (find-cmd self a)) - ;; ARG - (make-cli-node 'arg a))))))) + else + collect + (let ((cmd (find-cmd self a))) + (if cmd + ;; TBD + (make-cli-node 'cmd (find-cmd self a)) + ;; ARG + (make-cli-node 'arg a))))))) (defmethod install-ast ((self cli-cmd) (ast cli-ast)) "Install the given AST, recursively filling in value slots." diff -r f58f3b88c49e -r f901de70a80e lisp/lib/cli/clap/macs.lisp --- a/lisp/lib/cli/clap/macs.lisp Sun Sep 08 21:14:30 2024 -0400 +++ b/lisp/lib/cli/clap/macs.lisp Tue Sep 10 21:26:30 2024 -0400 @@ -78,5 +78,7 @@ `(defun ,fn-name (&optional arg) "Parse the cli-opt-val *ARG*." (declare (ignorable arg)) - ,@(when fn1 `((setf *arg* (funcall #',fn1 arg)))) + ,@(if fn1 + `((setf *arg* (print (funcall #',fn1 arg)))) + `((setf *arg* arg))) ,@body))))) diff -r f58f3b88c49e -r f901de70a80e lisp/lib/cli/clap/opt.lisp --- a/lisp/lib/cli/clap/opt.lisp Sun Sep 08 21:14:30 2024 -0400 +++ b/lisp/lib/cli/clap/opt.lisp Tue Sep 10 21:26:30 2024 -0400 @@ -35,7 +35,7 @@ (defstruct cli-opt ;; note that cli-opts can have a nil or unbound name slot (name "" :type string) - (kind 'boolean :type symbol) + (kind 'boolean :type (or symbol list)) (thunk nil :type (or null function symbol)) (val nil) (global nil :type boolean) diff -r f58f3b88c49e -r f901de70a80e lisp/lib/cli/clap/pkg.lisp --- a/lisp/lib/cli/clap/pkg.lisp Sun Sep 08 21:14:30 2024 -0400 +++ b/lisp/lib/cli/clap/pkg.lisp Tue Sep 10 21:26:30 2024 -0400 @@ -13,7 +13,8 @@ (:use :cl :std :log :sb-ext :cli/clap/vars) (:export :args :arg0 :long-opt-p :short-opt-p :opt-group-p :opt-string-prefix-eq :cli-opt-kind-p - :default-thunk)) + :default-thunk + :long-opt-has-eq-p)) (defpackage :cli/clap/macs (:use :cl :std :log :sb-ext :cli/clap/util :cli/clap/vars) diff -r f58f3b88c49e -r f901de70a80e lisp/lib/cli/clap/util.lisp --- a/lisp/lib/cli/clap/util.lisp Sun Sep 08 21:14:30 2024 -0400 +++ b/lisp/lib/cli/clap/util.lisp Tue Sep 10 21:26:30 2024 -0400 @@ -8,11 +8,22 @@ (defun arg0 () (car sb-ext:*posix-argv*)) (defun args () (cdr sb-ext:*posix-argv*)) +(declaim (inline long-opt-p long-opt-has-eq-p + short-opt-p opt-group-p + opt-string-prefix-eq)) + (defun long-opt-p (str) (declare (simple-string str)) (and (char= (aref str 0) (aref str 1) #\-) (> (length str) 2))) +(defun long-opt-has-eq-p (str) + "Return non-nil if STR is a long-opt which has an '=' somewhere, +indicating a key/val pair without whitespace." + (declare (simple-string str)) + (when-let ((pos (position #\= str :test 'char=))) + (cons (subseq str 2 pos) (subseq str (1+ pos))))) + (defun short-opt-p (str) (declare (simple-string str)) (and (char= (aref str 0) #\-) diff -r f58f3b88c49e -r f901de70a80e lisp/lib/cli/tests.lisp --- a/lisp/lib/cli/tests.lisp Sun Sep 08 21:14:30 2024 -0400 +++ b/lisp/lib/cli/tests.lisp Tue Sep 10 21:26:30 2024 -0400 @@ -4,7 +4,7 @@ ;;; Code: (defpackage :cli/tests - (:use :cl :std :rt :cli :cli/shell :cli/progress :cli/spark :cli/repl :cli/ansi :cli/prompt :cli/clap :cli/tools/sbcl)) + (:use :cl :std :rt :cli :cli/shell :cli/progress :cli/spark :cli/repl :cli/ansi :cli/prompt :cli/clap :cli/tools/sbcl :dat/sxp)) (in-package :cli/tests) (declaim (optimize (debug 3) (safety 3))) @@ -60,7 +60,7 @@ (princ "X")) (.sgr 0) (force-output) - (sleep 3) + ;; (sleep 3) (.ris) (force-output)) @@ -68,34 +68,36 @@ "Hide and show the cursor." (princ "Cursor visible:") (force-output) - (sleep 2) + ;; (sleep 2) (terpri) (princ "Cursor invisible:") (hide-cursor) (force-output) - (sleep 2) + ;; (sleep 2) (terpri) (princ "Cursor visible:") (show-cursor) (force-output) - (sleep 2)) + ;; (sleep 2) + ) (defun ansi-t05 () "Switch to and back from the alternate screen buffer." (princ "Normal screen buffer. ") (force-output) - (sleep 2) + ;; (sleep 2) (save-cursor-position) (use-alternate-screen-buffer) (clear) (princ "Alternate screen buffer.") (force-output) - (sleep 2) + ;; (sleep 2) (use-normal-screen-buffer) (restore-cursor-position) (princ "Back to Normal screen buffer.") (force-output) - (sleep 1)) + ;; (sleep 1) + ) (defun ansi-t06 () "Set individual termios flags to enable raw and disable echo mode. @@ -205,7 +207,7 @@ ;; fixture API (defprompt tpfoo :prompt "testing:") -(deftest cli-prompt () +(deftest cli-prompt (:skip t) "Test CLI prompts" (defvar tcoll nil) (defvar thist nil) @@ -220,8 +222,8 @@ (:name "bar" :description "foo"))) (defparameter *cmd1* (make-cli :cmd :name "holla" :opts *opts* :description "cmd1 description")) -(defparameter *cmd2* (make-cli :cmd :name "ayo" :cmds #(*cmd1*) :opts *opts* :description "cmd1 description")) -(defparameter *cmds* (make-cmds '(:name "baz" :description "baz" :opts *opts*))) +(defparameter *cmd2* (make-cli :cmd :name "ayo" :cmds (vector *cmd1*) :opts *opts* :description "cmd1 description")) +(defparameter *cmds* (make-cmds `(:name "baz" :description "baz" :opts ,*opts*) *cmd1* *cmd2*)) (defparameter *cli* (make-cli :cli :opts *opts* :cmds *cmds* :description "test cli")) @@ -230,7 +232,7 @@ "test basic CLAP functionality." (let ((cli *cli*)) (is (eq (make-shorty "test") #\t)) - (is (equalp (proc-args cli '("-f" "baz" "--bar" "fax")) ;; not eql + (is (equalp (proc-args cli '("-f" "baz" "--bar=fax")) ;; not eql (make-cli-ast (list (make-cli-node 'opt (find-short-opts cli #\f)) (make-cli-node 'cmd (find-cmd cli "baz")) @@ -242,7 +244,7 @@ (print-version cli s) (print-usage cli s) (print-help cli s)))) - (is (string= "foobar" (cli/clap::parse-string-opt "foobar"))))) + (is (string= "foobar" (cli/clap:parse-string-opt "foobar"))))) (make-opt-parser thing *arg*) @@ -676,10 +678,14 @@ (deftest cli-ast () "Validate the CLI/CLAP/AST parser." - (with-cli () *cli*)) + (with-cli () *cli* + (is (string= (cli-opt-name (cli-node-form (car (ast (proc-args *cli* '("--foo" "1")))))) + "foo")) + (is (string= + (cli-opt-name (cli-node-form (car (ast (proc-args *cli* '("--foo=11")))))) + "foo")))) (defmain (:exit nil :export nil) - (proc-args *cli* '("--foo 1")) (with-cli () *cli* (log:trace! "defmain is OK") t)) diff -r f58f3b88c49e -r f901de70a80e readme.org --- a/readme.org Sun Sep 08 21:14:30 2024 -0400 +++ b/readme.org Tue Sep 10 21:26:30 2024 -0400 @@ -6,9 +6,20 @@ #+property: header-args :eval no-export - [[https://compiler.company/docs/core][Documentation]] -* Overview This repository contains the monolothic core of [[comp:][The Compiler Company]]. +* Overview +The CC core is categorized into language-specific modules. Our +languages at time of writing are Common Lisp, Rust, and Emacs Lisp. + +The top-level modules are contained in the directories =lisp=, =rust=, +and =emacs= respectively. At the root directory you will also find a +=skelfile= and a =sk= file for each module. These files contain +project definitions which are used by our =skel= program to perform a +variety of actions on the core such as running tests and building +binaries. + +* Bootstrap To bootstrap the core you will need recent versions of [[https://www.rust-lang.org/][Rust]], [[http://www.sbcl.org/][SBCL]], and a C compiler (clang or gcc). Only Unix systems are explicitly supported. @@ -176,243 +187,3 @@ The core contains a collection of Emacs Lisp libraries under =emacs= which may be installed for the current user using the corresponding Makefile. - -** TODO Bootstrap from packy :experimental: -The following can (maybe someday) be used to bootstrap the core without a full -lisp compiler. -#+begin_src shell :results output - curl --proto '=https' \ - --tlsv1.3 \ - -sSf \ - https://packy.compiler.company/dist/x86_64-unknown-linux-gnu/bin/sk \ - --output /tmp/sk - chmod +x /tmp/sk - /tmp/sk make skel -#+end_src - -#+RESULTS: -#+begin_example -This is SBCL 2.4.5, an implementation of ANSI Common Lisp. -More information about SBCL is available at . - -SBCL is free software, provided as is, with absolutely no warranty. -It is mostly in the public domain; some portions are provided under -BSD-style licenses. See the CREDITS and COPYING files in the -distribution for more information. -To load "rt": - Load 1 ASDF system: - rt -; Loading "rt" - -saving skel to: /home/ellis/comp/core/.stash/skel -To load "bin/skel": - Load 1 ASDF system: - bin/skel -; Loading "bin/skel" -......... -[undoing binding stack and other enclosing state... done] -[performing final GC... done] -[saving current Lisp image into /home/ellis/comp/core/.stash/skel: -writing 15984 bytes from the static space at 0x50100000 -writing 339476480 bytes from the dynamic space at 0x1000000000 -writing 12498752 bytes from the read-only space at 0x74232dc00000 -writing 0 bytes from the text space at (nil) -done] -#+end_example - -* Programs -This section lists all program binaries provided by the core. -** skel :lisp: -#+begin_src shell :results output :exports both - skel --help -#+end_src - -#+RESULTS: -#+begin_example -skel v0.1.1:ce91ffc6cc7a+ --- A hacker's project compiler. - - usage: skel [global] [] - -options: - -h/--help* : print this message - -v/--version* : print version - -l/--level* : set log level (warn,info,debug,trace) - -c/--config* : set a custom skel user config - -i/--input* : input source - -o/--output* : output target - -commands: - init : initialize a skelfile in the current directory - -n/--name : project name - new : make a new skel project - -n/--name : project name - describe : describe a skelfile - show : show project slots - -f/--file : path to skelfile - -u/--user : print user configuration - -s/--system : print system configuration - vc : version control - -r/--root : repository path - id : print the project id - inspect : inspect the project skelfile - -f/--file : path to skelfile - make : build project targets - -t/--target : target to build - run : run a script or command - compile : compile source code - build : build programs and libraries - dist : distribute build artifacts - install : install stuff - pack : pack stuff - unpack : unpack stuff - bundle : bundle source code - unbundle : unbundle source code - clean : clean up the project - test : run tests - bench : run benchmark - status : print the vc status - push : push the current project upstream - pull : pull the current project from remote - clone : clone a remote project - commit : commit changes to the project vc - edit : edit a project file in emacs. - shell : open the sk-shell interpreter - -#+end_example -** organ :lisp: -#+begin_src shell :results output :exports both -organ --help -#+end_src - -#+RESULTS: -#+begin_example -organ v0.0.1 --- org-mode toolbox - - usage: organ [global] [] - -options: - -l/--level* : set the log level - -h/--help* : print help - -v/--version* : print version - -commands: - inspect : inspect an org file - show : display local org info - describe : describe local org info - parse -#+end_example - -** packy :lisp: -#+begin_src shell :results output :exports both -packy --help -#+end_src - -#+RESULTS: -#+begin_example -packy v0.1.0 --- Universal Package Manager - - usage: packy [global] [] - -options: - -l/--level* : set the log level - -h/--help* : print help - -v/--version* : print version - -commands: - show - -n/--name* - -t/--target - -t/--thunk* - -p/--pk-target* -#+end_example - -** rdb :lisp: -#+begin_src shell :results output :exports both -rdb --help -#+end_src - -#+RESULTS: - -** homer :lisp: -#+begin_src shell :results output :exports both -homer --help -#+end_src - -#+RESULTS: -#+begin_example -homer v0.1.0 --- user home manager - - usage: homer [global] [] - -options: - -l/--level* : set the log level - -h/--help* : print help - -v/--version* : print version - -f/--force* : use force - -commands: - show - check - push - pull - install -#+end_example - -** COMMENT alik :rust: -#+begin_src shell :results output :exports both -alik --help -#+end_src - -#+RESULTS: - -** COMMENT krypt :lisp: -#+begin_src shell :results output :exports both -krypt --help -#+end_src - -#+RESULTS: -#+begin_example -Krypt CLI - -Usage: krypt [OPTIONS] [COMMAND] - -Commands: - check check service providers and config - show Show Krypt info - search Query the Krypt - help Print this message or the help of the given subcommand(s) - -Options: - -c, --cfg Set the default config file [env: KRYPT_CONFIG_FILE=] - -u, --user Set a user for this command [env: USER=ellis] - -l, --level... Set log level - -h, --help Print help - -V, --version Print version -#+end_example - -** mailman :rust: -#+begin_src shell :results output :exports both -mailman --help -#+end_src - -#+RESULTS: -#+begin_example -Mail client util - -Usage: mailman [OPTIONS] [COMMAND] - -Commands: - ping Ping the server - search Search for items - import Import an account - export Export an account - help Print this message or the help of the given subcommand(s) - -Options: - -c, --cfg Set the default config file [env: MAILMAN_CONFIG_FILE=] - -u, --user Set a user for this command [env: USER=ellis] - -l, --level... Set log level - -h, --help Print help - -V, --version Print version -#+end_example -