Make raise facades macros

src/gerbil/runtime/error.ss

@@ -129,8 +129,12 @@ namespace: #f
 ;; method implementations
 (defmethod {:init! Error}
   (lambda (self message . rest)
-    (unchecked-slot-set! self 'message message)
-    (apply class-instance-init! self rest)))
+    (let (message
+          (if (string? message)
+            message
+            (call-with-output-string "" (cut display message <>))))
+      (unchecked-slot-set! self 'message message)
+      (apply class-instance-init! self rest))))
 
 (defmethod {display-exception Error}
   (lambda (self port)

src/std/actor-v18/ensemble.ss

@@ -49,7 +49,7 @@
                     mod-str)))
             (string-append mod-str "__rt")))
          (else
-          (raise-bad-argument 'load-library-module "string or symbol" mod))))
+          (raise-bad-argument load-library-module "string or symbol" mod))))
     (->> (handle srv (reference srv-id 'loader))
          (!load-library-module mod-str)))
   error: "error remotely loading library module" srv-id mod)
@@ -61,7 +61,7 @@
           ((string? object-file-path)
            (read-file-u8vector object-file-path))
           (else
-           (raise-bad-argument 'load-code "path: code object file" object-file-path))))
+           (raise-bad-argument load-code "path: code object file" object-file-path))))
         (linker (path-strip-directory object-file-path)))
     (->> (handle srv (reference srv-id 'loader))
          (!load-code code linker)))
@@ -120,7 +120,7 @@
                                 capabilities: (cap '(admin)))
   (let (remote-root (handle srv (reference srv-id 0)))
     (unless (and (list? cap) (andmap symbol? cap))
-      (raise-bad-argument 'authorize "capabilities: list of symbols" cap))
+      (raise-bad-argument authorize "capabilities: list of symbols" cap))
     (match (->> remote-root (!admin-auth authorized-server-id cap))
       ((!admin-auth-challenge bytes)
        (let (sig (admin-auth-challenge-sign privk srv-id authorized-server-id bytes))

src/std/actor-v18/io.ss

@@ -15,21 +15,21 @@
   (let (tag (object-tag obj))
     (cond
      ((not tag)
-      (raise-io-error 'BufferedWriter-marshal "unserializable object" obj))
+      (raise-io-error BufferedWriter-marshal "unserializable object" obj))
      ((vector-ref +marshal+ tag)
       => (lambda (write-e)
            (&BufferedWriter-write-u8 buf tag)
            (fx+ (write-e buf obj) 1)))
      (else
-      (raise-io-error 'BufferedWriter-marshal "missing serializer" obj tag)))))
+      (raise-io-error BufferedWriter-marshal "missing serializer" obj tag)))))
 
 (defreader-ext* (unmarshal buf)
   (let (tag (&BufferedReader-read-u8! buf))
     (cond
      ((vector-ref +unmarshal+ tag)
       => (cut <> buf))
      (else
-      (raise-io-error 'BufferedReader-unmarshal "unrecognized object tag" tag)))))
+      (raise-io-error BufferedReader-unmarshal "unrecognized object tag" tag)))))
 
 (defreader-ext* (try-unmarshal buf)
   (let (tag (&BufferedReader-read-u8 buf))
@@ -39,15 +39,15 @@
      ((vector-ref +unmarshal+ tag)
       => (cut <> buf))
      (else
-      (raise-io-error 'BufferedReader-unmarshal "unrecognized object tag" tag)))))
+      (raise-io-error BufferedReader-unmarshal "unrecognized object tag" tag)))))
 
 (defwriter-ext* (marshal-envelope buf obj)
   (with ((envelope message dest source nonce replyto expiry reply-expected?) obj)
     (when (or (thread? source)
               (handle? source)
               (thread? dest)
               (handle? dest))
-      (raise-io-error 'BufferedWriter-marshal "cannot marshal envelope; contains threads"
+      (raise-io-error BufferedWriter-marshal "cannot marshal envelope; contains threads"
                       source dest))
     (let* ((w1 (&BufferedWriter-marshal buf message))
            (w2 (&BufferedWriter-marshal buf dest))
@@ -100,7 +100,7 @@
      ((lookup-message-type klass-id)
       => (lambda (klass)
            (unless (fx= fields (type-descriptor-fields klass))
-             (raise-io-error 'BufferedReader-unmarshal-message "bad message; field count mismatch"
+             (raise-io-error BufferedReader-unmarshal-message "bad message; field count mismatch"
                              klass-id fields klass (type-descriptor-fields klass)))
            (let (obj (make-object klass fields))
              (let lp ((i 0))
@@ -111,7 +111,7 @@
                    (lp i+1))
                  obj)))))
      (else
-      (raise-io-error 'BufferedReader-unmarshal-message "unknown message type" klass-id)))))
+      (raise-io-error BufferedReader-unmarshal-message "unknown message type" klass-id)))))
 
 (defwriter-ext* (marshal-void buf obj)
   0)

src/std/actor-v18/message.ss

@@ -10,8 +10,8 @@
 
 ;; actor errors
 (deferror-class ActorError () actor-error?)
-(def (raise-actor-error where what . irritants)
-  (raise (ActorError what irritants: irritants where: where)))
+(defraise/context (raise-actor-error where message irritants ...)
+  (ActorError message irritants: [irritants ...]))
 
 ;; default reply timeout; 5s
 (def +default-reply-timeout+ 5)
@@ -99,7 +99,7 @@
    ((handle? actor)
     (thread-send/check (&handle-proxy actor) msg))
    (else
-    (raise-bad-argument 'send-message "thread or handle" actor))))
+    (raise-bad-argument send-message "thread or handle" actor))))
 
 ;; sends a message wrapped in an envelope
 ;; Returns #f if the destination is a dead thread; otherwise returns the message nonce.
@@ -118,7 +118,7 @@
   (let* ((expiry (timeout->expiry timeo))
          (nonce (current-thread-nonce!)))
     (unless (send-message dest (envelope msg dest (current-thread) nonce replyto expiry #t))
-      (raise-actor-error 'send-message "actor is dead" dest))
+      (raise-actor-error send-message "actor is dead" dest))
     (<< ((envelope reply _ _ _ (eqv? nonce))
          reply)
         timeout: expiry)))
@@ -171,7 +171,7 @@
                      (if (eq? next mailbox-timeout)
                        (begin
                          (thread-mailbox-rewind)
-                         (raise-timeout 'receive "receive timeout" expiry))
+                         (raise-timeout receive "receive timeout" expiry))
                        (recv-e next))))))))))))
 
   (def (generate-receive-raw stx)
@@ -278,7 +278,7 @@
    ((time? timeo)
     timeo)
    (else
-    (raise-bad-argument 'expiry "real or time" timeo))))
+    (raise-bad-argument expiry "real or time" timeo))))
 
 ;; message type registry
 (def +message-types+ (make-hash-table-eq))
@@ -287,7 +287,7 @@
 (def (register-message-type! klass)
   (let (klass-id (##type-id klass))
     (unless (interned-symbol? klass-id)
-      (raise-context-error 'register-message-type! "uninterned message class" klass))
+      (raise-context-error register-message-type! "uninterned message class" klass))
     (mutex-lock! +message-types-mx+)
     (hash-put! +message-types+ klass-id klass)
     (mutex-unlock! +message-types-mx+)))

src/std/actor-v18/proto.ss

@@ -21,7 +21,7 @@
   ((_ (proc arg ...) expr error: error-msg error-irritant ...)
    (def (proc arg ...)
      (with-result expr
-       (lambda (what) (raise-actor-error 'proc error-msg error-irritant ... what)))))
+       (lambda (what) (raise-actor-error proc error-msg error-irritant ... what)))))
   ((_ (proc arg ...) expr)
    (defcall-actor (proc arg ...) expr error: "actor error")))
 

src/std/coroutine.ss

@@ -42,7 +42,7 @@
    ((cothread? c)
     (cothread-continue! (thread-specific c) args))
    (else
-    (raise-bad-argument 'continue "coroutine or cothread" c))))
+    (raise-bad-argument continue "coroutine or cothread" c))))
 
 (def (yield . args)
   (cond
@@ -51,7 +51,7 @@
    ((cothr? (thread-specific (current-thread)))
     (cothread-yield! (thread-specific (current-thread)) args))
    (else
-    (raise-context-error 'yield "not in a coroutine continuation"))))
+    (raise-context-error yield "not in a coroutine continuation"))))
 
 ;;; Implementation of coroutines
 (def (coroutine-start! k thunk)
@@ -98,8 +98,8 @@
     (let (spec (thread-specific thread))
       (if (cothr? spec)
         (cothread-signal! spec 'end val)
-        (raise-bad-argument 'cothread-stop! "cothread" thread spec)))
-    (raise-bad-argument 'cothread-stop! "cothtread" thread)))
+        (raise-bad-argument cothread-stop! "cothread" thread spec)))
+    (raise-bad-argument cothread-stop! "cothtread" thread)))
 
 (def (cothread-continue! c val)
   (with ((cothr mx cv state kont) c)
@@ -130,15 +130,15 @@
               (raise kont))
              (else
               (mutex-unlock! mx)
-              (raise-context-error 'cothread-continue! "illegal cothread state" state))))))
+              (raise-context-error cothread-continue! "illegal cothread state" state))))))
       ((end)
        (mutex-unlock! mx)
        kont)
       ((error)
        (mutex-unlock! mx)
        (raise kont))
       (else
-       (raise-context-error 'cothread-continue! "illegal cothread state" state)))))
+       (raise-context-error cothread-continue! "illegal cothread state" state)))))
 
 (def (cothread-yield! c args)
   (let (kont (cothread-yield-values! c (apply values args)))
@@ -157,7 +157,7 @@
        kont)
       (else
        (mutex-unlock! mx)
-       (raise-context-error 'cothread-yield-values! "illegal cothread state" state)))))
+       (raise-context-error cothread-yield-values! "illegal cothread state" state)))))
 
 (def (cothread-signal! c state val)
   (with ((cothr mx cv) c)
@@ -181,4 +181,4 @@
            (mutex-unlock! mx))
           (else
            (mutex-unlock! mx)
-           (raise-context-error 'cothread-wait! "illegal cothread state" state)))))))
+           (raise-context-error cothread-wait! "illegal cothread state" state)))))))

src/std/crypto/etc.ss

@@ -7,6 +7,7 @@
         random-bytes random-bytes!
         as-bytes)
 (import :std/error
+        :std/sugar
         :std/format
         :std/text/utf8
         :std/crypto/libcrypto)
@@ -22,23 +23,25 @@
   macro-character-port-rlo-set!)
 
 (deferror-class LibCryptoError () libcrypto-error?
-  (lambda (self errno . irritants)
+  (lambda (self ctx errno . irritants)
     (Error:::init! self
                    (or (ERR_reason_error_string errno) "libcrypto: Unknown error")
-                   where: (string-append
-                           (or (ERR_lib_error_string errno) "?") ":"
-                           (or (ERR_func_error_string errno) "?"))
-                   irritants: (cons errno irritants))))
+                   where: ctx
+                   irritants:
+                   [(string-append
+                     (or (ERR_lib_error_string errno) "?") ":"
+                     (or (ERR_func_error_string errno) "?"))
+                    errno irritants ...])))
 
-(def (raise-libcrypto-error . irritants)
-  (raise (LibCryptoError (ERR_get_error) irritants)))
+(defrule (raise-libcrypto-error irritant irritants ...)
+  (raise (LibCryptoError (exception-context irritant) (ERR_get_error) irritant irritants ...)))
 
 (defrules with-libcrypto-error ()
   ((_ expr irritants ...)
    (let (res expr)
      (if (##fxpositive? res)
        res
-       (apply raise-libcrypto-error '(irritants ...))))))
+       (raise-libcrypto-error expr irritants ...)))))
 
 (def (call-with-binary-input proc in . args)
   (cond
@@ -49,7 +52,7 @@
    ((input-port? in)
     (apply call-with-binary-input-port proc in args))
    (else
-    (raise-bad-argument 'libcrypt "input source; u8vector, string or input port" in))))
+    (raise-bad-argument libcrypto "input source; u8vector, string or input port" in))))
 
 (def* call-with-binary-input-u8vector
   ((proc in)
@@ -130,4 +133,4 @@
    ((u8vector? in) in)
    ((string? in) (string->utf8 in))
    (else
-    (raise-bad-argument 'libcrypto "u8vector or string" in))))
+    (raise-bad-argument libcrypto "u8vector or string" in))))

src/std/crypto/pkey.ss

@@ -63,7 +63,7 @@
         (let* ((s (or (bytes-argument sig) (make-u8vector 8192)))
                (result (EVP_DigestSign mctx s bytes)))
           (if (##fxzero? result)
-            (raise-libcrypto-error)
+            (raise-libcrypto-error digest-sign)
             (bytes-result s result))))
       (foreign-release! mctx))))
 

src/std/db/conpool.ss

@@ -47,7 +47,7 @@
            (let (res (mutex-unlock! mx cv timeo))
              (if res
                (lp)
-               (raise-timeout 'conpool-get "Error getting connection; timeout")))))))))
+               (raise-timeout conpool-get "Error getting connection; timeout")))))))))
 
 (def (conpool-put cp conn)
   (with ((conpool _ mx cv conns out) cp)

src/std/db/dbi.ss

@@ -67,8 +67,8 @@
     (set! (&statement-i self) (Statement self))))
 
 (deferror-class SQLError () sql-error?)
-(def (raise-sql-error where what . irritants)
-  (raise (SQLError what irritants: irritants where: where)))
+(defraise/context (raise-sql-error where what irritants ...)
+  (SQLError what irritants: [irritants ...]))
 
 (def (sql-connect connect . args)
   (let (conn (apply connect args))
@@ -100,7 +100,7 @@
   (with ((connection e driver) conn)
     (cond
      ((not e)
-      (raise-context-error 'sql-txn-do "Invalid operation; connection closed" conn))
+      (raise-context-error sql-txn-do "Invalid operation; connection closed" conn))
      ((getf conn) => sql-exec)
      (else
       (let (stmt (&Driver-prepare driver sql))
@@ -122,7 +122,7 @@
       (let (stmt (&Driver-prepare driver text))
         (make-will stmt sql-finalize)
         stmt)
-      (raise-context-error 'sql-prepare "Invalid operation; connection closed" conn))))
+      (raise-context-error sql-prepare "Invalid operation; connection closed" conn))))
 
 (def (sql-finalize stmt)
   (with ((statement e i) stmt)
@@ -139,27 +139,27 @@
   (with ((statement e i) stmt)
     (if e
       (apply &Statement-bind i args)
-      (raise-context-error 'sql-bind "Invalid operation; statement finalized" stmt))))
+      (raise-context-error sql-bind "Invalid operation; statement finalized" stmt))))
 
 (def (sql-clear stmt)
   (with ((statement e i) stmt)
     (if e
       (&Statement-clear i)
-      (raise-context-error 'sql-clear "Invalid operation; statement finalized" stmt))))
+      (raise-context-error sql-clear "Invalid operation; statement finalized" stmt))))
 
 (def (sql-reset stmt)
   (with ((statement e i) stmt)
     (if e
       (&Statement-reset i)
-      (raise-context-error 'sql-reset "Invalid operation; statement finalized" stmt))))
+      (raise-context-error sql-reset "Invalid operation; statement finalized" stmt))))
 
 (def (sql-reset/clear stmt)
   (with ((statement e i) stmt)
     (if e
       (begin
         (&Statement-reset i)
         (&Statement-clear i))
-      (raise-context-error 'sql-reset/clear "Invalid operation; statement finalized" stmt))))
+      (raise-context-error sql-reset/clear "Invalid operation; statement finalized" stmt))))
 
 (def (sql-eval-e eval-e conn sql args)
   (let (stmt (sql-prepare conn sql))
@@ -182,7 +182,7 @@
         (&Statement-exec i)
         (&Statement-reset i)
         (void))
-      (raise-context-error 'sql-exec "Invalid operation; statement finalized" stmt))))
+      (raise-context-error sql-exec "Invalid operation; statement finalized" stmt))))
 
 (def (sql-query stmt)
   (for/collect (row (in-sql-query stmt)) row))
@@ -211,11 +211,11 @@
         (make-will it fini)
         (&Statement-query-start i)
         it)
-      (raise-context-error 'in-sql-query "Invalid operation; statement finalized" stmt))))
+      (raise-context-error in-sql-query "Invalid operation; statement finalized" stmt))))
 
 ;;; metadata
 (def (sql-columns stmt)
   (with ((statement e i) stmt)
     (if e
       (&Statement-columns i)
-      (raise-context-error 'sql-columns "Invalid operation; statement finalized" stmt))))
+      (raise-context-error sql-columns "Invalid operation; statement finalized" stmt))))