let-hash: support special forms and binding forms in body
ober
7dcfddbca25addab8045fceffac031bba18e9d84
--- a/jerbuild.ss +++ b/jerbuild.ss @@ -608,7 +608,9 @@ ;; std/text/base64 exports base64-encode/decode (now also in Chez 10.4 core) ((std text base64) . (base64-encode base64-decode)) ;; jsh/util re-exports and overrides several chezscheme identifiers - ((jsh util) . (string-downcase string-upcase file-directory? file-regular?)))) + ((jsh util) . (string-downcase string-upcase file-directory? file-regular?)) + ;; std/datetime exports make-date and make-time (chezscheme also has them) + ((std datetime) . (make-date make-time)))) ;; Chez Scheme built-in names that may be redefined in user code. ;; Only these will be auto-excluded when a local definition shadows them. --- a/lib/jerboa/core.sls +++ b/lib/jerboa/core.sls @@ -763,56 +763,65 @@ (define-syntax let-hash (lambda (stx) (syntax-case stx () - [(_ ht-expr body ...) - (with-syntax ([ht-var (datum->syntax #'ht-expr (gensym "ht"))]) + [(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 ([datum (syntax->datum #'expr)]) - (cond - [(and (symbol? datum) - (let ([s (symbol->string datum)]) - (and (> (string-length s) 1) - (char=? (string-ref s 0) #\.) - (not (and (> (string-length s) 1) - (char=? (string-ref s 1) #\.)))))) - (let* ([s (symbol->string datum)] - [func/key - (cond - [(and (> (string-length s) 2) - (char=? (string-ref s 1) #\?)) - (cons 'get (substring s 2 (string-length s)))] - [(and (> (string-length s) 2) - (char=? (string-ref s 1) #\$)) - (cons 'get-str (substring s 2 (string-length s)))] - [else - (cons 'ref (substring s 1 (string-length s)))])]) - (let ([func (car func/key)] - [key-name (cdr func/key)]) - (case func - [(ref) - (with-syntax ([key (datum->syntax #'expr - (string->symbol key-name))]) - #'(hash-ref ht 'key))] - [(get) - (with-syntax ([key (datum->syntax #'expr - (string->symbol key-name))]) - #'(hash-get ht 'key))] - [(get-str) - (with-syntax ([key (datum->syntax #'expr key-name)]) - #'(hash-get ht key))])))] - [(pair? datum) - (with-syntax ([(transformed ...) - (map (lambda (sub) - (with-syntax ([s sub]) - #'(let-hash-body ht s))) - (syntax->list #'expr))]) - #'(transformed ...))] - [else #'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