Layer 0: Gerbil-compatible reader for Chez Scheme
ober
ffcbfcca0ed6486c64d181129d493a001d4e3362
new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +*.so +*.wpo +*.boot +*~ +\#* +.#* new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,28 @@ +SCHEME = scheme +LIBDIRS = lib + +.PHONY: test test-reader test-core test-runtime test-stdlib clean + +test: test-reader test-core test-runtime test-stdlib + +test-reader: + $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-reader.ss + +test-core: + @if [ -f tests/test-core.ss ]; then \ + $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-core.ss; \ + fi + +test-runtime: + @if [ -f tests/test-runtime.ss ]; then \ + $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-runtime.ss; \ + fi + +test-stdlib: + @if [ -f tests/test-stdlib.ss ]; then \ + $(SCHEME) --libdirs $(LIBDIRS) --script tests/test-stdlib.ss; \ + fi + +clean: + find lib -name "*.so" -delete 2>/dev/null || true + find lib -name "*.wpo" -delete 2>/dev/null || true new file mode 100644 --- /dev/null +++ b/gerbil-like.md @@ -0,0 +1,436 @@ +# Gerbil-Like Language on Chez Scheme + +## The Core Realization + +What makes code "Gerbil" to the person writing it? It's not the expander, not Gambit's `##` primitives, not the internal MOP representation. It's: + +1. **Syntax**: `def`, `defstruct`, `defmethod`, `match`, `[]`, `try`/`catch`, `keyword:` args +2. **Standard library API**: `hash-ref`, `string-split`, `sort`, channels, JSON +3. **Module paths**: `(import :std/sort :mypackage/module)` +4. **FFI**: `(c-lambda (int) int "close")` + +Everything else is implementation detail the user never sees. All of those user-facing features are implementable as Chez macros + a runtime library. No Gerbil expander needed. + +## The Architecture: A Chez Macro Library + +``` +┌──────────────────────────────────────────────┐ +│ User's Gerbil-like code │ +│ (def (main) (displayln (sort [3 1 2] <))) │ +└──────────────┬───────────────────────────────┘ + │ (import :gerbil/core) +┌──────────────▼───────────────────────────────┐ +│ Layer 1: Syntax Macros (~500 lines) │ +│ def, defstruct, defclass, defmethod, │ +│ match, try/catch, defrules, using, with │ +└──────────────┬───────────────────────────────┘ + │ expands to +┌──────────────▼───────────────────────────────┐ +│ Layer 2: Runtime (~1500 lines) │ +│ MOP, hash tables, keywords, errors │ +│ All built on Chez records + hashtables │ +└──────────────┬───────────────────────────────┘ + │ uses +┌──────────────▼───────────────────────────────┐ +│ Layer 3: Standard Library (~3000 lines) │ +│ :std/sort, :std/text/json, :std/misc/* │ +│ Native Chez implementations, Gerbil API │ +└──────────────┬───────────────────────────────┘ + │ uses +┌──────────────▼───────────────────────────────┐ +│ Stock Chez Scheme — no fork, no patches │ +└──────────────────────────────────────────────┘ +``` + +No Gerbil expander. No gambit-compat.sls. No 1790 lines of `##` primitive shims. Just macros expanding to clean Chez code. + +## Layer by Layer + +### Layer 0: The Reader + +Handles: +- `[1 2 3]` → list syntax +- `{method obj}` → method dispatch +- `keyword:` → keyword objects +- `#!void`, `#!eof` → special values + +Instead of emitting `(@list ...)` and `(@method ...)` markers that the compiler interprets later, **expand them directly to Chez forms at read time**: + +```scheme +[1 2 3] → (list 1 2 3) +{method obj} → (~ obj method) ; ~ is the dispatch operator +foo: → (quote #:foo) ; or a keyword record +``` + +This eliminates the compiler's need to pattern-match these. They're just Chez expressions by the time macros see them. + +### Layer 1: Syntax Macros + +Every user-facing form becomes a `define-syntax` in Chez. Here's the complete list with how they expand: + +**`def`** — the big one. Handles 5 patterns: + +```scheme +;; Simple binding +(def x 42) +→ (define x 42) + +;; Function +(def (f x y) body ...) +→ (define (f x y) body ...) + +;; Optional args +(def (f x (y 0) (z 1)) body ...) +→ (define f + (case-lambda + [(x) (f x 0 1)] + [(x y) (f x y 1)] + [(x y z) body ...])) + +;; Keyword args +(def (f x key: (k 0)) body ...) +→ (define f + (make-keyword-procedure + (lambda (x k) body ...) + '((k: . 0)))) + +;; Rest args +(def (f x . rest) body ...) +→ (define (f x . rest) body ...) +``` + +**`defstruct`** — maps to Chez records, which are faster than gerbil-struct simulation: + +```scheme +(defstruct point (x y)) +→ (begin + (define-record-type point + (fields (mutable x) (mutable y))) + (define point::t (record-type-descriptor point)) + (define make-point (record-constructor (record-constructor-descriptor point))) + (define point? (record-predicate point::t)) + (define point-x (record-accessor point::t 0)) + (define point-y (record-accessor point::t 1)) + (define point-x-set! (record-mutator point::t 0)) + (define point-y-set! (record-mutator point::t 1))) +``` + +This is **native Chez speed** — no MOP indirection, no `##structure-ref` shims. Chez records are as fast as C structs. + +**`defclass`** — for classes with inheritance and methods, uses Chez's record inheritance: + +```scheme +(defclass (colored-point point) (color)) +→ (begin + (define-record-type colored-point + (parent point) + (fields (mutable color))) + ;; + method table registration + (register-class! colored-point::t '(point::t) '(color))) +``` + +**`defmethod`** — method dispatch via hashtable lookup: + +```scheme +(defmethod {draw self} + (displayln "drawing at " (point-x self))) +→ (bind-method! point::t 'draw + (lambda (self) (displayln "drawing at " (point-x self)))) +``` + +**`match`** — ~150 lines as a `syntax-case` macro: + +```scheme +(match expr + ([a b c] body1) + ((? string? s) body2) + (else body3)) +→ (let ([tmp expr]) + (cond + [(and (pair? tmp) (pair? (cdr tmp)) (pair? (cddr tmp)) (null? (cdddr tmp))) + (let ([a (car tmp)] [b (cadr tmp)] [c (caddr tmp)]) body1)] + [(string? tmp) (let ([s tmp]) body2)] + [else body3])) +``` + +**`try`/`catch`** — maps to Chez's `guard`: + +```scheme +(try + (risky-operation) + (catch (e) (handle e)) + (finally (cleanup))) +→ (dynamic-wind + (lambda () (void)) + (lambda () + (guard (e [#t (handle e)]) + (risky-operation))) + (lambda () (cleanup))) +``` + +**Complete macro list** (~500 lines total): + +| Macro | Expands to | Lines | +|-------|-----------|-------| +| `def` | `define` / `case-lambda` | ~60 | +| `defstruct` | `define-record-type` | ~50 | +| `defclass` | `define-record-type` + parent + MOP | ~80 | +| `defmethod` | `bind-method!` | ~15 | +| `defrules` | `define-syntax` + `syntax-rules` | ~30 | +| `match` | `cond` + destructuring | ~150 | +| `try`/`catch`/`finally` | `guard` + `dynamic-wind` | ~40 | +| `when`/`unless` | `if`/`begin` | ~5 | +| `using` | `let` + accessors | ~20 | +| `with` | resource management | ~20 | +| `while`/`until` | named `let` loop | ~10 | +| `hash` / `hash-eq` | hashtable constructor | ~10 | +| `let-hash` | hash destructuring | ~15 | + +### Layer 2: Runtime Library + +This is the stuff macros expand into — not user-facing, but needed. + +**MOP** (~200 lines) — simplified because Chez records do the heavy lifting: + +```scheme +;; Method dispatch table: type-descriptor → (symbol → procedure) hashtable +(define *method-tables* (make-eq-hashtable)) + +(define (bind-method! type name proc) + (let ([table (or (hashtable-ref *method-tables* type #f) + (let ([t (make-eq-hashtable)]) + (hashtable-set! *method-tables* type t) + t))]) + (hashtable-set! table name proc))) + +(define (call-method obj name . args) + (let ([type (record-rtd obj)]) + (let loop ([t type]) + (cond + [(and t (hashtable-ref (hashtable-ref *method-tables* t + (make-eq-hashtable)) name #f)) + => (lambda (method) (apply method obj args))] + [(record-type-parent t) => loop] + [else (error 'call-method "no method" name type)])))) +``` + +That's the entire method dispatch. ~30 lines vs hundreds in the current MOP because Chez records already handle inheritance, field access, and type checking natively. + +**Hash tables** (~100 lines) — Gerbil API on Chez hashtables: + +```scheme +(define (hash-ref ht key (default absent)) + (let ([v (hashtable-ref ht key absent)]) + (if (eq? v absent) (error "key not found" key) v))) + +(define hash-put! hashtable-set!) +(define hash-remove! hashtable-delete!) + +(define (hash-for-each proc ht) + (vector-for-each + (lambda (k) (proc k (hashtable-ref ht k #f))) + (hashtable-keys ht))) +``` + +**Keywords** (~30 lines) — tagged symbols: + +```scheme +(define-record-type keyword (fields name)) +(define (keyword->string kw) (keyword-name kw)) +(define (string->keyword s) (make-keyword s)) +``` + +**Error types** (~50 lines) — Gerbil errors as Chez conditions: + +```scheme +(define-condition-type &gerbil-error &error + make-gerbil-error gerbil-error? + (irritants gerbil-error-irritants) + (trace gerbil-error-trace)) +``` + +Using Chez conditions instead of simulated Gambit error structs means `(guard ...)` works natively, the debugger understands them, and `display-condition` prints them properly. + +### Layer 3: Standard Library + +**Native implementations with Gerbil's API.** Not loaded through the expander, not compiled from Gerbil source — written directly in Chez with Gerbil-compatible exports: + +```scheme +;; :std/sort — 10 lines +(library (std sort) + (export sort sort! stable-sort stable-sort!) + (import (chezscheme)) + (define (sort lst less?) (list-sort less? lst)) + (define (sort! lst less?) (list-sort less? lst)) + (define stable-sort sort) + (define stable-sort! sort!)) +``` + +```scheme +;; :std/text/json — ~200 lines +(library (std text json) + (export read-json write-json json-object->string string->json-object) + (import (chezscheme) (gerbil core)) + ;; Native implementation using Chez ports + ...) +``` + +```scheme +;; :std/misc/channel — ~100 lines (Chez-native, not shimmed Gambit) +(library (std misc channel) + (export make-channel channel-put channel-get channel-try-get channel-close) + (import (chezscheme)) + + (define-record-type channel + (fields (mutable queue) (immutable mutex) (immutable condvar) (mutable closed?))) + + (define (make-channel . args) + (make-channel '() (make-mutex) (make-condition) #f)) + + (define (channel-put ch val) + (with-mutex (channel-mutex ch) + (channel-queue-set! ch (append (channel-queue ch) (list val))) + (condition-signal (channel-condvar ch)))) + + (define (channel-get ch) + (with-mutex (channel-mutex ch) + (let loop () + (if (null? (channel-queue ch)) + (begin (condition-wait (channel-condvar ch) (channel-mutex ch)) (loop)) + (let ([val (car (channel-queue ch))]) + (channel-queue-set! ch (cdr (channel-queue ch))) + val)))))) +``` + +That channel implementation is ~20 lines and uses Chez's native mutex + condition variables. Real SMP. No Gambit shim. + +### Layer 4: FFI + +Translate Gerbil's FFI syntax to Chez's at macro-expansion time: + +```scheme +(define-syntax begin-ffi + (syntax-rules () + [(_ (export-name ...) body ...) + (begin (ffi-compile-c-blocks body ...) ...)])) + +(define-syntax c-lambda + (syntax-rules () + [(_ (arg-type ...) ret-type c-name) + (foreign-procedure c-name + (ffi-translate-type arg-type) ... + (ffi-translate-type ret-type))])) +``` + +The `c-declare` blocks need a compile-time step: extract C code, compile to `.so`, emit `load-shared-object`. This can be a build-system step rather than a macro — the `gherkin build` command handles it. + +FFI type mapping: + +| Gambit type | Chez type | +|-------------|-----------| +| `char-string` | `string` | +| `int` | `int` | +| `unsigned-int` | `unsigned` | +| `int64` | `integer-64` | +| `double` | `double` | +| `bool` | `boolean` | +| `scheme-object` | `scheme-object` | +| `void` | `void` | +| `(pointer void)` | `void*` | +| `nonnull-char-string` | `string` | + +### Layer 5: Module System + +Map Gerbil's `:package/module` paths to R6RS library paths: + +```scheme +(import :std/sort) → (import (std sort)) +(import :std/text/json) → (import (std text json)) +(import :myapp/core) → (import (myapp core)) +(export func1 func2) → (export func1 func2) +(export #t) → ;; re-export everything (needs macro support) +``` + +This is a reader-level transformation. When the reader sees `(import :std/sort)`, it emits `(import (std sort))`. Chez's library system handles compilation, caching, and dependency tracking natively. You get Chez's incremental compilation for free. + +## What This Means for Real Projects + +Here's what gerbil-shell code looks like today: + +```scheme +(import :std/sugar :std/sort :std/format :std/foreign + :gsh/lib :gsh/environment) + +(export start-shell run-command) + +(def (run-command cmd env) + (try + (let* ([tokens (tokenize cmd)] + [expanded (expand-aliases tokens env)]) + (match expanded + (["cd" dir] (chdir dir)) + ([prog . args] (exec-pipeline prog args env)) + (else (displayln "empty command")))) + (catch (e) (displayln "error: " (error-message e))))) +``` + +**This code would work unchanged.** Every form in it (`def`, `try`, `match`, `import`, `export`) is handled by the macro library. The `:std/*` imports resolve to native Chez libraries. The FFI imports compile to `foreign-procedure`. + +## What Changes vs Current Gherkin + +| Aspect | Current Gherkin | New approach | +|--------|----------------|--------------| +| Gerbil's expander | Loaded and run on Chez | Not needed | +| gambit-compat.sls | 1790 lines | Deleted | +| MOP | 800+ lines simulating Gambit structs | ~200 lines on Chez records | +| `defstruct` | → gerbil-struct → fields vector | → Chez `define-record-type` (native speed) | +| Method dispatch `{}` | Runtime `call-method` injection | Reader expands to `(~ obj method)` | +| Module loading | Custom loader + `/tmp` cache | Chez's native library system | +| Compilation | Pattern-match compiler (1100 lines) | Macros (~500 lines) | +| std library | Load Gerbil's source through expander | Native Chez reimplementation | +| FFI | Not implemented | `c-lambda` → `foreign-procedure` macro | +| Bootstrap | Load expander + compiler + core + runtime | `(import (gerbil core))` | + +The total codebase shrinks from ~50 files / 20K+ lines to roughly: + +| Component | Lines | +|-----------|-------| +| Reader | ~600 (keep existing, simplify) | +| Core macros | ~500 | +| Runtime (MOP, hash, keywords, errors) | ~800 | +| Standard library modules | ~3000 | +| FFI translation | ~200 | +| Module path mapping | ~100 | +| **Total** | **~5200** | + +vs. the current gherkin at ~20K+ lines across 50+ files. + +## What Gerbil Code Won't Work + +Being honest about what breaks: + +1. **Code using `syntax-case` with Gerbil's binding semantics** — rare in user code, common in Gerbil's own macro system. The macros would use Chez's `syntax-case` which is R6RS-standard. + +2. **Code using Gerbil's expander API directly** (`:gerbil/expander`) — gemacs uses this for its REPL. Solution: the REPL evaluates via Chez's `eval` with the macro library loaded. + +3. **Code using `##` Gambit primitives** — gsh uses `##cpu-count`, `##set-parallelism-level!`. Solution: provide the 10-15 primitives that real projects actually use, not all 90+. + +4. **`(export #t)`** — Gerbil's "re-export everything" convention. Needs a custom macro that tracks imports and re-exports them. Doable but ~50 lines of `syntax-case`. + +5. **Phase separation** (`for-syntax`, `begin-syntax`) — needed for advanced macros. Chez supports this natively via R6RS phases, but the syntax differs. Needs a translation macro. + +For gerbil-shell and gerbil-emacs specifically, items 1-2 affect maybe 5 lines of code total. Items 3-5 are straightforward to handle. + +## Summary + +Stop porting Gerbil. **Reimplement its surface** — the syntax and APIs users actually write — as a Chez library. You keep 95%+ source compatibility with real Gerbil projects while getting: + +- Native Chez record speed (no MOP indirection for structs) +- Native Chez threads (real SMP) +- Native Chez compilation (incremental, cached, fast) +- Native Chez FFI (zero overhead) +- Native Chez debugging (conditions, inspector) +- Stock Chez (no fork) +- ~5K lines instead of ~20K + +The user writes Gerbil. The machine runs Chez. Nothing in between pretends to be Gambit. new file mode 100644 --- /dev/null +++ b/lib/jerboa/reader.sls @@ -0,0 +1,726 @@ +#!chezscheme +;;; reader.sls -- Gerbil-compatible reader for Jerboa +;;; +;;; Handles: [...] → (list ...), {...} → (~ obj method args ...), +;;; #!void/#!eof, keyword: syntax, source locations, +;;; #; datum comments, #| block comments |#, #u8(...), #&box + +(library (jerboa reader) + (export + jerboa-read + jerboa-read-all + jerboa-read-file + jerboa-read-string + source-location source-location? + source-location-path source-location-line source-location-column + make-source-location + annotated-datum annotated-datum? + annotated-datum-value annotated-datum-source + make-annotated-datum) + + (import (chezscheme)) + + ;;;; Source locations + (define-record-type source-location + (fields path line column) + (sealed #t)) + + (define-record-type annotated-datum + (fields value source) + (sealed #t)) + + ;;;; Reader state + (define-record-type reader-state + (fields + port + (mutable line) + (mutable column) + (mutable path) + (mutable peeked)) + (sealed #t)) + + (define (make-reader port . path) + (make-reader-state port 1 0 (if (null? path) #f (car path)) #f)) + + ;;;; Character I/O with tracking + + (define (reader-peek rs) + (or (reader-state-peeked rs) + (let ((ch (read-char (reader-state-port rs)))) + (reader-state-peeked-set! rs ch) + ch))) + + (define (reader-next! rs) + (let ((ch (or (reader-state-peeked rs) + (read-char (reader-state-port rs))))) + (reader-state-peeked-set! rs #f) + (when (char? ch) + (if (char=? ch #\newline) + (begin + (reader-state-line-set! rs (fx+ (reader-state-line rs) 1)) + (reader-state-column-set! rs 0)) + (reader-state-column-set! rs (fx+ (reader-state-column rs) 1)))) + ch)) + + (define (reader-location rs) + (make-source-location + (reader-state-path rs) + (reader-state-line rs) + (reader-state-column rs))) + + (define (annotate rs value loc) + (if (reader-state-path rs) + (make-annotated-datum value loc) + value)) + + ;;;; Character classification + + (define (delimiter? ch) + (or (eof-object? ch) + (char-whitespace? ch) + (memv ch '(#\( #\) #\[ #\] #\{ #\} #\" #\; #\,)))) + + (define (initial-ident? ch) + (and (char? ch) + (or (char-alphabetic? ch) + (memv ch '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~ + #\+ #\- #\. #\@))))) + + (define (subsequent-ident? ch) + (and (char? ch) + (or (char-alphabetic? ch) + (char-numeric? ch) + (memv ch '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\^ #\_ #\~ + #\+ #\- #\. #\@ #\#))))) + + ;;;; Comment skipping + + (define (skip-whitespace! rs) + (let loop () + (let ((ch (reader-peek rs))) + (cond + ((eof-object? ch) (void)) + ((char-whitespace? ch) + (reader-next! rs) + (loop)) + ((char=? ch #\;) + (skip-line-comment! rs) + (loop)) + (else (void)))))) + + (define (skip-line-comment! rs) + (let loop () + (let ((ch (reader-next! rs))) + (unless (or (eof-object? ch) (char=? ch #\newline)) + (loop))))) + + (define (skip-block-comment! rs depth) + (let loop ((depth depth)) + (when (fx> depth 0) + (let ((ch (reader-next! rs))) + (cond + ((eof-object? ch) + (error 'jerboa-read "unterminated block comment")) + ((char=? ch #\#) + (let ((ch2 (reader-peek rs))) + (if (and (char? ch2) (char=? ch2 #\|)) + (begin (reader-next! rs) (loop (fx+ depth 1))) + (loop depth)))) + ((char=? ch #\|) + (let ((ch2 (reader-peek rs))) + (if (and (char? ch2) (char=? ch2 #\#)) + (begin (reader-next! rs) (loop (fx- depth 1))) + (loop depth)))) + (else (loop depth))))))) + + ;;;; Main reader dispatch + + (define (read-datum rs) + (skip-whitespace! rs) + (let ((loc (reader-location rs)) + (ch (reader-peek rs))) + (cond + ((eof-object? ch) (eof-object)) + + ;; Lists + ((char=? ch #\() + (reader-next! rs) + (annotate rs (read-list rs #\)) loc)) + + ;; Square brackets → (list ...) + ((char=? ch #\[) + (reader-next! rs) + (let ((items (read-list rs #\]))) + (annotate rs (cons 'list items) loc))) + + ;; Curly braces → (~ obj method args...) + ((char=? ch #\{) + (reader-next! rs) + (let ((items (read-list rs #\}))) + (cond + ((null? items) + (error 'jerboa-read "empty method dispatch {}")) + ((null? (cdr items)) + (error 'jerboa-read "method dispatch needs at least {method obj}")) + (else + ;; {method obj args...} → (~ obj 'method args...) + (let ((method (car items)) + (obj (cadr items)) + (args (cddr items))) + (annotate rs + (cons* '~ obj (list 'quote method) args) + loc)))))) + + ;; Closing delimiters + ((or (char=? ch #\)) (char=? ch #\]) (char=? ch #\})) + (error 'jerboa-read "unexpected closing delimiter" ch + (reader-state-line rs) (reader-state-column rs))) + + ;; String + ((char=? ch #\") + (reader-next! rs) + (annotate rs (read-string-literal rs) loc)) + + ;; Quote + ((char=? ch #\') + (reader-next! rs) + (annotate rs (list 'quote (read-datum rs)) loc)) + + ;; Quasiquote + ((char=? ch #\`) + (reader-next! rs) + (annotate rs (list 'quasiquote (read-datum rs)) loc)) + + ;; Unquote / unquote-splicing + ((char=? ch #\,) + (reader-next! rs) + (let ((ch2 (reader-peek rs))) + (if (and (char? ch2) (char=? ch2 #\@)) + (begin + (reader-next! rs) + (annotate rs (list 'unquote-splicing (read-datum rs)) loc)) + (annotate rs (list 'unquote (read-datum rs)) loc)))) + + ;; Hash dispatch + ((char=? ch #\#) + (reader-next! rs) + (read-hash rs loc)) + + ;; Number or symbol starting with + or - + ((or (char=? ch #\+) (char=? ch #\-)) + (read-number-or-symbol rs loc)) + + ;; Number + ((char-numeric? ch) + (annotate rs (read-number rs) loc)) + + ;; Symbol or keyword + ((or (initial-ident? ch) (char=? ch #\|)) + (read-symbol-or-keyword rs loc)) + + (else + (reader-next! rs) + (error 'jerboa-read "unexpected character" ch))))) + + ;;;; List reader + + (define (read-list rs close-char) + (let loop ((acc '())) + (skip-whitespace! rs) + (let ((hash-datum (handle-hash-comments! rs))) + (if hash-datum + (loop (cons hash-datum acc)) + (let ((ch (reader-peek rs))) + (cond + ((eof-object? ch) + (error 'jerboa-read "unterminated list")) + ((char=? ch close-char) + (reader-next! rs) + (reverse acc)) + ;; Dot for dotted pairs + ((char=? ch #\.) + (reader-next! rs) + (let ((ch2 (reader-peek rs))) + (cond + ((delimiter? ch2) + ;; Dotted pair + (skip-whitespace! rs) + (let ((tail (read-datum rs))) + (skip-whitespace! rs) + (let ((ch3 (reader-next! rs))) + (unless (and (char? ch3) (char=? ch3 close-char)) + (error 'jerboa-read "expected closing delimiter after dot"))) + (let build ((items acc) (result tail)) + (if (null? items) result + (build (cdr items) (cons (car items) result)))))) + (else + ;; Symbol starting with . + (reader-state-peeked-set! rs ch2) + (let ((loc (reader-location rs))) + (let ((sym (read-symbol-chars rs #\.))) + (loop (cons (annotate rs sym loc) acc)))))))) + (else + (let ((datum (read-datum rs))) + (if (eof-object? datum) + (error 'jerboa-read "unterminated list") + (loop (cons datum acc))))))))))) + + ;; Handle #| and #; comments inside lists. + (define (handle-hash-comments! rs) + (let ((ch (reader-peek rs))) + (if (and (char? ch) (char=? ch #\#)) + (let ((loc (reader-location rs))) + (reader-next! rs) + (let ((ch2 (reader-peek rs))) + (cond + ((and (char? ch2) (char=? ch2 #\|)) + (reader-next! rs) + (skip-block-comment! rs 1) + (skip-whitespace! rs) + (handle-hash-comments! rs)) + ((and (char? ch2) (char=? ch2 #\;)) + (reader-next! rs) + (skip-whitespace! rs) + (read-datum rs) ;; discard + (skip-whitespace! rs) + (handle-hash-comments! rs)) + (else + (read-hash rs loc))))) + #f))) + + ;;;; Hash dispatch (#) + + (define (read-hash rs loc) + (let ((ch (reader-peek rs))) + (cond + ((eof-object? ch) (error 'jerboa-read "unexpected EOF after #")) + + ;; #t, #f, #true, #false + ((or (char=? ch #\t) (char=? ch #\T)) + (reader-next! rs) + (let ((ch2 (reader-peek rs))) + (cond + ((or (eof-object? ch2) (delimiter? ch2)) + (annotate rs #t loc)) + ((char-alphabetic? ch2) + (let ((rest (read-symbol-chars rs #\t))) + (if (memq rest '(true True TRUE)) + (annotate rs #t loc) + (error 'jerboa-read "invalid # syntax" rest)))) + (else (annotate rs #t loc))))) + + ((or (char=? ch #\f) (char=? ch #\F)) + (reader-next! rs) + (let ((ch2 (reader-peek rs))) + (cond + ((or (eof-object? ch2) (delimiter? ch2)) + (annotate rs #f loc)) + ((char-alphabetic? ch2) + (let ((rest (read-symbol-chars rs #\f))) + (if (memq rest '(false False FALSE)) + (annotate rs #f loc) + (error 'jerboa-read "invalid # syntax" rest)))) + (else (annotate rs #f loc))))) + + ;; #( vector + ((char=? ch #\() + (reader-next! rs) + (let ((items (read-list rs #\)))) + (annotate rs (list->vector items) loc))) + + ;; #u8( bytevector + ((char=? ch #\u) + (reader-next! rs) + (let ((ch2 (reader-next! rs))) + (unless (and (char? ch2) (char=? ch2 #\8)) + (error 'jerboa-read "expected #u8(")) + (let ((ch3 (reader-next! rs))) + (unless (and (char? ch3) (char=? ch3 #\()) + (error 'jerboa-read "expected #u8(")) + (let ((items (read-list rs #\)))) + (let ((raw-items (map (lambda (x) + (if (annotated-datum? x) + (annotated-datum-value x) + x)) + items))) + (annotate rs (apply bytevector raw-items) loc)))))) + + ;; #\ character + ((char=? ch #\\) + (reader-next! rs) + (annotate rs (read-character rs) loc)) + + ;; #! hash-bang + ((char=? ch #\!) + (reader-next! rs) + (read-hash-bang rs loc)) + + ;; #| block comment + ((char=? ch #\|) + (reader-next! rs) + (skip-block-comment! rs 1) + (read-datum rs)) + + ;; #; datum comment + ((char=? ch #\;) + (reader-next! rs) + (skip-whitespace! rs) + (read-datum rs) ;; discard + (read-datum rs)) ;; read real + + ;; #& box + ((char=? ch #\&) + (reader-next! rs) + (annotate rs (box (read-datum rs)) loc)) + + ;; #' syntax quote + ((char=? ch #\') + (reader-next! rs) + (annotate rs (list 'syntax (read-datum rs)) loc)) + + ;; #` syntax quasiquote + ((char=? ch #\`) + (reader-next! rs) + (annotate rs (list 'quasisyntax (read-datum rs)) loc)) + + ;; #, syntax unquote + ((char=? ch #\,) + (reader-next! rs) + (let ((ch2 (reader-peek rs))) + (if (and (char? ch2) (char=? ch2 #\@)) + (begin + (reader-next! rs) + (annotate rs (list 'unsyntax-splicing (read-datum rs)) loc)) + (annotate rs (list 'unsyntax (read-datum rs)) loc)))) + + ;; #x hex, #o octal, #b binary, #d decimal number + ((or (char=? ch #\x) (char=? ch #\X)) + (reader-next! rs) + (let ((str (read-number-chars rs))) + (annotate rs (string->number (string-append "#x" str)) loc))) + + ((or (char=? ch #\o) (char=? ch #\O)) + (reader-next! rs) + (let ((str (read-number-chars rs))) + (annotate rs (string->number (string-append "#o" str)) loc))) + + ((or (char=? ch #\b) (char=? ch #\B)) + (reader-next! rs) + (let ((str (read-number-chars rs))) + (annotate rs (string->number (string-append "#b" str)) loc))) + + ((or (char=? ch #\d) (char=? ch #\D)) + (reader-next! rs) + (let ((str (read-number-chars rs))) + (annotate rs (string->number (string-append "#d" str)) loc))) + + ;; #< heredoc string (#<<DELIM ... DELIM) + ((char=? ch #\<) + (reader-next! rs) + (let ((ch2 (reader-peek rs))) + (if (and (char? ch2) (char=? ch2 #\<)) + (begin + (reader-next! rs) + (let ((delim (let dloop ((chars '())) + (let ((c (reader-peek rs))) + (cond + ((or (eof-object? c) (char=? c #\newline) (char=? c #\return)) + (when (and (char? c) (or (char=? c #\newline) (char=? c #\return))) + (reader-next! rs) + (when (char=? c #\return) + (let ((c2 (reader-peek rs))) + (when (and (char? c2) (char=? c2 #\newline)) + (reader-next! rs))))) + (list->string (reverse chars))) + (else + (reader-next! rs) + (dloop (cons c chars)))))))) + (define (build-heredoc-result lines) + (annotate rs + (let ((all (reverse lines))) + (if (null? all) "" + (let lp ((strs all) (acc (car all))) + (if (null? (cdr strs)) acc + (lp (cdr strs) + (string-append acc "\n" (cadr strs))))))) + loc)) + (let hloop ((lines '())) + (let lloop ((chars '())) + (let ((c (reader-next! rs))) + (cond + ((eof-object? c) + ;; Check if accumulated chars match delimiter + (let ((line (list->string (reverse chars)))) + (if (string=? line delim) + (build-heredoc-result lines) + (error 'jerboa-read "unterminated heredoc")))) + ((or (char=? c #\newline) (char=? c #\return)) + (when (char=? c #\return) + (let ((c2 (reader-peek rs))) + (when (and (char? c2) (char=? c2 #\newline)) + (reader-next! rs)))) + (let ((line (list->string (reverse chars)))) + (if (string=? line delim) + (build-heredoc-result lines) + (hloop (cons line lines))))) + (else + (lloop (cons c chars))))))))) + (error 'jerboa-read "invalid # dispatch" ch)))) + + (else + (error 'jerboa-read "invalid # dispatch" ch))))) + + ;; Read chars that could be part of a number literal + (define (read-number-chars rs) + (let loop ((acc '())) + (let ((ch (reader-peek rs))) + (if (and (char? ch) + (or (char-numeric? ch) + (and (char>=? ch #\a) (char<=? ch #\f)) + (and (char>=? ch #\A) (char<=? ch #\F)) + (char=? ch #\+) (char=? ch #\-))) + (begin (reader-next! rs) (loop (cons ch acc))) + (list->string (reverse acc)))))) + + ;;;; Hash-bang reader + + (define (read-hash-bang rs loc) + (let ((ch (reader-peek rs))) + (cond + ((or (eof-object? ch) (delimiter? ch)) + (error 'jerboa-read "incomplete #!")) + (else + (let ((name (read-hash-bang-name rs))) + (case name + ((void) (annotate rs (void) loc)) + ((eof) (annotate rs (eof-object) loc)) + ((optional) (annotate rs (void) loc)) ; placeholder + (else + (annotate rs (list (string->symbol "#!") name) loc)))))))) + + (define (read-hash-bang-name rs) + (let loop ((chars '())) + (let ((ch (reader-peek rs))) + (cond + ((or (eof-object? ch) (delimiter? ch)) + (string->symbol (list->string (reverse chars)))) + (else + (reader-next! rs) + (loop (cons ch chars))))))) + + ;;;; Character reader + + (define (read-character rs) + (let ((ch (reader-next! rs))) + (cond + ((eof-object? ch) (error 'jerboa-read "unexpected EOF in character")) + ((or (eof-object? (reader-peek rs)) (delimiter? (reader-peek rs))) + ch) + (else + (let loop ((chars (list ch))) + (let ((ch2 (reader-peek rs)))