Macros for exception context (#897)

A couple of utility macros in `:std/error` to aid error raisers.
Also fixes clown shoes with double `*** ERROR` display in the repl.

src/gerbil/runtime/error.ss

@@ -131,9 +131,15 @@ namespace: #f
 
 (defmethod {display-exception Error}
   (lambda (self port)
-    (let (tmp-port (open-output-string))
+    (let ((tmp-port (open-output-string))
+          (display-error-newline
+           (if (macro-character-port? port)
+             (> (macro-character-port-wchars port) 0)
+             #f)))
       (fix-port-width! tmp-port)
       (parameterize ((current-output-port tmp-port))
+        (when display-error-newline ; avoid clown shoes at the repl prompt
+          (newline))
         (display "*** ERROR IN ")
         (cond
          ((&Error-where self) => display)

src/gerbil/runtime/gambit.ss

@@ -62,6 +62,7 @@ namespace: #f
   macro-readtable-brace-handler-set!
   macro-exception?
   macro-character-port?
+  macro-character-port-wchars
   macro-character-port-output-width
   macro-character-port-output-width-set!)
 

src/std/error.ss

@@ -3,7 +3,8 @@
 ;;; Gerbil error objects
 (import :gerbil/runtime/error
         :gerbil/gambit/continuations
-        :gerbil/gambit/threads)
+        :gerbil/gambit/threads
+        (for-syntax :gerbil/expander))
 (export Exception Exception?
         RuntimeException RuntimeException?
         Error Error?
@@ -72,6 +73,27 @@
 ;; key lookup errors
 (deferror-class UnboundKey () unbound-key-error?)
 
+;; utility macros
+(defsyntax (exception-context stx)
+  (syntax-case stx ()
+    ((macro)
+     #'(exception-context macro))
+    ((_ here)
+     (with-syntax ((where
+                    (cond
+                     ((or (AST-source #'here)
+                          (AST-source stx))
+                      => (lambda (locat)
+                           (call-with-output-string "" (cut ##display-locat locat #t <>))))
+                     (else
+                      (expander-context-id (core-context-top))))))
+       #'(quote where)))))
+
+(defrules check-argument ()
+  ((_ expr expectation argument)
+   (unless expr
+     (raise-bad-argument (exception-context argument) expectation argument))))
+
 ;; check to the raiser!
 (def (raise-bad-argument where expectation . irritants)
   (raise

src/std/xml/_libxml.scm

@@ -404,7 +404,7 @@ END-C
    ((macro-character-input-port? port)
     (parse (read-char-port port) url encoding options))
    (else
-    (std/error#raise-unspecified-error "Can't parse port; not a byte or character input port" port))))
+    (error "Can't parse port; not a byte or character input port" port))))
 
 (define (xmlRead-port port url encoding options)
   (xmlRead-iocontext xmlRead-u8vector* port url encoding options))

src/std/xml/sxml-to-xml.scm

@@ -95,9 +95,6 @@
               next-separator
               ))
 
-(define-macro (error message . args)
-  `(std/error#raise-unspecified-error message ,@args))
-
 (define valid-quote-chars '(#\" #\'))
 
 ; The following regards HTML/XHTML though as XML is so frequently used, we include it here.