with-exception-handler updated, new functions

`error-object?` and `error-object-message`

libraries/scheme/core.scm

@@ -1599,14 +1599,12 @@
       ; procedure:  (with-exception-handler handler thunk)  * (scheme exceptions)
       ; procedure:  (raise obj) * (scheme exceptions)
       ; procedure:  (raise-continuable obj)  * (scheme exceptions)
-      ;  note: temporary is equal to 'raise'
-
-      ; procedure:  (error message obj ...)
+      ; procedure:  (error message obj ...)  * (scheme exceptions)
       ; procedure:  (error-object? obj)
-      ; procedure:  (error-object-message error-object)
-      ; procedure:  (error-object-irritants error-object)
-      ; procedure:  (read-error? obj)
-      ; procedure:  (file-error? obj)
+      ; macro:      (error-object-message error-object)
+      ; procedure:  (error-object-irritants error-object) * no
+      ; procedure:  (read-error? obj) * no
+      ; procedure:  (file-error? obj) * no
 
       ; -- i'm here ----------------------
 

libraries/scheme/exceptions.scm

@@ -7,6 +7,8 @@
 
    (export
       raise raise-continuable
+      error-object?
+      error-object-message     ; * macro
       with-exception-handler)
 
    (import
@@ -22,32 +24,42 @@
          (lambda (resume)
             (vm:mcp resume 5 flag obj))))
 
-   ; temporary is equal to 'raise'
+   ; equal to 'raise'
    (define raise-continuable raise)
 
-   ; 
-   (define (with-exception-handler handler thunk)
-      (define name ['with-exception-handler]) ; anonymous
-      (actor-linked name thunk)
+   (define (error-object? obj)
+      (and
+         (vector? obj)
+         (eq? (size obj) 4)
+         (or (eq? (ref obj 1) 'error)
+             (eq? (ref obj 1) 'crash))))
+
+   (define-syntax error-object-message
+      (syntax-rules (verbose-ol-error interaction-environment)
+         ((error-object-message err)
+            (vector-apply err (lambda (class code reason info)
+               (verbose-ol-error
+                  (interaction-environment) code reason info))))))
 
-      (case (await name)
-         ;; ok
+   ; error classes: 'error, 'crash (todo: rename 'crash to 'critical?)
+   (define (with-exception-handler handler thunk)
+      (define issue (await
+         (actor-linked ['with-exception-handler] thunk)))
+      (case issue
+         ;; ok, no issues
          (['finished result]
             result)
 
-         ; (VM::FAIL ...), vm pushed an error
-         (['crash opcode a b]
-            (handler (verbose-ol-error #e opcode a b)))
+         ; olvm critical errors (todo: rename to 'critical?)
+         (['crash code a b]
+            (handler issue))
 
-         ; (raise info)
-         ; note, these could easily be made resumable by storing cont
+         ; (runtime-error code info) or (raise info)
          (['error code reason info]
-            (handler
-               (if (eq? reason flag)
-                  info
-                  (verbose-ol-error #e code reason info))))
+            (handler (if (eq? reason flag) info issue)))
 
+         ; should not be happened
          (else is foo
-            (runtime-error "something wrong" foo))))
+            (runtime-error 'with-exception-handler foo))))
 
 ))

tests/arity-errors.scm

@@ -0,0 +1,73 @@
+(import (scheme repl))
+
+; ------------------------------------------------
+; you can't handle compile-time arity errors, like:
+; 1. direct invalid primop calls
+;   - (cons 1), (car), (clock 1 2 3 4), etc.
+; 2. wrong "let" recursions
+;   - (let loop ((x 1)) (loop 1 2 3 4))
+; 3. direct lambda calls
+;   - ((lambda (x) x) 1 2 3)
+;   - ((lambda (x y . z) x) 1)
+
+; but you can handle runtime arity errors
+
+; - wrong "let" recursions
+(with-exception-handler
+   (lambda (x)
+      (print "error detected. " x)
+      (if (error-object? x)
+         (print "  " (error-object-message x))))
+   (lambda ()
+      (let loop ((x 1))
+         (define q loop)
+         (q 1 2 3))
+))
+
+; - direct lambda calls
+(define f (lambda (x) 777))
+
+(with-exception-handler
+   (lambda (x)
+      (print "error detected. " x)
+      (if (error-object? x)
+         (print "  " (error-object-message x))))
+   (lambda ()
+      (f 1 2 3)
+))
+
+; - case-lambdas
+(define g (case-lambda
+   ((a) 1)
+   ((a b) 2)
+   ((a b c d . e) 4) ))
+
+(with-exception-handler
+   (lambda (x)
+      (print "error detected. " x)
+      (if (error-object? x)
+         (print "  " (error-object-message x))))
+   (lambda ()
+      (g 1 2 3)
+))
+
+; - olvm critical errors (error class is 'crash)
+(with-exception-handler
+   (lambda (x)
+      (print "error detected. " x)
+      (if (error-object? x)
+         (print "  " (error-object-message x))))
+   (lambda ()
+      ; don't repeat, this is a dirty hack!
+      ((vm:cast (bytevector 0) type-bytecode) 1 2 3)
+))
+
+; - manual errors
+(with-exception-handler
+   (lambda (x)
+      (print "error detected. " x)
+      (if (error-object? x)
+         (print "  " (error-object-message x))))
+   (lambda ()
+      (raise "hello, i'm error!")
+))

tests/arity-errors.scm.ok

@@ -0,0 +1,9 @@
+error detected. #(error 17 #<lambda> 3)
+  (error 17 -> (wrong number of arguments: 3, but #<lambda> expects 1))
+error detected. #(error 17 #<lambda> 3)
+  (error 17 -> (wrong number of arguments: 3, but #<f> expects 1))
+error detected. #(error 17 #<lambda> 3)
+  (error 17 -> (wrong number of arguments: 3, but #<g> expects one of #(1 2 (at least 4))))
+error detected. #(crash 0 #<lambda> 0)
+  (error 0 -> (unsupported vm code #<lambda>))
+error detected. hello, i'm error!

tests/eval.scm

@@ -20,6 +20,8 @@
 ;; error handling
 (with-exception-handler
    (lambda (x)
-      (print "error detected. " (cadr x)))
+      (print "error detected.\n  "
+         (error-object-message x)))
+
    (lambda ()
       (print (eval '(not-a-func 1 2)))))

tests/eval.scm.ok

@@ -3,4 +3,5 @@
 3
 3
 3
-error detected. (What is 'not-a-func'?)
+error detected.
+  (eval failed with (What is 'not-a-func'?))