diff --git a/doc/reference/std/sugar.md b/doc/reference/std/sugar.md index 5c270faa4..b97c41f3b 100644 --- a/doc/reference/std/sugar.md +++ b/doc/reference/std/sugar.md @@ -99,6 +99,27 @@ closed ``` ::: +## ignore-errors +```scheme +(ignore-errors body ...) +``` + +Evaluates body with an exception catcher that returns `#f` if an exception happened. +This is useful when attempting recovery side-effects on a “best effort” basis, +when trying out some user-specified computation that ought to return +something other than `#f` (or for which `#f` is otherwise a useful way to flag error), etc. + +::: tip Examples: +```scheme +> (ignore-errors 1 2 3) +3 +> (ignore-errors 1 (error "foo") 3) +#f +> (ignore-errors 1 2 #f) +#f +``` +::: + ## defmethod/alias ```scheme (defmethod/alias {method (alias ...) type} diff --git a/src/gerbil/expander/common.ss b/src/gerbil/expander/common.ss index 7bce7369c..082b0cca8 100644 --- a/src/gerbil/expander/common.ss +++ b/src/gerbil/expander/common.ss @@ -26,7 +26,7 @@ namespace: gx (generate1 hd #'pat #t #'body E)) ((pat fender body) (generate1 hd #'pat #'fender #'body E)) - (_ (raise-syntax-error #f "Bad syntax" stx hd)))) + (_ (raise-syntax-error #f "Bad syntax; invalid syntax-case pattern" stx hd)))) (def (generate1 where hd fender body E) (def (recur hd tgt K) @@ -79,7 +79,7 @@ namespace: gx [#'if #'(eql (stx-e target) 'datum) K E])) (else - (raise-syntax-error #f "Bad syntax" stx where hd)))))) + (raise-syntax-error #f "Bad syntax; invalid syntax-case head" stx where hd)))))) (recur hd tgt [#'if fender body E])) @@ -95,7 +95,7 @@ namespace: gx #'(lambda () (begin . body)) (stx-source #'hd))] r) - (raise-syntax-error #f "Bad syntax" stx #'hd)) + (raise-syntax-error #f "Bad syntax; invalid else body" stx #'hd)) (raise-syntax-error #f "Bad syntax; misplaced else" stx #'hd))) (_ (with-syntax* (($E (genident 'E)) @@ -108,7 +108,7 @@ namespace: gx (lp #'rest #'$E (cons [E #'try] r)))))) (_ (with-syntax ((target tgt)) (cons [E (stx-wrap-source - #'(lambda () (raise-syntax-error #f "Bad syntax" target)) + #'(lambda () (raise-syntax-error #f "Bad syntax; invalid syntax-case clause" target)) (stx-source stx))] r)))))) diff --git a/src/gerbil/expander/core.ss b/src/gerbil/expander/core.ss index 3bc1acb2b..076875e4b 100644 --- a/src/gerbil/expander/core.ss +++ b/src/gerbil/expander/core.ss @@ -251,7 +251,7 @@ namespace: gx (core-apply-expander (&syntax-binding-e bind) stx)) ((not bind) stx) (else - (raise-syntax-error #f "Bad syntax" stx))))) + (raise-syntax-error #f "Bad syntax; no binding for head" stx))))) (core-syntax-case stx () ((hd . _) @@ -283,7 +283,7 @@ namespace: gx (def (expand-splice hd body rest r) (if (stx-list? body) (K (stx-foldr cons rest body) r) - (raise-syntax-error #f "Bad syntax" stx hd))) + (raise-syntax-error #f "Bad syntax; splice body isn't a list" stx hd))) (def (expand-cond-expand hd rest r) (K (cons (core-expand-cond-expand% hd) rest) r)) @@ -370,7 +370,7 @@ namespace: gx ((or) (stx-ormap satisfied? body)) ((defined) (stx-andmap core-resolve-identifier body)) (else - (raise-syntax-error #f "Bad syntax" stx combinator)))))) + (raise-syntax-error #f "Bad syntax; bad cond-expannd combinator" stx combinator)))))) (def (loop rest) (core-syntax-case rest () @@ -380,7 +380,7 @@ namespace: gx (cond ((stx-eq? condition 'else) (if (stx-null? rest) body - (raise-syntax-error #f "Bad syntax" stx hd))) + (raise-syntax-error #f "Bad syntax; clauses after else" stx hd))) ((satisfied? condition) body) (else @@ -419,11 +419,11 @@ namespace: gx (else (K stx)))) ((bound-method-ref K method) => (cut core-apply-expander <> stx method)) (else - (raise-syntax-error #f "Bad syntax" stx method)))) + (raise-syntax-error #f "Bad syntax; no expander method" stx method)))) (defmethod {apply-macro-expander expander} (lambda (self stx) - (raise-syntax-error #f "Bad syntax" stx))) + (raise-syntax-error #f "Bad syntax; bottom method for apply-macro-expander" stx))) (defmethod {apply-macro-expander macro-expander} (lambda (self stx) diff --git a/src/gerbil/expander/stxcase.ss b/src/gerbil/expander/stxcase.ss index 3e20d15b5..cab01aad9 100644 --- a/src/gerbil/expander/stxcase.ss +++ b/src/gerbil/expander/stxcase.ss @@ -206,7 +206,7 @@ namespace: gx (generate (parse form)) (stx-source stx))) (else - (raise-syntax-error #f "Bad syntax" stx)))) + (raise-syntax-error #f "Bad syntax; expand-syntax expects a single argument" stx)))) ;;; syntax-case (def (macro-expand-syntax-case stx @@ -488,7 +488,7 @@ namespace: gx ((not (identifier-list? ids)) (raise-syntax-error #f "Bad template identifier list" stx ids)) ((not (stx-list? clauses)) - (raise-syntax-error #f "Bad syntax" stx)) + (raise-syntax-error #f "Bad syntax; clauses expected" stx)) (else (let* ((ids (syntax->list ids)) (clauses (syntax->list clauses)) @@ -502,7 +502,7 @@ namespace: gx (core-list 'let-values [[[E] (core-list 'lambda% [target] (core-list 'raise-syntax-error - #f "Bad syntax" target))]] + #f "Bad syntax; invalid match target" target))]] (generate-body (generate-bindings target ids clauses clause-ids E) [first expr])) diff --git a/src/gerbil/expander/top.ss b/src/gerbil/expander/top.ss index bd1eecdf7..71b9dde24 100644 --- a/src/gerbil/expander/top.ss +++ b/src/gerbil/expander/top.ss @@ -155,7 +155,7 @@ namespace: gx (else (let* ((body (match body - ([] (raise-syntax-error #f "Bad syntax" stx)) + ([] (raise-syntax-error #f "Bad syntax; empty body" stx)) ([expr] expr) (else (core-quote-syntax @@ -210,7 +210,7 @@ namespace: gx (core-cons '%#extern (reverse r)) (stx-source stx))) (else - (raise-syntax-error #f "Bad syntax" stx))))))) + (raise-syntax-error #f "Bad syntax; %#extern expects list of (internal external) identifier lists" stx))))))) ;; (%#define-values hd expr) (def (core-expand-define-values% stx) @@ -453,7 +453,7 @@ namespace: gx ((or (stx-string? ns) (stx-false? ns)) (stx-e ns)) (else - (raise-syntax-error #f "Bad syntax" stx ns)))) + (raise-syntax-error #f "Bad syntax; extern expects namespace identifier" stx ns)))) (lp rest ns r))) ((hd . rest) (if (identifier? hd) diff --git a/src/gerbil/prelude/core.ss b/src/gerbil/prelude/core.ss index f32fd87da..48b4a628e 100644 --- a/src/gerbil/prelude/core.ss +++ b/src/gerbil/prelude/core.ss @@ -1568,7 +1568,7 @@ package: gerbil (values (foldl cons tail hd) (foldl cons (list tail) body) #t)) - (raise-syntax-error #f "Bad syntax" stx #'e))) + (raise-syntax-error #f "Bad syntax; cut ellipsis <...> not in tail position" stx #'e))) (_ (lp #'rest hd (cons #'e body))))) (_ (values (reverse hd) (reverse body) #f))))) @@ -2077,7 +2077,7 @@ package: gerbil (generate-typedef stx #'id #'super fields body #t)) (_ (if (identifier? hd) (generate-typedef stx hd #f fields body #t) - (raise-syntax-error #f "Bad syntax" stx hd))))) + (raise-syntax-error #f "Bad syntax; struct name not an identifier" stx hd))))) (syntax-case stx () ((_ hd fields . rest) @@ -2096,7 +2096,7 @@ package: gerbil (generate-typedef stx #'id (syntax->list #'super) slots body #f)) (_ (if (identifier? hd) (generate-typedef stx hd [] slots body #f) - (raise-syntax-error #f "Bad syntax" stx hd))))) + (raise-syntax-error #f "Bad syntax; class name should be an identifier" stx hd))))) (syntax-case stx () ((_ hd slots . rest) @@ -2972,7 +2972,7 @@ package: gerbil ((recur id match-e) (recur id match-e (lambda ($stx) - (raise-syntax-error #f "Bad syntax" $stx))))) + (raise-syntax-error #f "Bad syntax; no macro definition for defsyntax-for-match" $stx))))) (defrules defrules-for-match () ((_ id . body) @@ -3064,11 +3064,11 @@ package: gerbil (lambda () postlude rest ...)))) (defsyntax (@bytes stx) - (syntax-case stx () - ((_ str) - (stx-string? #'str) - (with-syntax ((e (string->bytes (stx-e #'str)))) - #'(quote e))))) + (syntax-case stx () + ((_ str) + (stx-string? #'str) + (with-syntax ((e (string->bytes (stx-e #'str)))) + #'(quote e))))) ;; ... ) diff --git a/src/gerbil/runtime/eval.ss b/src/gerbil/runtime/eval.ss index 5adf31742..3dfe06261 100644 --- a/src/gerbil/runtime/eval.ss +++ b/src/gerbil/runtime/eval.ss @@ -128,7 +128,7 @@ namespace: #f => (lambda (bind) ((__syntax-e bind) stx))) (else - (__raise-syntax-error #f "Bad syntax" stx form)))))) + (__raise-syntax-error #f "Bad syntax; cannot resolve form" stx form)))))) (def (__compile-error stx (detail #f)) (__raise-syntax-error 'compile "Bad syntax; cannot compile" stx detail)) diff --git a/src/gerbil/runtime/syntax.ss b/src/gerbil/runtime/syntax.ss index 59307e93a..6e83d6cf6 100644 --- a/src/gerbil/runtime/syntax.ss +++ b/src/gerbil/runtime/syntax.ss @@ -63,7 +63,7 @@ namespace: #f (generate1 #'pat #'tgt #'(if fender expr E) #'E #'kws))))) #'(let ($E (lambda () continue)) body))) - ([] #'(__raise-syntax-error #f "Bad syntax" tgt))))))) + ([] #'(__raise-syntax-error #f "Bad syntax; malformed ast clause" tgt))))))) ;; we really don't want stack traces in syntax error, they are worse than useless. diff --git a/src/std/net/httpd/server.ss b/src/std/net/httpd/server.ss index 7d86c1497..66790a82e 100644 --- a/src/std/net/httpd/server.ss +++ b/src/std/net/httpd/server.ss @@ -1,5 +1,5 @@ ;;; -*- Gerbil -*- -;;; ̧© vyzo +;;; © vyzo ;;; embedded HTTP/1.1 server (import :std/sugar diff --git a/src/std/stxparam.ss b/src/std/stxparam.ss index 5ec936d90..098909213 100644 --- a/src/std/stxparam.ss +++ b/src/std/stxparam.ss @@ -45,12 +45,12 @@ => values) (else (raise-syntax-error #f errmsg stx))) - (raise-syntax-error #f "Bad syntax" stx)))))) + (raise-syntax-error #f "Bad syntax; defsyntax-parameter* expects a macro definition" stx)))))) (syntax-case stx () ((_ macro param) (identifier-list? #'(macro param)) - (defparam #'macro #'param "Bad syntax")) + (defparam #'macro #'param "Bad syntax; syntax parameter* unbound")) ((_ macro param errmsg) (identifier-list? #'(macro param)) (defparam #'macro #'param #'errmsg)))) diff --git a/src/std/sugar-test.ss b/src/std/sugar-test.ss index 95109c2b1..dab250870 100644 --- a/src/std/sugar-test.ss +++ b/src/std/sugar-test.ss @@ -57,6 +57,11 @@ (check-exception (in-ctx (lambda () (check depth => 1) (error "foo"))) true) (check depth => 0)) + (test-case "ignore-errors" + (check (ignore-errors 1 2 3) => 3) + (check (ignore-errors 1 (error "foo") 3) => #f) + (check (ignore-errors 1 2 #f) => #f)) + (test-case "with-destroy" (check (let (a (A)) [(with-destroy a (A-a a)) (A-a a)]) => '(open closed)) (def b (A)) diff --git a/src/std/sugar.ss b/src/std/sugar.ss index 8d46d7f64..f901cdb41 100644 --- a/src/std/sugar.ss +++ b/src/std/sugar.ss @@ -8,6 +8,7 @@ catch finally try + ignore-errors with-destroy defmethod/alias using-method @@ -107,6 +108,8 @@ (() ; no clauses, just a begin (cons 'begin (reverse body)))))))) +(defrule (ignore-errors form ...) (with-catch false (lambda () form ...))) + (defrule (with-destroy obj body ...) (let ($obj obj) (try body ... (finally {destroy $obj})))) diff --git a/src/std/values.ss b/src/std/values.ss index 9ac714cbb..e07a7fb9e 100644 --- a/src/std/values.ss +++ b/src/std/values.ss @@ -15,24 +15,24 @@ (def (first-value x . _) x) (defrules first-value% () ((_ form) (with ((values x . _) form) x)) - ((_ form forms ...) (syntax-error "Bad syntax")) + ((_ . _) (syntax-error "Bad syntax; first-value expects single argument")) (_ first-value)) (def (second-value _ x . _) x) (defrules second-value% () ((_ form) (with ((values _ x . _) form) x)) - ((_ form forms ...) (syntax-error "Bad syntax")) + ((_ . _) (syntax-error "Bad syntax; second-value expects single argument")) (_ second-value)) (defrules nth-value% () ((_ n form) (with ((values . x) form) (list-ref x n))) - ((_ form forms ...) (syntax-error "Bad syntax")) + ((_ . _) (syntax-error "Bad syntax; nth-value expects two arguments")) (_ nth-value_)) (def (nth-value n vals) (nth-value% n vals)) (defrules values->vector% () ((_ form) (list->vector (values->list form))) - ((_ . _) (syntax-error "Bad syntax")) + ((_ . _) (syntax-error "Bad syntax; values->vector expects one argument")) (_ values->vector)) (def (values->vector vals) (values->vector% vals)) @@ -42,7 +42,7 @@ (defrules values->cons% () ((_ form) (with ((values a b) form) (cons a b))) - ((_ . _) (syntax-error "Bad syntax")) + ((_ . _) (syntax-error "Bad syntax; values->cons expects one argument")) (_ values->cons)) (def (values->cons vals) (values->cons% vals))