jerboa-on-jerboa: pilot three .sls -> .ss migrations + tooling
ober
849a80879cbb2837c318a0130d1c845e59992de7
new file mode 100644 --- /dev/null +++ b/docs/jerboa-on-jerboa-idiom.md @@ -0,0 +1,299 @@ +# Jerboa-on-Jerboa Idiom Guide + +When migrating a `.sls` library to `.ss`, you are converting *editing surface*, +not behavior. The goal is: when someone opens the file, they see Jerboa — +`def`, `defstruct`, `match`, `try/catch` — rather than R6RS `define`, +`define-record-type`, `guard`. + +This guide is the cookbook. Companion plan: [`jerboa-on-jerboa.md`](jerboa-on-jerboa.md). + +--- + +## What changes between `.sls` and `.ss` + +### The library shell stays identical + +Both file types are loaded by Chez at library-resolution time using +`(library (path ...) (export ...) (import ...) body ...)`. The shell does not +change. Only the body does. + +```scheme +;; Same in both .sls and .ss +(library (std foo) + (export bar baz) + (import (chezscheme)) + ...body...) +``` + +### Standard library `.ss` import preamble + +The canonical preamble for a library `.ss` file: + +```scheme +(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) + (except (jerboa prelude) meta atom?)) +``` + +The `(chezscheme)` exclusions are names that `(jerboa prelude)` re-exports +with stronger semantics (e.g. `make-hash-table` returns a Gerbil-style +hash table, `printf` honors Jerboa formatting). + +The `(jerboa prelude)` exclusions (`meta`, `atom?`) are names that conflict +with low-level Chez forms; if you don't need them, exclude them to keep +imports clean. + +### Low-level / bootstrap modules + +For libraries used by `(jerboa prelude)` itself, or anywhere a full prelude +import creates a cycle, use the minimal import: + +```scheme +(import (chezscheme) + (only (jerboa core) def try catch finally)) +``` + +`(jerboa core)` is small and dependency-free, so importing only what you need +from it is safe everywhere. Use this for assert-level libraries, or anything +loaded during reader/prelude bootstrap. + +--- + +## Form-by-form translation + +### `define` → `def` + +```scheme +;; was: +(define (greet name) + (string-append "hello, " name)) + +;; now: +(def (greet name) + (string-append "hello, " name)) +``` + +`def` is `define` plus argument-defaulting and keyword args. For plain +positional functions the two are interchangeable — use `def` for consistency. + +### `define-record-type` → `defstruct` + +```scheme +;; was: +(define-record-type lock-entry + (fields name version hash deps)) + +;; now: +(defstruct lock-entry (name version hash deps)) +``` + +Generated names match the R6RS conventions: `make-lock-entry`, `lock-entry?`, +`lock-entry-name`, `lock-entry-name-set!`. The Jerboa form supports defaults: + +```scheme +(defstruct Config + (host "localhost") + (port 8080) + (timeout #f)) +``` + +### `guard` → `try/catch` + +```scheme +;; was: +(guard (e [#t (handle e)]) + (risky-op)) + +;; now: +(try (risky-op) + (catch (e) (handle e))) +``` + +`try` also takes an optional `(finally ...)` clause: + +```scheme +(try (open-and-use port) + (catch (e) (log-error e)) + (finally (close-port port))) +``` + +#### Gotcha: don't raise from inside `try` if `catch` would swallow it + +This pattern looks innocent but is wrong: + +```scheme +;; BUG: the catch catches our own error. +(def (assert-exception thunk) + (try + (begin (thunk) + (error 'assert "expected an exception but none was raised")) + (catch (e) e))) +``` + +If `thunk` returns cleanly, we call `error`. But that `error` raises *inside* +the `try`, so `catch` snags it and returns it as a normal value. The assertion +silently passes when it should fail. + +Use a sentinel-tag to escape the `try`: + +```scheme +(def (assert-exception thunk) + (let ([result (try + (begin (thunk) '(no-exception)) + (catch (e) (cons 'caught e)))]) + (if (and (pair? result) (eq? (car result) 'caught)) + (cdr result) + (error 'assert "expected an exception but none was raised")))) +``` + +Same constraint applied to the original `guard`-based version. The rule: +post-thunk validation that needs to *raise* belongs outside the `try`, not +inside the success branch. + +### `let loop` + `guard` chains → `some` + +When R6RS code recursively tries options with `guard` until one succeeds: + +```scheme +;; was: +(define c-errno-location + (let try ((names '("__error" "__errno_location" "__errno"))) + (cond + ((null? names) #f) + (else + (or (guard (e [#t #f]) + (foreign-procedure (car names) () void*)) + (try (cdr names))))))) +``` + +The Jerboa-idiom version uses `some` from the prelude: + +```scheme +(def c-errno-location + (some (lambda (name) + (try (foreign-procedure name () void*) + (catch (e) #f))) + '("__error" "__errno_location" "__errno"))) +``` + +`some` returns the first non-`#f` result of `(pred x)` over the list, or `#f` +if none yield truthy. + +### Long `cond` chains over equality → `match` (where it improves readability) + +```scheme +;; was: +(define (errno-name n) + (cond + ((= n EPERM) 'EPERM) + ((= n ENOENT) 'ENOENT) + ...)) +``` + +`match` doesn't help here (numeric equality with variable bindings), so +leave it as `cond`. Use `match` for *shape* destructuring: + +```scheme +(def (parse-entry form) + (match form + [(list 'entry name version hash deps) + (make-lock-entry name version hash deps)] + [_ (error 'parse "invalid entry" form)])) +``` + +Note `(list 'entry ...)` — quote the literal head, bind the rest. + +--- + +## What still works as-is + +These do not need translation; they work identically in `.ss` files: + +- **`define-syntax` / `syntax-rules`** — Chez's R6RS macro system. No change. +- **`foreign-procedure`, `foreign-ref`, `foreign-set!`** — from `(chezscheme)`. +- **`load-shared-object`, `machine-type`** — from `(chezscheme)`. +- **`error`, `condition-message`, `cons`, `car`, `cdr`, etc.** — R6RS bindings. +- **`(library ...)` / `(export ...)` / `(import ...)`** — the library shell. + +--- + +## What does NOT work the same in library `.ss` files + +Reader extras (`[...]`, `{...}`, `#{...}`, `:pkg/mod`, `name:`) only apply +when files are read through the Jerboa reader (`bin/jerboa`, the test +harnesses). Library files are loaded directly by Chez at import time, so: + +- `[...]` works as bracket-paren equivalence (Chez native), but not as + `(list ...)`. Write `(list a b c)` or `'(a b c)` instead. +- `{...}` is parsed as method dispatch — avoid in library code. +- `#{...}` set literal — avoid in library code. +- `:pkg/mod` shorthand — avoid; use `(import (pkg mod))` directly. +- `name:` keyword — works in `def`-form argument lists because `def` is a + macro and sees the syntax post-read, but the reader does not produce + `Keyword` records here. Stick to positional args in library code. + +When in doubt: if you want the reader extras, write a script (`bin/jerboa +script.ss`), not a library. + +--- + +## The veneer pattern (for FFI-heavy modules) + +For modules where the inner workings are unavoidably C interop (`foreign-procedure`, +struct-layout calculations, manual pointer arithmetic), split the file: + +- **Private:** `lib/std/foo/_chez.sls` — raw R6RS, all the FFI plumbing. +- **Public:** `lib/std/foo.ss` — Jerboa surface, imports `_chez` and re-exports. + +This keeps the editing surface a developer touches in Jerboa idiom, even +when the implementation must speak C/R6RS. Tiny re-export files are fine — +the goal is the editing surface, not implementation purity. + +If the FFI surface is small (a few `foreign-procedure` declarations like +`std/os/errno`), skip the split — just put the `.ss` body in Jerboa idiom +with the FFI calls inline. The veneer is for the cases where you'd otherwise +have hundreds of lines of R6RS in a single file. + +--- + +## Verification + +Before committing a migration: + +1. `mcp__jerboa__jerboa_compile_check` on the new `.ss` file — must pass. +2. `tools/audit-r6rs-in-ss.sh` — must return 0 (no banned forms in `lib/`). +3. Delete the corresponding `.sls` file. Chez resolves `.ss` before `.sls` + at default settings, but leaving both creates ambiguity. +4. Clear any stale `.so` / `.wpo`: `find lib -name '<name>.so' -delete`. +5. `make binary && make test` — the canonical sanity check. + +--- + +## Bootstrap floor (stays `.sls`) + +These libraries *cannot* be Jerboa-on-Jerboa because they implement Jerboa: + +- `lib/jerboa/reader.sls` (~893 LOC) — the reader itself. +- `lib/jerboa/core.sls` (~1248 LOC) — `def`, `try`, `match`, `defstruct`. +- `lib/jerboa/translator.sls` (~811 LOC) — module-path translation. +- Plus a handful of helpers needed during reader/core bootstrap. + +Total floor: ~3,000 LOC. Everything else is in scope to migrate. + +--- + +## Discovered patterns (running list) + +Add to this section as conversions surface new patterns worth standardizing. + +- **2026-05-13**: Three-pilot baseline established (`lib/jerboa/lock.ss`, + `lib/std/os/errno.ss`, `lib/std/assert.ss`). Patterns documented above: + `define-record-type` → `defstruct`, `guard` → `try/catch`, `let loop` + + guard chain → `some`, minimal-deps via `(only (jerboa core) ...)`. deleted file mode 100644 --- a/lib/jerboa/lock.sls +++ /dev/null @@ -1,138 +0,0 @@ -#!chezscheme -;;; (jerboa lock) — Lockfile Management -;;; -;;; S-expression lockfile for exact package pinning. - -(library (jerboa lock) - (export - ;; Lockfile - make-lockfile lockfile? lockfile-entries - lockfile-add! lockfile-remove! lockfile-lookup lockfile-has? - - ;; Lock entry - make-lock-entry lock-entry? lock-entry-name lock-entry-version - lock-entry-hash lock-entry-deps - - ;; Serialization - lockfile->sexp sexp->lockfile lockfile-write lockfile-read - - ;; Operations - lockfile-merge lockfile-diff) - - (import (chezscheme)) - - ;; ========== Lock Entry ========== - - (define-record-type (%lock-entry make-lock-entry lock-entry?) - (fields (immutable name lock-entry-name) ;; string - (immutable version lock-entry-version) ;; string "1.2.3" - (immutable hash lock-entry-hash) ;; string SHA-256 hex - (immutable deps lock-entry-deps))) ;; list of strings (names) - - ;; ========== Lockfile ========== - - (define-record-type (%lockfile make-lockfile lockfile?) - (fields (mutable entries lockfile-entries lockfile-entries-set!))) ;; list of lock-entry - - (define (lockfile-add! lf entry) - ;; Add or replace an entry by name. - (let ([existing (filter (lambda (e) - (not (equal? (lock-entry-name e) - (lock-entry-name entry)))) - (lockfile-entries lf))]) - (lockfile-entries-set! lf (cons entry existing)))) - - (define (lockfile-remove! lf name) - (lockfile-entries-set! lf - (filter (lambda (e) (not (equal? (lock-entry-name e) name))) - (lockfile-entries lf)))) - - (define (lockfile-lookup lf name) - ;; Returns lock-entry or #f. - (let loop ([es (lockfile-entries lf)]) - (cond - [(null? es) #f] - [(equal? (lock-entry-name (car es)) name) (car es)] - [else (loop (cdr es))]))) - - (define (lockfile-has? lf name) - (if (lockfile-lookup lf name) #t #f)) - - ;; ========== Serialization ========== - - (define (lockfile->sexp lf) - ;; Returns: (lockfile (entry name ver hash (dep ...)) ...) - `(lockfile - ,@(map (lambda (e) - `(entry ,(lock-entry-name e) - ,(lock-entry-version e) - ,(lock-entry-hash e) - ,(lock-entry-deps e))) - (lockfile-entries lf)))) - - (define (sexp->lockfile sexp) - ;; Parse: (lockfile (entry name ver hash (deps ...)) ...) - (unless (and (pair? sexp) (eq? (car sexp) 'lockfile)) - (error 'sexp->lockfile "invalid lockfile sexp" sexp)) - (let ([entries - (map (lambda (form) - (unless (and (pair? form) - (eq? (car form) 'entry) - (>= (length form) 5)) - (error 'sexp->lockfile "invalid entry form" form)) - (make-lock-entry - (list-ref form 1) - (list-ref form 2) - (list-ref form 3) - (list-ref form 4))) - (cdr sexp))]) - (make-lockfile entries))) - - (define (lockfile-write lf port) - ;; Write lockfile as S-expression to port. - (write (lockfile->sexp lf) port) - (newline port)) - - (define (lockfile-read port) - ;; Read a lockfile from port. - (let ([sexp (read port)]) - (if (eof-object? sexp) - (make-lockfile '()) - (sexp->lockfile sexp)))) - - ;; ========== Merge and Diff ========== - - (define (lockfile-merge lf1 lf2) - ;; Merge lf1 and lf2; lf2 entries take precedence on conflicts. - (let ([result (make-lockfile '())]) - ;; Add all lf1 entries first - (for-each (lambda (e) (lockfile-add! result e)) - (lockfile-entries lf1)) - ;; Add all lf2 entries (overrides lf1 on same name) - (for-each (lambda (e) (lockfile-add! result e)) - (lockfile-entries lf2)) - result)) - - (define (lockfile-diff lf1 lf2) - ;; Returns (added removed changed): - ;; added = entries in lf2 not in lf1 (by name) - ;; removed = entries in lf1 not in lf2 (by name) - ;; changed = entries in both but with different version or hash - (let* ([e1 (lockfile-entries lf1)] - [e2 (lockfile-entries lf2)] - [names1 (map lock-entry-name e1)] - [names2 (map lock-entry-name e2)] - [added (filter (lambda (e) (not (member (lock-entry-name e) names1))) e2)] - [removed (filter (lambda (e) (not (member (lock-entry-name e) names2))) e1)] - [changed - (filter (lambda (e2-entry) - (let ([e1-entry (lockfile-lookup lf1 (lock-entry-name e2-entry))]) - (and e1-entry - (not (and (equal? (lock-entry-version e1-entry) - (lock-entry-version e2-entry)) - (equal? (lock-entry-hash e1-entry) - (lock-entry-hash e2-entry))))))) - e2)]) - (list added removed changed))) - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa/lock.ss @@ -0,0 +1,124 @@ +#!chezscheme +;;; (jerboa lock) — Lockfile Management +;;; +;;; S-expression lockfile for exact package pinning. + +(library (jerboa lock) + (export + ;; Lockfile + make-lockfile lockfile? lockfile-entries + lockfile-add! lockfile-remove! lockfile-lookup lockfile-has? + + ;; Lock entry + make-lock-entry lock-entry? lock-entry-name lock-entry-version + lock-entry-hash lock-entry-deps + + ;; Serialization + lockfile->sexp sexp->lockfile lockfile-write lockfile-read + + ;; Operations + lockfile-merge lockfile-diff) + + (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) + (except (jerboa prelude) meta atom?)) + + (defstruct lock-entry (name version hash deps)) + (defstruct lockfile (entries)) + + (def (lockfile-add! lf entry) + ;; Add or replace an entry by name. + (lockfile-entries-set! lf + (cons entry + (filter (lambda (e) + (not (equal? (lock-entry-name e) + (lock-entry-name entry)))) + (lockfile-entries lf))))) + + (def (lockfile-remove! lf name) + (lockfile-entries-set! lf + (filter (lambda (e) (not (equal? (lock-entry-name e) name))) + (lockfile-entries lf)))) + + (def (lockfile-lookup lf name) + ;; Returns lock-entry or #f. + (let loop ([es (lockfile-entries lf)]) + (cond + [(null? es) #f] + [(equal? (lock-entry-name (car es)) name) (car es)] + [else (loop (cdr es))]))) + + (def (lockfile-has? lf name) + (and (lockfile-lookup lf name) #t)) + + (def (lockfile->sexp lf) + ;; Returns: (lockfile (entry name ver hash (dep ...)) ...) + `(lockfile + ,@(map (lambda (e) + `(entry ,(lock-entry-name e) + ,(lock-entry-version e) + ,(lock-entry-hash e) + ,(lock-entry-deps e))) + (lockfile-entries lf)))) + + (def (parse-entry form) + (match form + [(list 'entry name version hash deps) + (make-lock-entry name version hash deps)] + [_ (error 'sexp->lockfile "invalid entry form" form)])) + + (def (sexp->lockfile sexp) + ;; Parse: (lockfile (entry name ver hash (deps ...)) ...) + (unless (and (pair? sexp) (eq? (car sexp) 'lockfile)) + (error 'sexp->lockfile "invalid lockfile sexp" sexp)) + (make-lockfile (map parse-entry (cdr sexp)))) + + (def (lockfile-write lf port) + (write (lockfile->sexp lf) port) + (newline port)) + + (def (lockfile-read port) + (let ([sexp (read port)]) + (if (eof-object? sexp) + (make-lockfile '()) + (sexp->lockfile sexp)))) + + (def (lockfile-merge lf1 lf2) + ;; Merge lf1 and lf2; lf2 entries take precedence on conflicts. + (let ([result (make-lockfile '())]) + (for-each (lambda (e) (lockfile-add! result e)) + (lockfile-entries lf1)) + (for-each (lambda (e) (lockfile-add! result e)) + (lockfile-entries lf2)) + result)) + + (def (lockfile-diff lf1 lf2) + ;; Returns (added removed changed): + ;; added = entries in lf2 not in lf1 (by name) + ;; removed = entries in lf1 not in lf2 (by name) + ;; changed = entries in both but with different version or hash + (let* ([e1 (lockfile-entries lf1)] + [e2 (lockfile-entries lf2)] + [names1 (map lock-entry-name e1)] + [names2 (map lock-entry-name e2)] + [added (filter (lambda (e) (not (member (lock-entry-name e) names1))) e2)] + [removed (filter (lambda (e) (not (member (lock-entry-name e) names2))) e1)] + [changed + (filter (lambda (e2-entry) + (let ([e1-entry (lockfile-lookup lf1 (lock-entry-name e2-entry))]) + (and e1-entry + (not (and (equal? (lock-entry-version e1-entry) + (lock-entry-version e2-entry)) + (equal? (lock-entry-hash e1-entry) + (lock-entry-hash e2-entry))))))) + e2)]) + (list added removed changed))) + +) ;; end library deleted file mode 100644 --- a/lib/std/assert.sls +++ /dev/null @@ -1,47 +0,0 @@ -#!chezscheme -;;; :std/assert -- Assertion library - -(library (std assert) - (export assert! - assert-equal! - assert-pred - assert-exception) - (import (chezscheme)) - - ;; (assert! expr) or (assert! expr "message") - ;; Raises an error with the expression text if expr is #f. - (define-syntax assert! - (syntax-rules () - [(_ expr) - (unless expr - (error 'assert! (format "assertion failed: ~s" 'expr)))] - [(_ expr msg) - (unless expr - (error 'assert! (format "assertion failed: ~a (~s)" msg 'expr)))])) - - ;; (assert-equal! actual expected) - ;; Compare with equal?, raise error showing both values on mismatch. - (define (assert-equal! actual expected) - (unless (equal? actual expected) - (error 'assert-equal! - (format "expected ~s, got ~s" expected actual)))) - - ;; (assert-pred pred val) - ;; Assert that (pred val) is true. - (define (assert-pred pred val) - (unless (pred val) - (error 'assert-pred - (format "predicate ~s failed for value ~s" pred val)))) - - ;; (assert-exception thunk) - ;; Assert that thunk raises an exception. Returns the raised condition. - (define (assert-exception thunk) - (let ([result (guard (e [#t (cons 'caught e)]) - (thunk) - '(no-exception))]) - (if (and (pair? result) (eq? (car result) 'caught)) - (cdr result) - (error 'assert-exception - "expected an exception but none was raised")))) - - ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/assert.ss @@ -0,0 +1,50 @@ +#!chezscheme +;;; :std/assert -- Assertion library + +(library (std assert) + (export assert! + assert-equal! + assert-pred + assert-exception) + (import (chezscheme) + (only (jerboa core) def try catch finally)) + + ;; (assert! expr) or (assert! expr "message") + ;; Raises an error with the expression text if expr is #f. + (define-syntax assert! + (syntax-rules () + [(_ expr) + (unless expr + (error 'assert! (format "assertion failed: ~s" 'expr)))] + [(_ expr msg) + (unless expr + (error 'assert! (format "assertion failed: ~a (~s)" msg 'expr)))])) + + ;; (assert-equal! actual expected) + ;; Compare with equal?, raise error showing both values on mismatch. + (def (assert-equal! actual expected) + (unless (equal? actual expected) + (error 'assert-equal! + (format "expected ~s, got ~s" expected actual)))) + + ;; (assert-pred pred val) + ;; Assert that (pred val) is true. + (def (assert-pred pred val) + (unless (pred val) + (error 'assert-pred + (format "predicate ~s failed for value ~s" pred val)))) + + ;; (assert-exception thunk) + ;; Assert that thunk raises an exception. Returns the raised condition. + ;; Use a sentinel-tag pattern so we can tell "thunk ran cleanly" from + ;; "thunk raised" without the post-thunk error being swallowed by catch. + (def (assert-exception thunk) + (let ([result (try + (begin (thunk) '(no-exception)) + (catch (e) (cons 'caught e)))]) + (if (and (pair? result) (eq? (car result) 'caught)) + (cdr result) + (error 'assert-exception + "expected an exception but none was raised")))) + + ) ;; end library deleted file mode 100644 --- a/lib/std/os/errno.sls +++ /dev/null @@ -1,162 +0,0 @@ -#!chezscheme -;;; (std os errno) -- Cross-platform errno access and POSIX error constants -;;; -;;; Thin module so callers (aproc, debug-repl, future syscall wrappers) -;;; can read errno and check well-known values without pulling in the -;;; rest of (std os posix). Tries the three known C-side symbols: -;;; -;;; macOS / *BSD: __error (thread-local errno pointer) -;;; Linux glibc: __errno_location -;;; Bionic / musl: __errno -;;; -;;; Use: -;;; (errno) => current errno (int) -;;; (errno-strerror n) => string for errno N -;;; (errno-name n) => 'EINTR / 'ECHILD / ... or 'UNKNOWN -;;; E* constants exported by name (EINTR EAGAIN EWOULDBLOCK ECHILD EINVAL EPIPE -;;; ESRCH EPERM EBADF ENOENT EACCES EEXIST EIO -;;; ETIMEDOUT EBUSY ENOMEM EFAULT ENOTDIR) -;;; -;;; Numeric values differ between Linux and the BSDs; the constants are -;;; resolved at load time based on (machine-type). - -(library (std os errno) - (export - errno - errno-strerror - errno-name - errno-supported? - - EINTR EAGAIN EWOULDBLOCK ECHILD EINVAL EPIPE - ESRCH EPERM EBADF ENOENT EACCES EEXIST EIO - ETIMEDOUT EBUSY ENOMEM EFAULT ENOTDIR ENOSYS - EMFILE ENFILE ENOEXEC E2BIG) - - (import (chezscheme)) - - ;; Try to make libc symbols visible. (load-shared-object #f) maps the - ;; running image, which works for static binaries; the platform fallbacks - ;; handle dynamic builds where libc isn't already in the image. - (define _libc-loaded - (or (guard (e [#t #f]) (load-shared-object #f)) - (guard (e [#t #f]) (load-shared-object "libc.so.7")) - (guard (e [#t #f]) (load-shared-object "libc.so.6")) - (guard (e [#t #f]) (load-shared-object "libc.so")) - (guard (e [#t #f]) (load-shared-object "/usr/lib/libSystem.B.dylib")) - (guard (e [#t #f]) (load-shared-object "libSystem.dylib")) - (guard (e [#t #f]) (load-shared-object "libc.dylib")))) - - ;; ========== Platform detection ========== - (define machine-type-str (symbol->string (machine-type))) - - (define (ends-with? s suf) - (let ((sl (string-length s)) (fl (string-length suf))) - (and (>= sl fl) - (string=? (substring s (- sl fl) sl) suf)))) - - (define *freebsd?* (memq (machine-type) '(a6fb ta6fb i3fb ti3fb arm64fb))) - (define *openbsd?* (memq (machine-type) '(a6ob ta6ob arm64ob))) - (define *netbsd?* (memq (machine-type) '(a6nb ta6nb arm64nb))) - (define *macos?* (ends-with? machine-type-str "osx")) - (define *bsd-family?* (or *freebsd?* *openbsd?* *netbsd?* *macos?*)) - - ;; ========== errno location ========== - ;; Returns a thunk that yields a void* pointer to the current thread's - ;; errno cell — or #f if no known symbol resolved. - (define c-errno-location - (let try ((names (if *bsd-family?* - '("__error" "__errno_location" "__errno") - '("__errno_location" "__errno" "__error")))) - (cond - ((null? names) #f) - (else - (or (guard (e [#t #f]) - (foreign-procedure (car names) () void*)) - (try (cdr names))))))) - - (define (errno-supported?) - (and c-errno-location #t)) - - (define (errno) - (if c-errno-location - (foreign-ref 'int (c-errno-location) 0) - 0)) - - ;; ========== strerror ========== - (define c-strerror - (foreign-procedure "strerror" (int) string)) - - (define (errno-strerror n) - (or (guard (e [#t #f]) (c-strerror n)) - (string-append "errno=" (number->string n)))) - - ;; ========== Errno constants ========== - ;; Most are stable across platforms; the divergent ones (EAGAIN/EWOULDBLOCK - ;; on BSDs vs Linux, EDEADLK numbering, etc.) get a platform branch. - (define EPERM 1) - (define ENOENT 2) - (define ESRCH 3) - (define EINTR 4) - (define EIO 5) - (define E2BIG 7) - (define ENOEXEC 8) - (define EBADF 9) - (define ECHILD 10) - (define EACCES 13) - (define EFAULT 14) - (define EBUSY 16) - (define EEXIST 17) - (define ENOTDIR 20) - (define EINVAL 22) - (define ENFILE 23) - (define EMFILE 24) - (define ENOMEM (if *bsd-family?* 12 12)) - ;; EPIPE = 32 on Linux/glibc and the BSDs alike. - (define EPIPE 32) - - ;; EAGAIN/EWOULDBLOCK - ;; Linux: EAGAIN = EWOULDBLOCK = 11 - ;; *BSD: EAGAIN = EWOULDBLOCK = 35 - (define EAGAIN (if *bsd-family?* 35 11)) - (define EWOULDBLOCK EAGAIN) - - ;; ETIMEDOUT - ;; Linux: 110 - ;; FreeBSD: 60 macOS: 60 OpenBSD: 60 - (define ETIMEDOUT (if *bsd-family?* 60 110)) - - ;; ENOSYS - ;; Linux: 38 - ;; FreeBSD: 78 macOS: 78 - (define ENOSYS (if *bsd-family?* 78 38)) - - ;; ========== Name lookup ========== - ;; Reverse map: errno value -> symbol. Returns 'UNKNOWN for codes we - ;; haven't enumerated. Used by error messages, not by hot paths. - (define (errno-name n) - (cond - ((= n EPERM) 'EPERM) - ((= n ENOENT) 'ENOENT) - ((= n ESRCH) 'ESRCH) - ((= n EINTR) 'EINTR) - ((= n EIO) 'EIO) - ((= n E2BIG) 'E2BIG) - ((= n ENOEXEC) 'ENOEXEC) - ((= n EBADF) 'EBADF) - ((= n ECHILD) 'ECHILD) - ((= n EAGAIN) 'EAGAIN) - ((= n EACCES) 'EACCES) - ((= n EFAULT) 'EFAULT) - ((= n EBUSY) 'EBUSY) - ((= n EEXIST) 'EEXIST) - ((= n ENOTDIR) 'ENOTDIR) - ((= n EINVAL) 'EINVAL) - ((= n ENFILE) 'ENFILE) - ((= n EMFILE) 'EMFILE) - ((= n ENOMEM) 'ENOMEM) - ((= n EPIPE) 'EPIPE) - ((= n ETIMEDOUT) 'ETIMEDOUT) - ((= n ENOSYS) 'ENOSYS) - (else 'UNKNOWN))) - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/os/errno.ss @@ -0,0 +1,174 @@ +#!chezscheme +;;; (std os errno) -- Cross-platform errno access and POSIX error constants +;;; +;;; Thin module so callers (aproc, debug-repl, future syscall wrappers) +;;; can read errno and check well-known values without pulling in the +;;; rest of (std os posix). Tries the three known C-side symbols: +;;; +;;; macOS / *BSD: __error (thread-local errno pointer) +;;; Linux glibc: __errno_location +;;; Bionic / musl: __errno +;;; +;;; Use: +;;; (errno) => current errno (int) +;;; (errno-strerror n) => string for errno N +;;; (errno-name n) => 'EINTR / 'ECHILD / ... or 'UNKNOWN +;;; E* constants exported by name (EINTR EAGAIN EWOULDBLOCK ECHILD EINVAL EPIPE +;;; ESRCH EPERM EBADF ENOENT EACCES EEXIST EIO +;;; ETIMEDOUT EBUSY ENOMEM EFAULT ENOTDIR) +;;; +;;; Numeric values differ between Linux and the BSDs; the constants are +;;; resolved at load time based on (machine-type). + +(library (std os errno) + (export + errno + errno-strerror + errno-name + errno-supported? + + EINTR EAGAIN EWOULDBLOCK ECHILD EINVAL EPIPE + ESRCH EPERM EBADF ENOENT EACCES EEXIST EIO + ETIMEDOUT EBUSY ENOMEM EFAULT ENOTDIR ENOSYS + EMFILE ENFILE ENOEXEC E2BIG) + + (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) + (except (jerboa prelude) meta atom?)) + + ;; Try to make libc symbols visible. (load-shared-object #f) maps the + ;; running image, which works for static binaries; the platform fallbacks + ;; handle dynamic builds where libc isn't already in the image. + (def _libc-loaded + (some (lambda (lib) + (try (begin (load-shared-object lib) #t) + (catch (e) #f))) + '(#f + "libc.so.7" + "libc.so.6" + "libc.so" + "/usr/lib/libSystem.B.dylib" + "libSystem.dylib" + "libc.dylib"))) + + ;; ========== Platform detection ========== + (def machine-type-str (symbol->string (machine-type))) + + (def (ends-with? s suf) + (let ([sl (string-length s)] [fl (string-length suf)]) + (and (>= sl fl) + (string=? (substring s (- sl fl) sl) suf)))) + + (def *freebsd?* (memq (machine-type) '(a6fb ta6fb i3fb ti3fb arm64fb))) + (def *openbsd?* (memq (machine-type) '(a6ob ta6ob arm64ob))) + (def *netbsd?* (memq (machine-type) '(a6nb ta6nb arm64nb))) + (def *macos?* (ends-with? machine-type-str "osx")) + (def *bsd-family?* (or *freebsd?* *openbsd?* *netbsd?* *macos?*)) + + ;; ========== errno location ========== + ;; Returns a thunk that yields a void* pointer to the current thread's + ;; errno cell — or #f if no known symbol resolved. + (def c-errno-location + (let try-names ([names (if *bsd-family?* + '("__error" "__errno_location" "__errno") + '("__errno_location" "__errno" "__error"))]) + (cond + [(null? names) #f] + [else + (or (try (foreign-procedure (car names) () void*) + (catch (e) #f)) + (try-names (cdr names)))]))) + + (def (errno-supported?) + (and c-errno-location #t)) + + (def (errno) + (if c-errno-location + (foreign-ref 'int (c-errno-location) 0) + 0)) + + ;; ========== strerror ========== + (def c-strerror + (foreign-procedure "strerror" (int) string)) + + (def (errno-strerror n) + (or (try (c-strerror n) (catch (e) #f)) + (string-append "errno=" (number->string n)))) + + ;; ========== Errno constants ========== + ;; Most are stable across platforms; the divergent ones (EAGAIN/EWOULDBLOCK + ;; on BSDs vs Linux, EDEADLK numbering, etc.) get a platform branch. + (def EPERM 1) + (def ENOENT 2) + (def ESRCH 3) + (def EINTR 4) + (def EIO 5) + (def E2BIG 7) + (def ENOEXEC 8) + (def EBADF 9) + (def ECHILD 10) + (def EACCES 13) + (def EFAULT 14) + (def EBUSY 16) + (def EEXIST 17) + (def ENOTDIR 20) + (def EINVAL 22) + (def ENFILE 23) + (def EMFILE 24) + (def ENOMEM 12) + ;; EPIPE = 32 on Linux/glibc and the BSDs alike. + (def EPIPE 32) + + ;; EAGAIN/EWOULDBLOCK + ;; Linux: EAGAIN = EWOULDBLOCK = 11 + ;; *BSD: EAGAIN = EWOULDBLOCK = 35 + (def EAGAIN (if *bsd-family?* 35 11)) + (def EWOULDBLOCK EAGAIN) + + ;; ETIMEDOUT + ;; Linux: 110 + ;; FreeBSD: 60 macOS: 60 OpenBSD: 60 + (def ETIMEDOUT (if *bsd-family?* 60 110)) + + ;; ENOSYS + ;; Linux: 38 + ;; FreeBSD: 78 macOS: 78 + (def ENOSYS (if *bsd-family?* 78 38)) + + ;; ========== Name lookup ========== + ;; Reverse map: errno value -> symbol. Returns 'UNKNOWN for codes we + ;; haven't enumerated. Used by error messages, not by hot paths. + (def (errno-name n) + (cond + [(= n EPERM) 'EPERM] + [(= n ENOENT) 'ENOENT] + [(= n ESRCH) 'ESRCH] + [(= n EINTR) 'EINTR] + [(= n EIO) 'EIO] + [(= n E2BIG) 'E2BIG] + [(= n ENOEXEC) 'ENOEXEC] + [(= n EBADF) 'EBADF] + [(= n ECHILD) 'ECHILD] + [(= n EAGAIN) 'EAGAIN] + [(= n EACCES) 'EACCES] + [(= n EFAULT) 'EFAULT] + [(= n EBUSY) 'EBUSY] + [(= n EEXIST) 'EEXIST] + [(= n ENOTDIR) 'ENOTDIR] + [(= n EINVAL) 'EINVAL]