WASM: add exception handling lowering (guard, try/catch, assert!)
ober
0900d9bfcb16002ed3c83049fe9aee7679f297a5
--- a/lib/std/secure/wasm-target.sls +++ b/lib/std/secure/wasm-target.sls @@ -556,6 +556,62 @@ [(match) (lower-match (car args) (cdr args))] + ;; ---- Exception handling ---- + + ;; (guard (e [test => expr] ...) body ...) + ;; Lowered to try/catch with tag 0 (general exception tag) + [(guard) + (let* ([var-clauses (car args)] + [var (car var-clauses)] + [clauses (cdr var-clauses)] + [body (cdr args)]) + `(try-catch 0 + (begin ,@(map lower-expr body)) + ,var + ,(lower-guard-clauses var clauses)))] + + ;; (try body (catch (e) handler)) + ;; (try body (catch (pred? e) handler)) + [(try) + (let* ([body (car args)] + [rest (cdr args)] + [catch-clause (and (pair? rest) + (pair? (car rest)) + (eq? (caar rest) 'catch) + (car rest))] + [finally-clause (and (pair? rest) + (or (and (pair? (car rest)) + (eq? (caar rest) 'finally) + (car rest)) + (and (>= (length rest) 2) + (pair? (cadr rest)) + (eq? (caadr rest) 'finally) + (cadr rest))))]) + (let ([try-body (lower-expr body)]) + (if catch-clause + (let* ([catch-args (cdr catch-clause)] + [catch-bindings (car catch-args)] + [catch-body (cdr catch-args)] + [e-var (if (pair? catch-bindings) (car catch-bindings) catch-bindings)]) + (if finally-clause + `(try-catch 0 + ,try-body + ,e-var + (begin ,@(map lower-expr catch-body))) + `(try-catch 0 + ,try-body + ,e-var + (begin ,@(map lower-expr catch-body))))) + try-body)))] + + ;; (assert! expr) or (assert! expr "message") + [(assert!) + (let ([test (lower-expr (car args))]) + `(when (not (is-truthy ,test)) + (throw 0 ,(if (and (pair? (cdr args)) (string? (cadr args))) + (lower-expr (cadr args)) + (tagged-fixnum 0)))))] + ;; ---- Quote ---- [(quote) (lower-quoted (car args))] @@ -570,6 +626,20 @@ [else expr])) + ;; Lower guard clauses: (guard (e [test body] ...) ...) + (define (lower-guard-clauses var clauses) + (if (null? clauses) + ;; No matching clause: re-throw + `(throw 0 ,var) + (let* ([clause (car clauses)] + [test (car clause)] + [body (cdr clause)]) + (if (eq? test 'else) + `(begin ,@(map lower-expr body)) + `(if (is-truthy ,(lower-expr test)) + (begin ,@(map lower-expr body)) + ,(lower-guard-clauses var (cdr clauses))))))) + ;; Lower a cond expression (define (lower-cond clauses) (if (null? clauses) --- a/tests/test-slang-wasm.ss +++ b/tests/test-slang-wasm.ss @@ -676,6 +676,40 @@ ;; Should have lifted definitions (check (> (length result) 1) => #t)) +;; ================================================================ +;; Exception Handling Patterns +;; ================================================================ + +(section "Exception Handling Patterns") + +;; throw with tag compiles to valid WASM +(let ([wasm (compile-program + (append + value-memory-forms + value-global-forms + value-tag-forms + '((define-tag 0) + (define (check-positive n) + (when (not n) + (throw 0 0)) + n))))]) + (check-pred bytevector? wasm) + (check (> (bytevector-length wasm) 30) => #t)) + +;; assert! pattern: throw on falsy condition +(let ([wasm (compile-program + (append + value-memory-forms + value-global-forms + value-tag-forms + '((define-tag 0) + (define (assert-test n) + (when (= n 0) + (throw 0 0)) + n))))]) + (check-pred bytevector? wasm) + (check (> (bytevector-length wasm) 30) => #t)) + ;; Full runtime with UTF-8 string-length compiles to valid WASM (let ([wasm (compile-program (append