jerboa: busybox-style multicall binary (jerboa/jmcp/jlsp/jerbuild)
ober
2387ef5333b46803d91c63066a49ba62c9bdab91
--- a/.gitignore +++ b/.gitignore @@ -53,6 +53,11 @@ /jlsp-* /lsp/analysis/completion-tables.ss +# `make jerboa` output: the busybox-style multicall binary + its symlinks +# (dist/jerboa with dist/{jmcp,jlsp,jerbuild} -> jerboa). Regenerated by +# support/build-jerboa-multicall.ss; intermediates land in build/jerboa-multicall/. +/dist/ + # `make native-cross` outputs (per-target Rust dylibs) /lib-cross/ --- a/Makefile +++ b/Makefile @@ -43,6 +43,8 @@ help: @echo " chez-cross Build cross Chez (target libkernel.a + boot files + xpatch)" @echo " Args: CHEZ_TARGET_MACHINE=<mt> CROSS_CC=<cross-cc>" @echo " binary-cross Build a jerboa-bin for a foreign target (same args as chez-cross)" + @echo " jerboa Build the busybox-style multicall binary: dist/jerboa" + @echo " + symlinks dist/{jmcp,jlsp,jerbuild} (one image, all four modes)" @echo " native-cross Cross-build Rust native lib for a target" @echo " Args: CHEZ_TARGET_MACHINE=<mt> CROSS_CC=<cc> [CROSS_NATIVE_FEATURES=tls,...]" @echo " typecheck Typecheck Typed Jerboa sources" @@ -196,6 +198,30 @@ jerbuild-smoke: jerbuild exit 1; \ fi +# ── jerboa multicall binary (busybox-style) ────────────────────────────────── +# One binary; behavior selected by basename(argv[0]). Outputs dist/jerboa plus +# relative symlinks dist/{jmcp,jlsp,jerbuild}. Bundles Chez + the Jerboa stdlib +# so it can transpile/build a full Jerboa project on a bare host. +# +# dist/jerboa <script.ss> # REPL / run a script (also: jerboa <mode>) +# dist/jmcp # MCP server (mcp/server.ss) +# dist/jlsp # LSP server (lsp/main-binary.ss) +# dist/jerbuild <src> <lib> # transpile; dist/jerbuild binary E.ss OUT +.PHONY: jerboa jerboa-smoke +jerboa: chez build mcp-check lsp-gen + $(SCHEME) --script support/build-jerboa-multicall.ss + +# End-to-end smoke test: all four modes from the single binary + its symlinks. +jerboa-smoke: jerboa + @D=$(CURDIR)/dist; fail=0; \ + echo '(import (jerboa prelude)) (displayln (+ 40 2))' > /tmp/jms.ss; \ + [ "$$($$D/jerboa /tmp/jms.ss)" = "42" ] && echo " jerboa script: PASS" || { echo " jerboa script: FAIL" >&2; fail=1; }; \ + $$D/jlsp --version >/dev/null 2>&1 && echo " jlsp: PASS" || { echo " jlsp: FAIL" >&2; fail=1; }; \ + echo '{"jsonrpc":"2.0","id":1,"method":"initialize","params":{}}' | $$D/jmcp 2>/dev/null | grep -q '"jerboa-mcp"' && echo " jmcp: PASS" || { echo " jmcp: FAIL" >&2; fail=1; }; \ + $$D/jerbuild --version | grep -q 'sha256=' && echo " jerbuild: PASS" || { echo " jerbuild: FAIL" >&2; fail=1; }; \ + rm -f /tmp/jms.ss; \ + [ $$fail -eq 0 ] && echo "jerboa-smoke: PASS" || { echo "jerboa-smoke: FAIL" >&2; exit 1; } + # Cross-compiled jerbuild. Drives support/build-jerbuild.sh with TARGET_* env, # producing ./jerbuild-<machine> alongside the host ./jerbuild. # new file mode 100644 --- /dev/null +++ b/support/build-jerboa-multicall.ss @@ -0,0 +1,346 @@ +#!chezscheme +;;; build-jerboa-multicall.ss — Build the single multicall `jerboa` binary. +;;; +;;; One binary, busybox-style: behavior selected by basename(argv[0]). +;;; jerboa REPL / run a script (also `jerboa <mode> ...`) +;;; jmcp MCP server (mcp/server.ss) +;;; jlsp LSP server (lsp/main-binary.ss) +;;; jerbuild transpiler/builder (jerbuild.ss) + bundled stdlib +;;; +;;; Additive: the three entry sources are NOT edited. We read their top-level +;;; forms and rewrap each as a (jerboa entry mcp|lsp|jerbuild) library exporting +;;; a *-main procedure, generate a dispatcher program importing all three, then +;;; WPO-compile one shared image and link support/multicall-main.c around it. +;;; +;;; Usage: scheme --script support/build-jerboa-multicall.ss +;;; Output: dist/jerboa + relative symlinks dist/{jmcp,jlsp,jerbuild} + +(import (chezscheme)) + +;;;; ---------- small helpers ---------- +(define (env name default) + (let ([v (getenv name)]) (if (and v (> (string-length v) 0)) v default))) + +(define (string-suffix? s suffix) + (let ([sl (string-length s)] [xl (string-length suffix)]) + (and (>= sl xl) (string=? suffix (substring s (- sl xl) sl))))) + +(define (string-prefix? prefix s) + (let ([pl (string-length prefix)] [sl (string-length s)]) + (and (>= sl pl) (string=? prefix (substring s 0 pl))))) + +(define (trim-ws s) + (let* ([n (string-length s)] + [start (let lp ([i 0]) (if (and (< i n) (char-whitespace? (string-ref s i))) (lp (+ i 1)) i))] + [end (let lp ([i n]) (if (and (> i start) (char-whitespace? (string-ref s (- i 1)))) (lp (- i 1)) i))]) + (substring s start end))) + +(define (shell-quote s) + (call-with-string-output-port + (lambda (out) + (display "'" out) + (let lp ([i 0]) + (when (< i (string-length s)) + (let ([c (string-ref s i)]) + (if (char=? c #\') (display "'\"'\"'" out) (display c out))) + (lp (+ i 1)))) + (display "'" out)))) + +(define (run cmd) + (printf " ~a~n" cmd) + (let ([rc (system cmd)]) + (unless (zero? rc) (error 'build-multicall "command failed" rc cmd)))) + +(define (directory-list* p) (guard (e [else '()]) (if (file-directory? p) (directory-list p) '()))) +(define (require-file p) (unless (file-exists? p) (error 'build-multicall "missing file" p))) + +(define (read-text-file path) + (call-with-input-file path + (lambda (in) + (let lp ([acc '()]) + (let ([c (get-string-n in 4096)]) + (if (eof-object? c) (apply string-append (reverse acc)) (lp (cons c acc)))))))) + +(define (find-csv-dir lib-dir machine) + (let lp ([entries (directory-list* lib-dir)]) + (cond + [(null? entries) #f] + [else + (let* ([e (car entries)] [d (format "~a/~a/~a" lib-dir e machine)]) + (if (and (string-prefix? "csv" e) + (file-exists? (format "~a/libkernel.a" d)) + (file-exists? (format "~a/scheme.h" d)) + (file-exists? (format "~a/petite.boot" d)) + (file-exists? (format "~a/scheme.boot" d))) + d (lp (cdr entries))))]))) + +(define (file->c-header input-path output-path array-name size-name) + (let* ([port (open-file-input-port input-path)] + [data (get-bytevector-all port)] + [size (bytevector-length data)]) + (close-port port) + (call-with-output-file output-path + (lambda (out) + (fprintf out "/* Generated by support/build-jerboa-multicall.ss */~n") + (fprintf out "static const unsigned char ~a[] = {~n" array-name) + (let lp ([i 0]) + (when (< i size) + (when (= 0 (modulo i 16)) (fprintf out " ")) + (fprintf out "0x~2,'0x" (bytevector-u8-ref data i)) + (when (< (+ i 1) size) (fprintf out ",")) + (when (= 15 (modulo i 16)) (fprintf out "~n")) + (lp (+ i 1)))) + (fprintf out "~n};~n") + (fprintf out "static const unsigned int ~a = ~a;~n" size-name size)) + 'replace) + (printf " embed ~a (~a bytes)~n" output-path size))) + +;;;; ---------- source-form surgery ---------- +;; Read all top-level datums, dropping a leading #!/… shebang line. +;; #!chezscheme / #!r6rs reader directives are consumed by `read`. +(define (read-source-forms path) + (let* ([text (read-text-file path)] + [text (if (string-prefix? "#!/" text) + (let ([nl (let f ([i 0]) + (cond [(>= i (string-length text)) i] + [(char=? (string-ref text i) #\newline) i] + [else (f (+ i 1))]))]) + (substring text nl (string-length text))) + text)]) + (with-input-from-string text + (lambda () + (let lp ([acc '()]) + (let ([f (read)]) + (if (eof-object? f) (reverse acc) (lp (cons f acc))))))))) + +;; Split leading consecutive (import ...) forms; return (values import-sets rest). +(define (split-imports forms) + (let lp ([fs forms] [imps '()]) + (if (and (pair? fs) (pair? (car fs)) (eq? (caar fs) 'import)) + (lp (cdr fs) (append imps (cdr (car fs)))) + (values imps fs)))) + +(define (drop-last xs) (reverse (cdr (reverse xs)))) +(define (last-form xs) (car (last-pair xs))) + +;; trailing form is (let ([args EXPR]) BODY...) — return BODY... (the run body) +(define (let-args-body trailing who) + (unless (and (pair? trailing) (eq? (car trailing) 'let) + (pair? (cadr trailing)) (pair? (car (cadr trailing))) + (eq? (caar (cadr trailing)) 'args)) + (error 'build-multicall "unexpected trailing form (want (let ([args ..]) ..))" who trailing)) + (cddr trailing)) + +(define (lib-form name export-name import-sets body main-def) + `(library (jerboa entry ,name) + (export ,export-name) + (import ,@import-sets) + ,@body + ,main-def)) + +(define (write-library form path) + (run (format "mkdir -p ~a" (shell-quote (let ([s (path-parent path)]) s)))) + (call-with-output-file path + (lambda (out) (display "#!chezscheme\n" out) (write form out) (newline out)) + 'replace)) + +(define (transform-jerbuild repo) + (let-values ([(imps rest) (split-imports (read-source-forms (format "~a/jerbuild.ss" repo)))]) + (lib-form 'jerbuild 'jerbuild-main imps (drop-last rest) + `(define (jerbuild-main args) ,@(let-args-body (last-form rest) "jerbuild.ss"))))) + +(define (transform-lsp repo) + (let-values ([(imps rest) (split-imports (read-source-forms (format "~a/lsp/main-binary.ss" repo)))]) + (lib-form 'lsp 'lsp-main imps (drop-last rest) + `(define (lsp-main args) ,@(let-args-body (last-form rest) "lsp/main-binary.ss"))))) + +(define (embedded-data-placeholder? f) + (and (pair? f) (eq? (car f) 'def) (pair? (cdr f)) (eq? (cadr f) '*embedded-data*))) + +(define (embedded-data-entries repo) + (let* ([dir (format "~a/data" repo)] + [files (list-sort string<? (filter (lambda (n) (string-suffix? n ".sexp")) + (directory-list* dir)))]) + (map (lambda (n) (cons n (read-text-file (format "~a/~a" dir n)))) files))) + +;; mcp/server.ss's in-file import is a placeholder `(except (rnrs) partition)` +;; that the standalone jmcp build (mcp/build-jmcp.sh) overrides; getenv et al. +;; come from chezscheme, not rnrs. Mirror that override here. +(define mcp-import-sets + '((except (chezscheme) + 1+ 1- atom? define-values format fprintf hash-table? + iota last-pair make-date make-hash-table make-time meta + partition path-absolute? path-extension printf sort sort! + with-input-from-string with-output-to-string) + (jerboa prelude) + (jerboa reader) + (std text json) + (std misc ports) + (std misc process) + (std os path) + (std misc string))) + +(define (transform-mcp repo) + (let-values ([(imps rest) (split-imports (read-source-forms (format "~a/mcp/server.ss" repo)))]) + (let ([trailing (last-form rest)] + [entries (embedded-data-entries repo)]) + (unless (equal? trailing '(serve)) + (error 'build-multicall "mcp/server.ss must end in (serve)" trailing)) + (lib-form 'mcp 'mcp-main mcp-import-sets + (map (lambda (f) (if (embedded-data-placeholder? f) + `(def *embedded-data* ',entries) f)) + (drop-last rest)) + '(def (mcp-main) (serve)))))) + +;;;; ---------- unified dispatcher program ---------- +(define (write-unified-entry path) + (call-with-output-file path + (lambda (out) + (display "#!chezscheme\n" out) + (write '(import (except (chezscheme) + make-hash-table hash-table? sort sort! printf fprintf + path-extension path-absolute? with-input-from-string + with-output-to-string iota 1+ 1- partition make-date + make-time meta atom?) + (jerboa prelude) + (jerboa entry mcp) + (jerboa entry lsp) + (jerboa entry jerbuild)) + out) + (newline out) + (write '(let ([mode (or (getenv "JERBOA_MULTICALL_NAME") "jerboa")] + [args (command-line-arguments)]) + (cond + [(string=? mode "jmcp") (mcp-main)] + [(string=? mode "jlsp") (lsp-main args)] + [(string=? mode "jerbuild") (jerbuild-main args)] + [(null? args) + (displayln "Jerboa Scheme — type (exit) to quit") + (let loop () + (display "jerboa> ") + (flush-output-port (current-output-port)) + (let ([form (read)]) + (cond + [(eof-object? form) (newline)] + [else + (guard (exn [#t (display "Error: ") (display-condition exn) (newline)]) + (let ([result (eval form (interaction-environment))]) + (unless (eq? result (void)) (write result) (newline)))) + (loop)])))] + [(or (string=? (car args) "--version") (string=? (car args) "-v")) + (displayln "jerboa 0.1.0 (multicall: jerboa/jmcp/jlsp/jerbuild)")] + [(or (string=? (car args) "--help") (string=? (car args) "-h")) + (for-each displayln + (list "Usage: jerboa [<script.ss> | <mode> ...] [--version]" + " (no args) start the Jerboa REPL" + " <script.ss> load and run a Scheme script" + " jmcp|mcp ... run the MCP server" + " jlsp|lsp ... run the LSP server" + " jerbuild ... transpile/build a Jerboa project" + "" + "Symlink to jmcp/jlsp/jerbuild to pick a mode by name."))] + [else (load (car args))])) + out) + (newline out)) + 'replace)) + +;;;; ---------- main build ---------- +(define repo (env "JERBOA_HOME" + (let* ([script (car (command-line))] + [abs (if (path-absolute? script) + script + (format "~a/~a" (current-directory) script))]) + (path-parent (path-parent abs))))) +(define machine (symbol->string (machine-type))) +(define csv-dir (or (getenv "CHEZ_DIR") + (find-csv-dir (format "~a/.chez/lib" repo) machine))) +(unless csv-dir (error 'build-multicall "no Chez csv dir for" machine (format "~a/.chez/lib" repo))) + +(define out-dir (env "OUTPUT_DIR" (format "~a/dist" repo))) +(define output (format "~a/jerboa" out-dir)) +(define build-dir (format "~a/build/jerboa-multicall" repo)) +(define gen-dir (format "~a/gen" build-dir)) +(define obj-dir (format "~a/obj" build-dir)) +(define program-wp-so (format "~a/program.wp.so" build-dir)) + +(printf "=== jerboa multicall build ===~n") +(printf " repo: ~a~n" repo) +(printf " machine: ~a~n" machine) +(printf " chez: ~a~n" csv-dir) +(printf " output: ~a~n" output) +(for-each require-file + (list (format "~a/jerbuild.ss" repo) + (format "~a/lsp/main-binary.ss" repo) + (format "~a/mcp/server.ss" repo) + (format "~a/support/multicall-main.c" repo) + (format "~a/libkernel.a" csv-dir))) + +(run (format "rm -rf ~a && mkdir -p ~a ~a ~a" (shell-quote build-dir) + (shell-quote gen-dir) (shell-quote obj-dir) (shell-quote out-dir))) + +(printf "==> [1/6] generate entry libraries + dispatcher~n") +(write-library (transform-jerbuild repo) (format "~a/jerboa/entry/jerbuild.sls" gen-dir)) +(write-library (transform-lsp repo) (format "~a/jerboa/entry/lsp.sls" gen-dir)) +(write-library (transform-mcp repo) (format "~a/jerboa/entry/mcp.sls" gen-dir)) +(define entry-ss (format "~a/jerboa-multicall-entry.ss" gen-dir)) +(write-unified-entry entry-ss) + +(printf "==> [2/6] WPO compile shared image~n") +(library-directories (list (cons gen-dir obj-dir) + (cons (format "~a/lib" repo) obj-dir) + (cons repo obj-dir))) +(compile-imported-libraries #t) +(generate-wpo-files #t) +(compile-program entry-ss (format "~a/program.so" obj-dir)) +(compile-whole-program (format "~a/program.wpo" obj-dir) program-wp-so #t) + +(printf "==> [3/6] tarball stdlib + obj + kernel for jerbuild bundle~n") +(define bundle-tar (format "~a/bundle.tar" build-dir)) +(define stage (format "~a/stage" build-dir)) +(run (format "cd ~a && find lib/jerboa lib/std \\( -name '*.ss' -o -name '*.sls' \\) -type f | sort | tar -cf ~a -T -" + (shell-quote repo) (shell-quote bundle-tar))) +(run (format "rm -rf ~a && mkdir -p ~a/lib" (shell-quote stage) (shell-quote stage))) +(run (format "cd ~a && find . \\( -name '*.so' -o -name '*.wpo' \\) -type f ! -name 'program.so' ! -name 'program.wpo' ! -name 'program.wp.so' | tar -cf - -T - | (cd ~a/lib && tar -xf -)" + (shell-quote obj-dir) (shell-quote stage))) +(run (format "cd ~a && tar -rf ~a lib" (shell-quote stage) (shell-quote bundle-tar))) +(run (format "mkdir -p ~a/csv/~a" (shell-quote stage) machine)) +(for-each (lambda (f) + (when (file-exists? (format "~a/~a" csv-dir f)) + (run (format "cp ~a/~a ~a/csv/~a/" (shell-quote csv-dir) f (shell-quote stage) machine)))) + '("libkernel.a" "scheme.h" "petite.boot" "scheme.boot" "liblz4.a" "libz.a")) +(run (format "cd ~a && tar -rf ~a csv" (shell-quote stage) (shell-quote bundle-tar))) + +(define sha-file (format "~a/bundle.sha256" build-dir)) +(run (format "(shasum -a 256 ~a 2>/dev/null || sha256sum ~a) | awk '{print $1}' > ~a" + (shell-quote bundle-tar) (shell-quote bundle-tar) (shell-quote sha-file))) +(define bundle-sha (trim-ws (read-text-file sha-file))) + +(printf "==> [4/6] embed boot files + program + bundle as C arrays~n") +(file->c-header (format "~a/petite.boot" csv-dir) (format "~a/petite_boot.h" build-dir) "petite_boot_data" "petite_boot_size") +(file->c-header (format "~a/scheme.boot" csv-dir) (format "~a/scheme_boot.h" build-dir) "scheme_boot_data" "scheme_boot_size") +(file->c-header program-wp-so (format "~a/program_boot.h" build-dir) "program_boot_data" "program_boot_size") +(file->c-header bundle-tar (format "~a/bundle_tar.h" build-dir) "bundle_tar_data" "bundle_tar_size") +(call-with-output-file (format "~a/bundle_meta.h" build-dir) + (lambda (o) (fprintf o "static const char bundle_sha256[] = \"~a\";~n" bundle-sha)) 'replace) + +(printf "==> [5/6] compile + link -> ~a~n" output) +(define os-libs + (cond [(string-suffix? machine "osx") "-lm -lpthread -lncurses -liconv"] + [(string-suffix? machine "fb") "-lm -lpthread -lncurses -L/usr/local/lib -liconv"] + [else "-lm -ldl -lpthread -lncurses"])) +(define extra-archives + (apply string-append + (map (lambda (a) (if (file-exists? (format "~a/~a" csv-dir a)) (format " ~a/~a" csv-dir a) "")) + '("liblz4.a" "libz.a")))) +(define cc (env "CC" "cc")) +(run (format "~a -I~a -I~a -O2 -o ~a ~a/support/multicall-main.c ~a/libkernel.a~a ~a" + cc (shell-quote build-dir) (shell-quote csv-dir) (shell-quote output) + (shell-quote repo) (shell-quote csv-dir) extra-archives os-libs)) + +(printf "==> [6/6] symlinks~n") +(for-each (lambda (nm) (run (format "ln -sf jerboa ~a/~a" (shell-quote out-dir) nm))) + '("jmcp" "jlsp" "jerbuild")) + +(printf "~n=== done ===~n") +(run (format "ls -lh ~a ~a/jmcp ~a/jlsp ~a/jerbuild" (shell-quote output) out-dir out-dir out-dir)) +(run (format "file ~a" (shell-quote output))) new file mode 100644 --- /dev/null +++ b/support/multicall-main.c @@ -0,0 +1,209 @@ +/* support/multicall-main.c — Jerboa multicall (busybox-style) binary. + * + * One binary; behavior is selected by basename(argv[0]): + * jerboa -> REPL / run a script (also: `jerboa <mode> ...`) + * jmcp -> MCP server (mcp/server.ss) + * jlsp -> LSP server (lsp/main-binary.ss) + * jerbuild -> .ss -> .sls transpiler / project builder (jerbuild.ss) + * + * The mode is passed to the embedded Scheme program via the + * JERBOA_MULTICALL_NAME environment variable, because Chez's Sscheme_program + * overwrites command-line[0] with the program path (so argv[0] is otherwise + * lost to Scheme). + * + * The generated headers below (boot files, the WPO program image, and the + * jerbuild lib bundle) are produced by support/build-jerboa-multicall.ss. + */ +#define _GNU_SOURCE +#include "scheme.h" +#include <errno.h> +#include <fcntl.h> +#include <pwd.h> +#include <signal.h> +#include <stdio.h> +#include <stdlib.h> +#include <string.h> +#include <sys/stat.h> +#include <sys/types.h> +#include <unistd.h> + +#include "petite_boot.h" +#include "scheme_boot.h" +#include "program_boot.h" +#include "bundle_tar.h" +#include "bundle_meta.h" + +/* ── jerbuild lib bundle: extracted to a per-sha cache dir on demand ─────── + * Layout: $XDG_CACHE_HOME/jerbuild/<sha256>/ (or ~/.cache/jerbuild/<sha256>/) + * holding the Jerboa stdlib + Chez kernel files the `jerbuild binary`/`build` + * subcommands need. Keyed by sha256 so a new binary lives in its own dir. */ + +static int mkdir_p(const char *path) { + char tmp[1024]; + size_t n = strlen(path); + if (n + 1 > sizeof(tmp)) { errno = ENAMETOOLONG; return -1; } + memcpy(tmp, path, n + 1); + for (size_t i = 1; i < n; i++) { + if (tmp[i] == '/') { + tmp[i] = '\0'; + if (mkdir(tmp, 0755) != 0 && errno != EEXIST) return -1; + tmp[i] = '/'; + } + } + if (mkdir(tmp, 0755) != 0 && errno != EEXIST) return -1; + return 0; +} + +static const char *cache_root(char *buf, size_t n) { + const char *xdg = getenv("XDG_CACHE_HOME"); + if (xdg && *xdg) { + snprintf(buf, n, "%s/jerbuild", xdg); + return buf; + } + const char *home = getenv("HOME"); + if (!home || !*home) { + struct passwd *pw = getpwuid(getuid()); + home = pw ? pw->pw_dir : "/tmp"; + } + snprintf(buf, n, "%s/.cache/jerbuild", home); + return buf; +} + +static const char *ensure_extracted(void) { + static char root[1024]; + static char target[1024]; + static char marker[1100]; + static char bundle[1100]; + static int ready = 0; + if (ready) return target; + + cache_root(root, sizeof(root)); + snprintf(target, sizeof(target), "%s/%s", root, bundle_sha256); + snprintf(marker, sizeof(marker), "%s/.complete", target); + + struct stat st; + if (stat(marker, &st) == 0) { ready = 1; return target; } + + if (mkdir_p(target) != 0) { + fprintf(stderr, "jerboa: mkdir -p %s: %s\n", target, strerror(errno)); + exit(1); + } + + snprintf(bundle, sizeof(bundle), "%s/bundle.tar", target); + int fd = open(bundle, O_WRONLY | O_CREAT | O_TRUNC, 0644); + if (fd < 0) { + fprintf(stderr, "jerboa: open %s: %s\n", bundle, strerror(errno)); + exit(1); + } + ssize_t w = write(fd, bundle_tar_data, bundle_tar_size); + close(fd); + if (w != (ssize_t)bundle_tar_size) { + fprintf(stderr, "jerboa: short write to %s\n", bundle); + exit(1); + } + + char cmd[2400]; + snprintf(cmd, sizeof(cmd), "cd '%s' && tar -xf '%s'", target, bundle); + int rc = system(cmd); + if (rc != 0) { + fprintf(stderr, "jerboa: tar -xf %s failed (rc=%d)\n", bundle, rc); + exit(1); + } + unlink(bundle); + + fd = open(marker, O_WRONLY | O_CREAT | O_TRUNC, 0644); + if (fd < 0) { + fprintf(stderr, "jerboa: cannot touch %s: %s\n", marker, strerror(errno)); + exit(1); + } + close(fd); + + ready = 1; + return target; +} + +static const char *write_program_tmpfile(void) { + static char path[] = "/tmp/jerboa-prog-XXXXXX"; + int fd = mkstemp(path); + if (fd < 0) { perror("mkstemp"); exit(1); } + ssize_t n = write(fd, program_boot_data, program_boot_size); + if (n != (ssize_t)program_boot_size) { + perror("write"); close(fd); unlink(path); exit(1); + } + close(fd); + return path; +} + +/* MCP mode resolves these via foreign-procedure; registering them is harmless + * for the other modes. */ +static void register_symbols(void) { + Sforeign_symbol("kill", (void *)kill); + Sforeign_symbol("isatty", (void *)isatty); +} + +static const char *basename_of(const char *p) { + if (!p) return "jerboa"; + const char *s = strrchr(p, '/'); + return s ? s + 1 : p; +} + +static const char JERBUILD_USAGE[] = + "Usage:\n" + " jerbuild <src> <lib> # transpile .ss -> .sls\n" + " jerbuild transpile <src> <lib> [--force]\n" + " jerbuild compile --libdirs <p> [--wpo] FILE...\n" + " jerbuild exec --libdirs <p> FILE [args...] # load+run a Scheme script\n" + " jerbuild binary [--libdirs <p>] [--cc CC] <entry.ss> <output>\n" + " jerbuild build [--cc CC] [--config PATH] # read .jerbuild, build\n" + " jerbuild --jerboa-home # extract+print stdlib path\n" + " jerbuild --version\n"; + +int main(int argc, const char *argv[]) { + const char *name = basename_of(argc > 0 ? argv[0] : "jerboa"); + const char *mode = name; + int shift = 0; + + /* `jerboa <mode> ...` selects a mode without needing a symlink. */ + if (strcmp(name, "jerboa") == 0 && argc > 1) { + const char *s = argv[1]; + if (!strcmp(s, "jmcp") || !strcmp(s, "mcp")) { mode = "jmcp"; shift = 1; } + else if (!strcmp(s, "jlsp") || !strcmp(s, "lsp")) { mode = "jlsp"; shift = 1; } + else if (!strcmp(s, "jerbuild")) { mode = "jerbuild"; shift = 1; } + } + /* Normalize aliased symlink names. */ + if (!strcmp(mode, "mcp")) mode = "jmcp"; + if (!strcmp(mode, "lsp")) mode = "jlsp"; + + /* jerbuild mode: C-side fast paths that avoid booting Chez, plus bundle + * pre-extraction for the subcommands that link binaries. a1 is the first + * real jerbuild argument (the token after the mode selector). */ + if (!strcmp(mode, "jerbuild")) { + const char *a1 = (shift + 1 < argc) ? argv[shift + 1] : NULL; + if (a1 && !strcmp(a1, "--jerboa-home")) { printf("%s\n", ensure_extracted()); return 0; } + if (a1 && !strcmp(a1, "--bundle-sha256")) { printf("%s\n", bundle_sha256); return 0; } + if (a1 && !strcmp(a1, "--version")) { + printf("jerbuild (jerboa multicall, bundled-lib sha256=%s)\n", bundle_sha256); + return 0; + } + if (a1 && (!strcmp(a1, "-h") || !strcmp(a1, "--help"))) { + fputs(JERBUILD_USAGE, stdout); + return 0; + } + if (a1 && (!strcmp(a1, "binary") || !strcmp(a1, "build"))) + setenv("JERBUILD_BUNDLE_DIR", ensure_extracted(), 1); + } + + setenv("JERBOA_MULTICALL_NAME", mode, 1); + + Sscheme_init(NULL); + Sregister_boot_file_bytes("petite", (void *)petite_boot_data, petite_boot_size); + Sregister_boot_file_bytes("scheme", (void *)scheme_boot_data, scheme_boot_size); + Sbuild_heap(NULL, register_symbols); + + const char *prog = write_program_tmpfile(); + int status = Sscheme_program(prog, argc - shift, argv + shift); + unlink(prog); + + Sscheme_deinit(); + return status; +}