build: convert raw-Chez .sls library source to src/ .ss with generated .sls wrappers
ober
99fec52692bd9ad82d24ba1c5e4b387ff07c23ba
--- a/Makefile +++ b/Makefile @@ -263,11 +263,15 @@ $(SCHEME): vendor/ChezScheme/configure $(MAKE) -C $(CHEZ_BUILD_DIR) install test -x $(SCHEME) -build: chez +build: chez transpile @mkdir -p build JERBOA_BUILD_GENSYM_PREFIX_FILE=$(CURDIR)/build/jerboa-build-gensym-prefix.txt \ $(SCHEME) --libdirs $(LIBDIRS) --script support/build.ss +# Generate R6RS .sls wrappers from src/ .ss source. +transpile: + python3 support/wrap-ss-to-sls.py src lib + # Build a self-contained Jerboa binary that bundles petite.boot, scheme.boot, # and a WPO-compiled entry program. Output: ./jerboa-bin # Override entry script with BINARY_ENTRY=path/to/script.ss deleted file mode 100644 --- a/lib/jerboa/core.sls +++ /dev/null @@ -1,1280 +0,0 @@ -#!chezscheme -;;; core.sls -- Gerbil-compatible syntax macros for Chez Scheme -;;; -;;; Implements: def, defstruct, defclass, defmethod, defrule, defrules, -;;; match, try/catch/finally, when, unless, while, until, -;;; hash, hash-eq, let-hash - -(library (jerboa core) - (export - ;; definitions - def def* defrule defrules - - ;; struct/class/method - defstruct defclass defmethod - - ;; pattern matching - match - - ;; control flow - try catch finally - while until - - ;; hash constructors - hash hash-eq - hash-literal hash-eq-literal - let-hash - - ;; struct export helper - struct-out - - ;; Gerbil compat I/O and filesystem - read-line - read-string - getenv - - ;; I/O compat - force-output - - ;; Thread + mutex (re-exported from :std/misc/thread) - spawn spawn/name spawn/group - make-thread thread-start! thread-join! - thread-yield! thread-sleep! current-thread thread-name - thread? thread-specific thread-specific-set! - thread-interrupt! thread-terminate! - make-mutex make-mutex-gambit mutex? mutex-name - mutex-lock! mutex-unlock! mutex-specific mutex-specific-set! - make-condition-variable condition-variable? - condition-variable-signal! condition-variable-broadcast! - condition-variable-specific condition-variable-specific-set! - thread-send thread-receive thread-mailbox-next - thread-done? - - ;; Path utilities (re-exported from :std/os/path) - path-expand path-normalize path-directory - path-strip-directory path-extension path-strip-extension - path-strip-trailing-directory-separator - path-join path-absolute? - with-exception-catcher - create-directory create-directory* - file-info file-info-type file-info-size file-info-mode - file-info-last-modification-time file-info-last-access-time - file-info-device file-info-inode file-info-owner file-info-group - directory-files - - ;; re-export runtime - ~ bind-method! call-method - make-hash-table make-hash-table-eq - hash-ref hash-get hash-put! hash-update! hash-remove! - hash-key? hash->list hash->plist hash-for-each hash-map hash-fold - hash-find hash-keys hash-values hash-copy hash-clear! - hash-merge hash-merge! hash-length hash-table? - list->hash-table plist->hash-table - keyword? keyword->string string->keyword make-keyword - keyword-arg-ref - error-message error-irritants error-trace - display-exception display-continuation-backtrace - string-split string-empty? string-subst random-integer copy-file setenv - user-info user-info-home user-name - read-u8 write-u8 - f64vector-ref f64vector-set! f64vector-length make-f64vector - input-port-timeout-set! output-port-timeout-set! - u8vector u8vector-ref u8vector-set! u8vector-length u8vector->list list->u8vector - subu8vector string->bytes bytes->string - getpid random-bytes object->string - filter-map - displayln 1+ 1- - arithmetic-shift - any every - time->seconds - open-process open-input-process process-status - string-map take drop delete last - call-with-input-string call-with-output-string - iota last-pair - *method-tables* - register-struct-type! *struct-types* - struct-predicate struct-field-ref struct-field-set! - struct-type-info) - - (import (except (chezscheme) - make-hash-table hash-table? - iota 1+ 1- - getenv ;; shadowed by our variadic wrapper - path-extension path-absolute? ;; provided by (std os path) - thread? ;; shadowed by (std misc thread) - make-mutex mutex? mutex-name) ;; wrapped by (std misc thread) - (rename (only (chezscheme) getenv) (getenv %chez-getenv)) - (jerboa runtime) - (std os path) - (std misc thread) - (only (std misc string) string-split string-empty?) - (only (std misc list) filter-map) - (only (std contract condition) raise-contract-violation) - (only (std typed) check-type! check-return-type!)) - - ;;;; ---- Compile-time helpers ---- - - (meta define (keyword-sym? sym) - ;; Check if a symbol looks like a keyword arg: ends with ':' - (and (symbol? sym) - (let ([s (symbol->string sym)]) - (and (> (string-length s) 1) - (char=? (string-ref s (- (string-length s) 1)) #\:))))) - - (meta define (has-keywords? params) - ;; Check if param list contains keyword: (var default) patterns - (cond - [(null? params) #f] - [(not (pair? params)) #f] - [(keyword-sym? (car params)) #t] - [else (has-keywords? (cdr params))])) - - (meta define (has-optionals? params) - (cond - [(null? params) #f] - [(not (pair? params)) #f] ; rest arg (symbol) = no optionals here - [(keyword-sym? (car params)) #t] ; keyword args count as optionals - [(pair? (car params)) #t] - [else (has-optionals? (cdr params))])) - - (meta define (split-params params) - ;; Returns (values required optionals rest-arg keywords) - ;; keywords is a list of (keyword-symbol var-name default) - (let loop ([rest params] [req '()] [opt '()] [kw '()]) - (cond - [(null? rest) (values (reverse req) (reverse opt) #f (reverse kw))] - [(symbol? rest) (values (reverse req) (reverse opt) rest (reverse kw))] - ;; keyword: (var default) pattern - [(and (keyword-sym? (car rest)) (pair? (cdr rest)) (pair? (cadr rest))) - (let* ([kw-sym (car rest)] - [kw-str (symbol->string kw-sym)] - [kw-name (substring kw-str 0 (- (string-length kw-str) 1))] - [binding (cadr rest)] - [var-name (car binding)] - [default (cadr binding)]) - (loop (cddr rest) req opt - (cons (list (string->symbol kw-name) var-name default) kw)))] - [(pair? (car rest)) - (loop (cdr rest) req (cons (car rest) opt) kw)] - [else - (if (and (null? opt) (null? kw)) - (loop (cdr rest) (cons (car rest) req) opt kw) - (loop (cdr rest) req (cons (list (car rest) #f) opt) kw))]))) - - (meta define (meta-take lst n) - (if (or (zero? n) (null? lst)) '() - (cons (car lst) (meta-take (cdr lst) (- n 1))))) - - (meta define (meta-drop lst n) - (if (or (zero? n) (null? lst)) lst - (meta-drop (cdr lst) (- n 1)))) - - (meta define (generate-keyword-clause name-stx required optionals keywords body-stx) - ;; Generate a single clause: (req1 req2 ... . kwargs) - ;; with a single-pass keyword extractor binding all kw vars at once. - ;; - ;; Before: k calls to keyword-arg-ref, each doing an independent linear - ;; scan of %kwargs — O(k * len(%kwargs)) work, k allocations. - ;; After: one named loop walks %kwargs once, dispatching to eq? arms, - ;; and each arm rebuilds the loop args with the matched position - ;; updated to (cadr rest) and all other positions passed through. - ;; Common case (no kwargs at all) short-circuits on the (null? rest) - ;; cond-head. - (let* ([all-positional (append required (map car optionals))] - [kw-var-names (map cadr keywords)] - [kw-defaults (map caddr keywords)] - [kw-key-syms (map (lambda (kw) - (string->symbol - (string-append (symbol->string (car kw)) ":"))) - keywords)] - [loop-sym '%kw-loop] - [rest-sym '%kw-rest] - ;; Build match arms as raw datums: one per keyword. - ;; Arm i: ((eq? (car %kw-rest) 'kw-i:) - ;; (%kw-loop (cddr %kw-rest) kv0 ... (cadr %kw-rest) ... kvN)) - [arms - (let loop ([i 0] [ks kw-key-syms] [acc '()]) - (cond - [(null? ks) (reverse acc)] - [else - (let ([arm - (list - (list 'eq? (list 'car rest-sym) (list 'quote (car ks))) - (cons loop-sym - (cons (list 'cddr rest-sym) - (let upd ([j 0] [vars kw-var-names]) - (cond - [(null? vars) '()] - [(= j i) - (cons (list 'cadr rest-sym) (upd (+ j 1) (cdr vars)))] - [else - (cons (car vars) (upd (+ j 1) (cdr vars)))])))))]) - (loop (+ i 1) (cdr ks) (cons arm acc)))]))] - ;; Default (no-match) arm: skip two items, keep all kv's. - [skip-arm - (list 'else - (cons loop-sym - (cons (list 'cddr rest-sym) kw-var-names)))] - ;; Base cond arms (null? / odd-length check). - [base-arms - (list - (list (list 'null? rest-sym) (cons 'let (cons '() (syntax->datum body-stx)))) - (list (list 'null? (list 'cdr rest-sym)) - (list 'error - (list 'quote 'keyword-arg-ref) - "odd number of keyword arguments (missing value for last key)" - (list 'car rest-sym))))] - ;; Full body: named let with initial kv=defaults, then cond. - [loop-body - (list 'let loop-sym - (cons (list rest-sym '%kwargs) - (map (lambda (v d) (list v d)) kw-var-names kw-defaults)) - (cons 'cond (append base-arms arms (list skip-arm))))]) - (with-syntax ([(p ...) (datum->syntax name-stx all-positional)] - [rest-var (datum->syntax name-stx '%kwargs)] - [lb (datum->syntax name-stx loop-body)]) - (list #'((p ... . rest-var) lb))))) - - (meta define (generate-case-lambda-clauses name-stx params-stx body-stx) - (let ([params (syntax->datum params-stx)]) - (let-values ([(required optionals rest keywords) - (split-params params)]) - (if (not (null? keywords)) - ;; Keyword args: generate a single clause with rest arg + keyword parsing - (generate-keyword-clause name-stx required optionals keywords body-stx) - ;; Positional-only: original case-lambda logic - (let ([n-opt (length optionals)] - [all-names (append required (map car optionals))]) - (let ([full-clause - (with-syntax ([(p ...) (datum->syntax name-stx all-names)] - [(b ...) body-stx]) - #'((p ...) b ...))] - [partial-clauses - (let loop ([i 0] [clauses '()]) - (if (>= i n-opt) - (reverse clauses) - (let* ([present-opt (meta-take optionals i)] - [missing-opt (meta-drop optionals i)] - [clause-params (append required (map car present-opt))] - [defaults (map cadr missing-opt)] - [all-args (append clause-params defaults)]) - (with-syntax ([(p ...) (datum->syntax name-stx clause-params)] - [fn name-stx] - [(a ...) (datum->syntax name-stx all-args)]) - (loop (+ i 1) - (cons #'((p ...) (fn a ...)) clauses))))))]) - (append partial-clauses (list full-clause)))))))) - - (meta define (gen-struct-names name-sym fields-sym) - (let ([ns (symbol->string name-sym)]) - (values - (string->symbol (string-append ns "::t")) - (string->symbol (string-append "make-" ns)) - (string->symbol (string-append ns "?")) - (map (lambda (f) - (string->symbol (string-append ns "-" (symbol->string f)))) - fields-sym) - (map (lambda (f) - (string->symbol (string-append ns "-" (symbol->string f) "-set!"))) - fields-sym)))) - - (meta define (gen-struct-body name-stx fields-list type-id-stx make-id-stx - pred-id-stx acc-stxs mut-stxs idx-stxs) - ;; Generate accessor/mutator definitions as a list of syntax objects - (let loop ([as acc-stxs] [ms mut-stxs] [is idx-stxs] [defs '()]) - (if (null? as) - (reverse defs) - (loop (cdr as) (cdr ms) (cdr is) - (cons (with-syntax ([m (car ms)] [t type-id-stx] [i (car is)]) - #'(define m (record-mutator t i))) - (cons (with-syntax ([a (car as)] [t type-id-stx] [i (car is)]) - #'(define a (record-accessor t i))) - defs)))))) - - ;;;; ---- DEF ---- - - ;; Check if a datum looks like a contract/typed param: - ;; (name : type) checked type - ;; (name :? type) checked nullable type - ;; (name :- type) unchecked assertion - ;; (name :~ pred) checked predicate contract - (meta define (typed-param? p) - (and (pair? p) - (pair? (cdr p)) - (pair? (cddr p)) - (null? (cdddr p)) - (symbol? (car p)) - (memq (cadr p) '(: :? :- :~)))) - - ;; Check if any param in the list is typed - (meta define (has-typed-params? params) - (cond - [(null? params) #f] - [(not (pair? params)) #f] - [(typed-param? (car params)) #t] - [else (has-typed-params? (cdr params))])) - - ;; Extract just the arg names from a mixed typed/untyped param list - (meta define (extract-arg-names params) - (map (lambda (p) - (if (typed-param? p) (car p) p)) - params)) - - ;; Extract typed params as list of (name op spec) triples. - (meta define (extract-typed-params params) - (let loop ([rest params] [acc '()]) - (cond - [(null? rest) (reverse acc)] - [(typed-param? (car rest)) - (loop (cdr rest) - (cons (list (caar rest) (cadar rest) (caddar rest)) acc))] - [else (loop (cdr rest) acc)]))) - - (meta define (contract-check-form who ta) - (let ([aname (car ta)] - [op (cadr ta)] - [spec (caddr ta)]) - (case op - [(:) - `(check-type! ',who ',aname ,aname ',spec)] - [(:?) - `(when ,aname - (check-type! ',who ',aname ,aname ',spec))] - [(:-) - '(void)] - [(:~) - `(unless (,spec ,aname) - (raise-contract-violation ',who - "argument ~a failed predicate contract for ~s" - ',aname ,aname))] - [else - '(void)]))) - - (define-syntax def - (lambda (stx) - (syntax-case stx () - ;; Typed def with return type: (def (name (x : fixnum) y) : ret-type body ...) - [(_ (name . params) colon ret-type body ...) - (and (identifier? #'name) - (eq? (syntax->datum #'colon) ':) - (let ([pl (syntax->datum #'params)]) - (and (list? pl) (has-typed-params? pl)))) - (let* ([params-list (syntax->datum #'params)] - [arg-names (extract-arg-names params-list)] - [typed (extract-typed-params params-list)] - [checks (map (lambda (ta) - (contract-check-form (syntax->datum #'name) ta)) - typed)]) - (with-syntax ([(arg ...) (datum->syntax #'name arg-names)] - [(chk ...) (datum->syntax #'name checks)]) - #'(define (name arg ...) - chk ... - (let ([result (begin body ...)]) - (check-return-type! 'name result 'ret-type) - result))))] - - ;; Typed def without return type: (def (name (x : fixnum) y) body ...) - [(_ (name . params) body ...) - (and (identifier? #'name) - (let ([pl (syntax->datum #'params)]) - (and (list? pl) (has-typed-params? pl)))) - (let* ([params-list (syntax->datum #'params)] - [arg-names (extract-arg-names params-list)] - [typed (extract-typed-params params-list)] - [checks (map (lambda (ta) - (contract-check-form (syntax->datum #'name) ta)) - typed)]) - (with-syntax ([(arg ...) (datum->syntax #'name arg-names)] - [(chk ...) (datum->syntax #'name checks)]) - #'(define (name arg ...) - chk ... - body ...)))] - - ;; Original: plain function def - [(_ (name . params) body ...) - (identifier? #'name) - (let ([params-list (syntax->datum #'params)]) - (if (has-optionals? params-list) - (with-syntax ([(clause ...) (generate-case-lambda-clauses - #'name #'params #'(body ...))]) - #'(define name (case-lambda clause ...))) - #'(define (name . params) body ...)))] - [(_ name expr) - (identifier? #'name) - #'(define name expr)] - [(_ name) - (identifier? #'name) - #'(define name (void))]))) - - ;;;; ---- DEF* (case-lambda) ---- - - (define-syntax def* - (syntax-rules () - [(_ name clause ...) - (define name (case-lambda clause ...))])) - - ;;;; ---- DEFRULE / DEFRULES ---- - - (define-syntax defrule - (syntax-rules () - [(_ (name . pattern) template) - (define-syntax name - (syntax-rules () - [(_ . pattern) template]))])) - - (define-syntax defrules - (syntax-rules () - [(_ name (keywords ...) clause ...) - (define-syntax name - (syntax-rules (keywords ...) - clause ...))])) - - ;;;; ---- DEFSTRUCT ---- - - (define-syntax defstruct - (lambda (stx) - (syntax-case stx () - [(_ name (field ...)) - (identifier? #'name) - (let* ([name-sym (syntax->datum #'name)] - [fields-list (syntax->datum #'(field ...))] - [ns (symbol->string name-sym)]) - (let-values ([(type-id make-id pred-id accs muts) - (gen-struct-names name-sym fields-list)]) - ;; Generate internal accessor/mutator names to avoid conflicts - (let ([int-accs (map (lambda (f) - (gensym (string-append ns "-" (symbol->string f)))) - fields-list)] - [int-muts (map (lambda (f) - (gensym (string-append ns "-" (symbol->string f) "-set!"))) - fields-list)]) - (with-syntax ([tid (datum->syntax #'name type-id)] - [mid (datum->syntax #'name make-id)] - [pid (datum->syntax #'name pred-id)] - [rcd-id (datum->syntax #'name - (string->symbol (string-append ns "-rcd")))] - [(acc ...) (datum->syntax #'name accs)] - [(mut ...) (datum->syntax #'name muts)] - [(idx ...) (datum->syntax #'name - (iota (length fields-list)))] - [(iacc ...) (datum->syntax #'name int-accs)] - [(imut ...) (datum->syntax #'name int-muts)] - [hidden-name (datum->syntax #'name - (gensym (symbol->string name-sym)))]) - #'(begin - (define-record-type (hidden-name mid pid) - (fields (mutable field iacc imut) ...)) - (define tid (record-type-descriptor hidden-name)) - (define rcd-id (record-constructor-descriptor hidden-name)) - (define acc iacc) ... - (define mut imut) ...)))))] - [(_ (name parent) (field ...)) - (and (identifier? #'name) (identifier? #'parent)) - (let* ([name-sym (syntax->datum #'name)] - [parent-sym (syntax->datum #'parent)] - [fields-list (syntax->datum #'(field ...))] - [ns (symbol->string name-sym)]) - (let-values ([(type-id make-id pred-id accs muts) - (gen-struct-names name-sym fields-list)]) - (let ([int-accs (map (lambda (f) - (gensym (string-append ns "-" (symbol->string f)))) - fields-list)] - [int-muts (map (lambda (f) - (gensym (string-append ns "-" (symbol->string f) "-set!"))) - fields-list)]) - (with-syntax ([tid (datum->syntax #'name type-id)] - [mid (datum->syntax #'name make-id)] - [pid (datum->syntax #'name pred-id)] - [rcd-id (datum->syntax #'name - (string->symbol (string-append ns "-rcd")))] - [parent-tid (datum->syntax #'parent - (string->symbol - (string-append (symbol->string parent-sym) "::t")))] - [parent-rcd-id (datum->syntax #'parent - (string->symbol - (string-append (symbol->string parent-sym) "-rcd")))] - [(acc ...) (datum->syntax #'name accs)] - [(mut ...) (datum->syntax #'name muts)] - [(idx ...) (datum->syntax #'name - (iota (length fields-list)))] - [(iacc ...) (datum->syntax #'name int-accs)] - [(imut ...) (datum->syntax #'name int-muts)] - [hidden-name (datum->syntax #'name - (gensym (symbol->string name-sym)))]) - #'(begin - (define-record-type (hidden-name mid pid) - (parent-rtd parent-tid parent-rcd-id) - (fields (mutable field iacc imut) ...)) - (define tid (record-type-descriptor hidden-name)) - (define rcd-id (record-constructor-descriptor hidden-name)) - (define acc iacc) ... - (define mut imut) ...)))))] - ;; Keyword options: warn about unsupported ones, handle what we can. - ;; Supported: transparent: #t (makes record non-opaque, visible to inspector) - ;; Unsupported: final:, opaque:, print: etc. — raise error instead of silently dropping. - [(_ name (field ...) kw val rest ...) - (let ([key (syntax->datum #'kw)]) - (unless (memq key '(transparent: final: opaque: print: equal: constructor:)) - (syntax-violation 'defstruct - (format "unknown keyword option: ~a" key) #'kw)) - (when (memq key '(final: print: equal: constructor:)) - (syntax-violation 'defstruct - (format "keyword ~a is not supported in Jerboa defstruct (Chez R6RS limitation)" key) - #'kw)) - ;; transparent: and opaque: are accepted — Chez records don't use - ;; hidden names in transparent mode (but our hidden-name approach - ;; already makes fields accessible via accessors, so this is informational). - #'(defstruct name (field ...)))] - [(_ (name parent) (field ...) kw val rest ...) - (let ([key (syntax->datum #'kw)]) - (unless (memq key '(transparent: final: opaque: print: equal: constructor:)) - (syntax-violation 'defstruct - (format "unknown keyword option: ~a" key) #'kw)) - (when (memq key '(final: print: equal: constructor:)) - (syntax-violation 'defstruct - (format "keyword ~a is not supported in Jerboa defstruct (Chez R6RS limitation)" key) - #'kw)) - #'(defstruct (name parent) (field ...)))]))) - - ;;;; ---- DEFCLASS ---- - ;; NOTE: defclass in Jerboa maps to defstruct (single inheritance via Chez records). - ;; Gerbil's defclass supports multiple inheritance and mixins — these are NOT supported. - ;; Using multiple parents will raise an error. - - (define-syntax defclass - (lambda (stx) - (syntax-case stx () - [(_ (name parent) (field ...) rest ...) - #'(defstruct (name parent) (field ...))] - [(_ (name parent1 parent2 . more-parents) (field ...) rest ...) - (syntax-violation 'defclass - "multiple inheritance is not supported in Jerboa (use single parent only)" - stx)] - [(_ name (field ...) rest ...) - #'(defstruct name (field ...))]))) - - ;;;; ---- DEFMETHOD ---- - - (define-syntax defmethod - (lambda (stx) - (syntax-case stx () - [(_ (method-name (self type) arg ...) body ...) - (and (identifier? #'method-name) - (identifier? #'self) - (identifier? #'type)) - (with-syntax ([type-rtd (datum->syntax #'type - (string->symbol - (string-append - (symbol->string (syntax->datum #'type)) - "::t")))]) - #'(bind-method! type-rtd 'method-name - (lambda (self arg ...) body ...)))]))) - - ;;;; ---- MATCH ---- - ;; Single procedural macro to avoid hygiene issues across macro boundaries - - (meta define (compile-match-pattern tmp-stx pat-stx success-stx fail-stx) - (let ([pat (syntax->datum pat-stx)]) - (cond - ;; Wildcard - [(eq? pat '_) success-stx] - - ;; Null (empty list) - [(null? pat) - #`(if (null? #,tmp-stx) #,success-stx #,fail-stx)] - - ;; Boolean/number/string/char literal - [(or (boolean? pat) (number? pat) (string? pat) (char? pat)) - #`(if (equal? #,tmp-stx #,pat-stx) #,success-stx #,fail-stx)] - - ;; Symbol = variable binding - [(symbol? pat) - #`(let ([#,pat-stx #,tmp-stx]) #,success-stx)] - - ;; List patterns - [(pair? pat) - (let ([head (car pat)]) - (cond - ;; (quote x) - [(eq? head 'quote) - #`(if (equal? #,tmp-stx #,pat-stx) #,success-stx #,fail-stx)] - - ;; (list p ...) - [(eq? head 'list) - (let ([pats (cdr (syntax->list pat-stx))] - [n (length (cdr pat))]) - (let ([check-body - (let loop ([ps pats] [idx 0]) - (if (null? ps) - success-stx - (let ([elem (datum->syntax tmp-stx (gensym "elem"))]) - #`(let ([#,elem (list-ref #,tmp-stx #,idx)]) - #,(compile-match-pattern elem (car ps) - (loop (cdr ps) (+ idx 1)) - fail-stx)))))]) - #`(if (and (list? #,tmp-stx) (= (length #,tmp-stx) #,n)) - #,check-body - #,fail-stx)))] - - ;; (cons a b) - [(eq? head 'cons) - (let ([parts (syntax->list pat-stx)]) - (let ([a-pat (cadr parts)] - [b-pat (caddr parts)] - [hd (datum->syntax tmp-stx (gensym "hd"))] - [tl (datum->syntax tmp-stx (gensym "tl"))]) - (let ([inner (compile-match-pattern hd a-pat - (compile-match-pattern tl b-pat success-stx fail-stx) - fail-stx)]) - #`(if (pair? #,tmp-stx) - (let ([#,hd (car #,tmp-stx)] [#,tl (cdr #,tmp-stx)]) - #,inner) - #,fail-stx))))] - - ;; (? pred) or (? pred var) - [(eq? head '?) - (let ([parts (syntax->list pat-stx)]) - (if (= (length parts) 2) - ;; (? pred) - (let ([pred (cadr parts)]) - #`(if (#,pred #,tmp-stx) #,success-stx #,fail-stx)) - ;; (? pred var) - (let ([pred (cadr parts)] - [var (caddr parts)]) - #`(if (#,pred #,tmp-stx) - (let ([#,var #,tmp-stx]) #,success-stx) - #,fail-stx))))] - - ;; (and p1 p2 ...) - [(eq? head 'and) - (let ([parts (cdr (syntax->list pat-stx))]) - (if (null? parts) success-stx - (let loop ([ps parts]) - (if (null? (cdr ps)) - (compile-match-pattern tmp-stx (car ps) success-stx fail-stx) - (compile-match-pattern tmp-stx (car ps) - (loop (cdr ps)) - fail-stx)))))] - - ;; (or p1 p2 ...) - [(eq? head 'or) - (let ([parts (cdr (syntax->list pat-stx))]) - (if (null? parts) fail-stx - (let loop ([ps parts]) - (if (null? (cdr ps)) - (compile-match-pattern tmp-stx (car ps) success-stx fail-stx) - (compile-match-pattern tmp-stx (car ps) - success-stx - (loop (cdr ps)))))))] - - ;; (not p) - [(eq? head 'not) - (let ([parts (syntax->list pat-stx)]) - (compile-match-pattern tmp-stx (cadr parts) fail-stx success-stx))] - - ;; Pair pattern (a . b) — cons destructuring - [else - (let ([hd (datum->syntax tmp-stx (gensym "hd"))] - [tl (datum->syntax tmp-stx (gensym "tl"))]) - ;; Use syntax-case to destructure the pair pattern - (syntax-case pat-stx () - [(a-pat . b-pat) - (let ([inner (compile-match-pattern hd #'a-pat - (compile-match-pattern tl #'b-pat success-stx fail-stx) - fail-stx)]) - #`(if (pair? #,tmp-stx) - (let ([#,hd (car #,tmp-stx)] [#,tl (cdr #,tmp-stx)]) - #,inner) - #,fail-stx))]))]))] - - ;; Vector pattern - [(vector? pat) - #`(error 'match "vector patterns are not supported yet")] - - ;; Fallthrough - [else fail-stx]))) - - (meta define (compile-match-clauses tmp-stx clauses) - (if (null? clauses) - #`(error 'match "no matching pattern" #,tmp-stx) - (let ([clause (car clauses)] - [rest (cdr clauses)]) - (let ([parts (syntax->list clause)]) - (let ([pat (car parts)] - [body (cdr parts)]) - (if (eq? 'else (syntax->datum pat)) - ;; else clause - #`(begin #,@body) - ;; regular clause - (let ([fail (compile-match-clauses tmp-stx rest)]) - (compile-match-pattern tmp-stx pat - #`(begin #,@body) - fail)))))))) - - (define-syntax match - (lambda (stx) - (syntax-case stx () - [(k expr clause ...) - (let ([tmp (datum->syntax #'k (gensym "match-tmp"))]) - #`(let ([#,tmp expr]) - #,(compile-match-clauses tmp (syntax->list #'(clause ...)))))]))) - - ;;;; ---- TRY/CATCH/FINALLY ---- - - (define-syntax try - (lambda (stx) - (syntax-case stx (catch finally) - [(_ body ... (catch (pred var) handler ...) (finally cleanup ...)) - #'(dynamic-wind - (lambda () (void)) - (lambda () - (guard (var [(pred var) handler ...]) - body ...)) - (lambda () cleanup ...))] - [(_ body ... (catch (var) handler ...) (finally cleanup ...)) - #'(dynamic-wind - (lambda () (void)) - (lambda () - (guard (var [#t handler ...]) - body ...)) - (lambda () cleanup ...))] - [(_ body ... (catch (pred var) handler ...)) - #'(guard (var [(pred var) handler ...]) - body ...)] - [(_ body ... (catch (var) handler ...)) - #'(guard (var [#t handler ...]) - body ...)] - [(_ body ... (finally cleanup ...)) - #'(dynamic-wind - (lambda () (void)) - (lambda () body ...) - (lambda () cleanup ...))] - [(_ body ...) - #'(begin body ...)]))) - - (define-syntax catch - (lambda (stx) - (syntax-violation 'catch "catch used outside of try" stx))) - - (define-syntax finally - (lambda (stx) - (syntax-violation 'finally "finally used outside of try" stx))) - - ;;;; ---- WHILE/UNTIL ---- - - (define-syntax while - (syntax-rules () - [(_ test body ...) - (let loop () - (when test body ... (loop)))])) - - (define-syntax until - (syntax-rules () - [(_ test body ...) - (let loop () - (unless test body ... (loop)))])) - - ;;;; ---- HASH / HASH-EQ literals ---- - - (define-syntax hash-literal - (syntax-rules () - [(_ (key val) ...) - (let ([ht (make-hash-table)]) - (hash-put! ht 'key val) ... - ht)])) - - (define-syntax hash-eq-literal - (syntax-rules () - [(_ (key val) ...) - (let ([ht (make-hash-table-eq)]) - (hash-put! ht 'key val) ... - ht)])) - - ;;;; ---- LET-HASH ---- - - (define-syntax let-hash - (lambda (stx) - (syntax-case stx () - [(k ht-expr body ...) - ;; Use the let-hash keyword itself as the template for datum->syntax - ;; — it's always an identifier, regardless of what ht-expr is. This - ;; lets ht-expr be any expression, not just a bare identifier. - (with-syntax ([ht-var (datum->syntax #'k (gensym "ht"))]) - #'(let ([ht-var ht-expr]) - (let-hash-body ht-var body) ...))]))) - - ;; Single-pass walker: rewrites every .foo / .?foo / .$foo identifier in - ;; the syntax tree to a hash lookup against `ht`, leaving everything else - ;; structurally intact. Doing the substitution eagerly (instead of - ;; expanding into nested (let-hash-body ht ...) calls) keeps special-form - ;; identifiers — `or`, `and`, `when`, `if`, `let`, `lambda`, etc. — in - ;; operator position, so Chez can classify the form correctly. Quoted - ;; data is not traversed. - (define-syntax let-hash-body - (lambda (stx) - (syntax-case stx () - [(_ ht expr) - (let walk ([s #'expr]) - (let ([d (syntax->datum s)]) - (cond - [(and (symbol? d) - (let ([str (symbol->string d)]) - (and (> (string-length str) 1) - (char=? (string-ref str 0) #\.) - (not (char=? (string-ref str 1) #\.))))) - (let* ([str (symbol->string d)] - [func/key - (cond - [(and (> (string-length str) 2) - (char=? (string-ref str 1) #\?)) - (cons 'get (substring str 2 (string-length str)))] - [(and (> (string-length str) 2) - (char=? (string-ref str 1) #\$)) - (cons 'get-str (substring str 2 (string-length str)))] - [else - (cons 'ref (substring str 1 (string-length str)))])]) - (let ([func (car func/key)] - [key-name (cdr func/key)]) - (case func - [(ref) - (with-syntax ([key (datum->syntax s - (string->symbol key-name))]) - #'(hash-ref ht 'key))] - [(get) - (with-syntax ([key (datum->syntax s - (string->symbol key-name))]) - #'(hash-get ht 'key))] - [(get-str) - (with-syntax ([key (datum->syntax s key-name)]) - #'(hash-get ht key))])))] - [(and (pair? d) (eq? (car d) 'quote)) - ;; Don't traverse inside quoted data - s] - [(pair? d) - (with-syntax ([(item ...) (map walk (syntax->list s))]) - #'(item ...))] - [else s])))]))) - - ;;;; ---- HASH / HASH-EQ aliases ---- - ;; Gerbil uses (hash (k v) ...) directly; jerboa had hash-literal - (define-syntax hash - (syntax-rules () - [(_ (key val) ...) - (hash-literal (key val) ...)])) - - ;; hash-eq is already exported from runtime as a procedure. - ;; Re-define as a macro for the (hash-eq (k v) ...) literal form. - ;; The runtime version handles the (hash-eq) / (hash-eq pairs...) cases. - - ;;;; ---- STRUCT-OUT ---- - ;; (struct-out name) is used inside export forms in Gerbil. - ;; In jerboa, it's a compile-time expansion that cannot work inside - ;; R6RS (export ...) forms. Instead, provide it as a macro that - ;; expands to a begin with explicit definitions — this is a helper - ;; for generating manual export lists, not a true export-spec. - ;; - ;; Usage: call (struct-out-names 'typename) at the REPL to see what to export. - ;; The defstruct macro already defines make-X, X?, X-field, X-field-set! etc. - ;; Users just need to list them in their library's export form. - ;; - ;; For convenience in top-level programs (not libraries), struct-out - ;; is a no-op identity — the names are already bound. - (define-syntax struct-out - (syntax-rules () - [(_ name) (void)])) - - ;;;; ---- Gerbil compat: I/O ---- - ;; read-line: Gerbil-style (port is optional) - (define (read-line . args) - (let ([port (if (pair? args) (car args) (current-input-port))]) - (get-line port))) - - ;; getenv: Gerbil-style with optional default - ;; Wraps Chez's built-in getenv (aliased as %chez-getenv) to add optional default. - (define (getenv name . rest) - (or (%chez-getenv name) (if (pair? rest) (car rest) #f))) - - ;; with-exception-catcher: Gambit-style handler that catches and escapes. - ;; Uses call/cc so the handler's return value becomes the overall result, - ;; instead of re-raising (which with-exception-handler does). - (define (with-exception-catcher handler thunk) - (call-with-current-continuation - (lambda (k) - (with-exception-handler - (lambda (e) (k (handler e))) - thunk)))) - - ;;;; ---- Gerbil compat: Filesystem ---- - ;; create-directory: Gerbil alias for Chez mkdir - (define create-directory mkdir) - - ;; create-directory*: recursive mkdir -p - ;; Uses strict quoting to prevent shell injection via path names. - (define (create-directory* path) - (system (string-append "mkdir -p '" - (string-replace-simple path "'" "'\"'\"'") - "'"))) - - ;; file-info record type (using Chez fields syntax) - (define-record-type (file-info-rec make-file-info-rec file-info-rec?) - (fields - (immutable type file-info-type) - (immutable size file-info-size) - (immutable mode file-info-mode) - (immutable mtime file-info-last-modification-time))) - - (define (file-info-last-access-time fi) (file-info-last-modification-time fi)) - (define (file-info-device fi) 0) - (define (file-info-inode fi) 0) - (define (file-info-owner fi) 0) - (define (file-info-group fi) 0) - - ;; file-info: return a file-info-rec for the given path - ;; Uses stat(2) via Chez's file-stat when available, with POSIX fallback. - (define (file-info path . rest) - (let ([type (cond - [(file-directory? path) 'directory] - [(file-regular? path) 'regular] - [(file-symbolic-link? path) 'symbolic-link] - [else 'unknown])] - ;; Use Chez's built-in file-length for size (only works for regular files) - [size (guard (exn [#t 0]) - (if (file-regular? path) - (call-with-port (open-file-input-port path) - (lambda (p) (port-length p))) - 0))] - ;; Get modification time via Chez's file-modification-time (seconds since epoch) - [mtime (guard (exn [#t 0]) - (file-change-time path))]) - (make-file-info-rec type size 0 mtime))) - - ;; directory-files: list files in a directory (like Gambit's) - (define (directory-files path) - (directory-list path)) - - ;; read-string: Gerbil-style (n port) → read up to n chars from port - (define (read-string n . args) - (let ([port (if (pair? args) (car args) (current-input-port))]) - (get-string-n port n))) - - ;; force-output: Gerbil/Gambit alias for Chez flush-output-port - (define (force-output . args) - (let ([port (if (pair? args) (car args) (current-output-port))]) - (flush-output-port port))) - - ;; mutex-lock!/mutex-unlock! and thread functions are provided by (std misc thread) - - ;; display-exception: Gerbil/Gambit compat — display an exception to a port - ;; In Gerbil: (display-exception e [port]) — uses Chez display-condition equivalent - (define (display-exception e . args) - (let ([port (if (pair? args) (car args) (current-output-port))]) - (cond - [(condition? e) (display-condition e port)] - [else (display e port)]) - (newline port))) - - ;; display-continuation-backtrace: Gerbil/Gambit compat — no-op stub - ;; Gambit can display a continuation as a stack trace; Chez has no equivalent. - (define (display-continuation-backtrace k port) - (void))