Guile-hoot/module/hoot/exceptions.scm

;;; Exception definitions
;;; 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:
;;;
;;; Exception constructors for common errors.
;;;
;;; Code:

(library (hoot exceptions)
  (export &exception simple-exception?
          &compound-exception make-compound-exception compound-exception?
          compound-exception-components

          simple-exceptions make-exception exception?

          &message make-exception-with-message exception-with-message?
          exception-message

          &warning make-warning warning?

          &serious make-serious-exception serious-exception?

          &error make-error error?

          &violation make-violation violation?

          &assertion make-assertion-violation assertion-violation?

          &arity-violation make-arity-violation arity-violation?

          &implementation-restriction make-implementation-restriction-violation
          implementation-restriction-violation?

          &failed-type-check make-failed-type-check failed-type-check?
          failed-type-check-predicate

          &non-continuable make-non-continuable-violation
          non-continuable-violation?

          &irritants make-exception-with-irritants exception-with-irritants?
          exception-irritants

          &origin make-exception-with-origin exception-with-origin?
          exception-origin

          &lexical make-lexical-violation lexical-violation?

          &i/o make-i/o-error i/o-error?

          &i/o-line-and-column make-i/o-line-and-column-error
          i/o-line-and-column-error? i/o-error-line i/o-error-column

          &i/o-filename make-i/o-filename-error i/o-filename-error?
          i/o-error-filename

          &i/o-not-seekable make-i/o-not-seekable-error i/o-not-seekable-error?

          &i/o-port make-i/o-port-error i/o-port-error? i/o-error-port)
  (import (hoot syntax)
    (hoot features)
    (hoot cond-expand)
    (hoot errors)
    (hoot pairs)
    (hoot lists)
    (hoot records)
    (hoot match)
    (only (hoot primitives) %inline-wasm))

  (define-record-type &exception
    #:extensible? #t
    (make-&exception)
    simple-exception?)
  (define-record-type &compound-exception
    (make-compound-exception components)
    compound-exception?
    (components compound-exception-components))

  (define (simple-exceptions exception)
    "Return a list of the simple exceptions that compose the exception
object @var{exception}."
    (cond ((compound-exception? exception)
           (compound-exception-components exception))
          ((simple-exception? exception)
           (list exception))
          (else
           (raise (make-type-error exception 'exception? 'simple-exceptions)))))

  (define (make-exception . exceptions)
    "Return an exception object composed of @var{exceptions}."
    (define (flatten exceptions)
      (if (null? exceptions)
          '()
          (append (simple-exceptions (car exceptions))
                  (flatten (cdr exceptions)))))
    (let ((simple (flatten exceptions)))
      (if (and (pair? simple) (null? (cdr simple)))
          (car simple)
          (make-compound-exception simple))))

  (define (exception? obj)
    "Return true if @var{obj} is an exception object."
    (or (compound-exception? obj) (simple-exception? obj)))

  (define-syntax define-exception-type
    (lambda (stx)
      (syntax-case stx ()
        ((define-exception-type exn parent
           (make-exn arg ...)
           exn?
           (field exn-field)
           ...)
         (with-syntax (((%exn-field ...)
                        (generate-temporaries #'(exn-field ...))))
           #'(begin
               (define-record-type exn
                 #:parent parent #:extensible? #t
                 (make-exn arg ...)
                 %exn?
                 (field %exn-field)
                 ...)
               (define (exn? x)
                 (or (%exn? x)
                     (and (compound-exception? x)
                          (let lp ((simple (compound-exception-components x)))
                            (match simple
                              (() #f)
                              ((x . simple)
                               (or (%exn? x)
                                   (lp simple))))))))
               (define (exn-field x)
                 (if (%exn? x)
                     (%exn-field x)
                     (let lp ((simple (compound-exception-components x)))
                       (match simple
                         (() (raise (make-type-error x 'exn-field 'exn?)))
                         ((x . simple)
                          (if (%exn? x)
                              (%exn-field x)
                              (lp simple)))))))
               ...))))))

  (define-exception-type &message &exception
    (make-exception-with-message message)
    exception-with-message?
    (message exception-message))
  (define-exception-type &warning &exception
    (make-warning)
    warning?)
  (define-exception-type &serious &exception
    (make-serious-exception)
    serious-exception?)
  (define-exception-type &error &serious
    (make-error)
    error?)
  (define-exception-type &violation &serious
    (make-violation)
    violation?)
  (define-exception-type &assertion &violation
    (make-assertion-violation)
    assertion-violation?)
  (define-exception-type &arity-violation &violation
    (make-arity-violation)
    arity-violation?)
  (define-exception-type &implementation-restriction &violation
    (make-implementation-restriction-violation)
    implementation-restriction-violation?)
  (define-exception-type &failed-type-check &assertion
    (make-failed-type-check predicate)
    failed-type-check?
    (predicate failed-type-check-predicate))
  (define-exception-type &non-continuable &violation
    (make-non-continuable-violation)
    non-continuable-violation?)
  (define-exception-type &irritants &exception
    (make-exception-with-irritants irritants)
    exception-with-irritants?
    (irritants exception-irritants))
  (define-exception-type &origin &exception
    (make-exception-with-origin origin)
    exception-with-origin?
    (origin exception-origin))
  (define-exception-type &lexical &violation
    (make-lexical-violation)
    lexical-violation?)
  (define-exception-type &i/o &error
    (make-i/o-error)
    i/o-error?)
  (define-exception-type &i/o-line-and-column &i/o
    (make-i/o-line-and-column-error line column)
    i/o-line-and-column-error?
    (line i/o-error-line)
    (column i/o-error-column))
  (define-exception-type &i/o-filename &i/o
    (make-i/o-filename-error filename)
    i/o-filename-error?
    (filename i/o-error-filename))
  (define-exception-type &i/o-not-seekable &i/o
    (make-i/o-not-seekable-error)
    i/o-not-seekable-error?)
  (define-exception-type &i/o-port &i/o
    (make-i/o-port-error port)
    i/o-port-error?
    (port i/o-error-port))

  (cond-expand
   (guile-vm)
   (hoot-main
    (let ()
      (define (make-with-irritants exn message origin irritants)
        (make-exception exn
                        (make-exception-with-message message)
                        (make-exception-with-origin origin)
                        (make-exception-with-irritants irritants)))
      (define-syntax-rule (define-exception-constructor (name arg ...) body ...)
        (cond-expand
         ((and) (define (name arg ...) body ...))
         (else (define (name arg ...) (list arg ...)))))
      (define-exception-constructor (make-size-error val max who)
        (make-with-irritants (make-error) "size out of range" who (list val)))
      (define-exception-constructor (make-index-error val size who)
        (make-with-irritants (make-error) "index out of range" who (list val)))
      (define-exception-constructor (make-range-error val min max who)
        (make-with-irritants (make-error) "value out of range" who (list val)))
      (define-exception-constructor (make-start-offset-error val size who)
        (make-with-irritants (make-error) "start offset out of range" who
                             (list val)))
      (define-exception-constructor (make-end-offset-error val size who)
        (make-with-irritants (make-error) "end offset out of range" who
                             (list val)))
      (define-exception-constructor (make-type-error val who what)
        (make-with-irritants (make-failed-type-check what)
                             "type check failed"
                             who (list val)))
      (define-exception-constructor (make-unimplemented-error who)
        (make-exception (make-implementation-restriction-violation)
                        (make-exception-with-message "unimplemented")
                        (make-exception-with-origin who)))
      (define-exception-constructor (make-assertion-error expr who)
        (make-with-irritants (make-assertion-violation) "assertion failed"
                             who (list expr)))
      (define-exception-constructor (make-not-seekable-error port who)
        (make-exception (make-i/o-not-seekable-error)
                        (make-i/o-port-error port)
                        (make-exception-with-origin who)))
      (define-exception-constructor (make-runtime-error-with-message msg)
        (make-exception (make-error) (make-exception-with-message msg)))
      (define-exception-constructor (make-runtime-error-with-message+irritants
                                     msg irritants)
        (make-exception (make-error)
                        (make-exception-with-message msg)
                        (make-exception-with-irritants irritants)))
      (define-exception-constructor (make-match-error v)
        (make-exception (make-assertion-violation)
                        (make-exception-with-message "value failed to match")
                        (make-exception-with-irritants (list v))))
      (define-exception-constructor (make-arity-error v who)
        (define (annotate-with-origin exn)
          (if who
              (make-exception (make-exception-with-origin who) exn)
              exn))
        (annotate-with-origin
         (make-exception (make-arity-violation)
                         (make-exception-with-message
                          "wrong number of arguments")
                         (make-exception-with-irritants (list v)))))

      (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
       ($make-size-error make-size-error)
       ($make-index-error make-index-error)
       ($make-range-error make-range-error)
       ($make-start-offset-error make-start-offset-error)
       ($make-end-offset-error make-end-offset-error)
       ($make-type-error make-type-error)
       ($make-unimplemented-error make-unimplemented-error)
       ($make-assertion-error make-assertion-error)
       ($make-not-seekable-error make-not-seekable-error)
       ($make-runtime-error-with-message make-runtime-error-with-message)
       ($make-runtime-error-with-message+irritants
        make-runtime-error-with-message+irritants)
       ($make-match-error make-match-error)
       ($make-arity-error make-arity-error))))
   (else)))