Guile-hoot/lib/hoot/error-handling.scm

;;; Catching errors.
;;; Copyright (C) 2024 Igalia, S.L.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; with-exception-handler, guard, and all that.
;;;
;;; Code:

(library (hoot error-handling)
  (export guard format-exception)
  (import (hoot primitives)
    (hoot cond-expand)
    (hoot pairs)
    (hoot errors)
    (hoot exceptions)
    (hoot fluids)
    (only (hoot control)
          make-prompt-tag call-with-prompt abort-to-prompt)
    (hoot match)
    (hoot numbers)
    (hoot ports)
    (hoot write))

  ;; Snarfed from Guile's (ice-9 exceptions).  Deviates a bit from R7RS.
  (define-syntax guard
    (lambda (stx)
      (define (dispatch tag exn clauses)
        (define (build-clause test handler clauses)
          #`(let ((t #,test))
              (if t
                  (abort-to-prompt #,tag #,handler t)
                  #,(dispatch tag exn clauses))))
        (syntax-case clauses (=> else)
          (() #`(raise-continuable #,exn))
          (((test => f) . clauses)
           (build-clause #'test #'(lambda (res) (f res)) #'clauses))
          (((else e e* ...) . clauses)
           (build-clause #'#t #'(lambda (res) e e* ...) #'clauses))
          (((test) . clauses)
           (build-clause #'test #'(lambda (res) res) #'clauses))
          (((test e* ...) . clauses)
           (build-clause #'test #'(lambda (res) e* ...) #'clauses))))
      (syntax-case stx ()
        ((guard (exn clause clause* ...) body body* ...)
         (identifier? #'exn)
         #`(let ((tag (make-prompt-tag)))
             (call-with-prompt
              tag
              (lambda ()
                (with-exception-handler
                 (lambda (exn)
                   #,(dispatch #'tag #'exn #'(clause clause* ...)))
                 (lambda () body body* ...)))
              (lambda (_ h v)
                (h v))))))))

  (define (format-exception exception port)
    (display "Scheme error:\n")
    (match (simple-exceptions exception)
      (() (display "Empty exception object" port))
      (components
       (let loop ((i 1) (components components))
         (define (format-numbered-exception exception)
           (display "  " port)
           (display i port)
           (display ". " port)
           (write exception port))
         (match components
           ((component)
            (format-numbered-exception component))
           ((component . rest)
            (format-numbered-exception component)
            (newline port)
            (loop (+ i 1) rest)))))))

  (cond-expand
   (guile-vm)
   (hoot-main
    (let ()
      (define %exception-handler (make-fluid #f))
      (define (fluid-ref* fluid depth)
        (%inline-wasm
         '(func (param $fluid (ref $fluid)) (param $depth i32)
                (result (ref eq))
                (call $fluid-ref* (local.get $fluid) (local.get $depth)))
         fluid depth))

      (define* (with-exception-handler handler thunk #:key (unwind? #f))
        #;
        (unless (procedure? handler)      ; ; ; ;
        (error "not a procedure" handler))
        (cond
         (unwind?
          (let ((tag (make-prompt-tag "exception handler")))
            (call-with-prompt
             tag
             (lambda ()
               (with-fluids ((%exception-handler (cons #t tag)))
                 (thunk)))
             (lambda (k exn)
               (handler exn)))))
         (else
          (let ((running? (make-fluid #f)))
            (with-fluids ((%exception-handler (cons running? handler)))
              (thunk))))))

      (define (raise-non-continuable-exception)
        (raise (make-exception (make-non-continuable-violation)
                               (make-exception-with-message
                                "unhandled non-continuable exception"))))

      ;; FIXME: Use #:key instead
      (define* (raise-exception exn #:optional keyword continuable?)
        (let lp ((depth 0))
          ;; FIXME: fluid-ref* takes time proportional to depth, which
          ;; makes this loop quadratic.
          (match (fluid-ref* %exception-handler depth)
            (#f
             ;; No exception handlers bound; fall back.
             (let ((port (current-error-port)))
               (format-exception exn port)
               (newline port)
               (flush-output-port port))
             (%inline-wasm
              '(func (param $exn (ref eq))
                     (call $die (string.const "uncaught exception")
                           (local.get $exn))
                     (unreachable))
              exn))
            ((#t . prompt-tag)
             (abort-to-prompt prompt-tag exn)
             (raise-non-continuable-exception))
            ((running? . handler)
             (if (fluid-ref running?)
                 (begin
                   (lp (1+ depth)))
                 (with-fluids ((running? #t))
                   (cond
                    (continuable?
                     (handler exn))
                    (else
                     (handler exn)
                     (raise-non-continuable-exception)))))))))

      (define-syntax-rule (initialize-globals (global type proc) ...)
        (%inline-wasm
         '(func (param global type) ...
                (global.set global (local.get global)) ...)
         proc ...))
      (define-syntax-rule (initialize-proc-globals (global proc) ...)
        (initialize-globals (global (ref $proc) proc) ...))
      (initialize-proc-globals
       ($with-exception-handler with-exception-handler)
       ($raise-exception raise-exception))))
   (hoot-aux)))