FM / ice-9

/usr/share/guile/3.0/ice-9

Name	Size	Mode	Actions
peg/	-	0755	rm
and-let-star.scm	2593	0644	edit dl rm
arrays.scm	2692	0644	edit dl rm
atomic.scm	1592	0644	edit dl rm
binary-ports.scm	2773	0644	edit dl rm
boot-9.scm	170413	0644	edit dl rm
buffered-input.scm	4935	0644	edit dl rm
calling.scm	10790	0644	edit dl rm
command-line.scm	19050	0644	edit dl rm
common-list.scm	9160	0644	edit dl rm
control.scm	4181	0644	edit dl rm
copy-tree.scm	3119	0644	edit dl rm
curried-definitions.scm	1829	0644	edit dl rm
deprecated.scm	1573	0644	edit dl rm
documentation.scm	7584	0644	edit dl rm
eval-string.scm	3058	0644	edit dl rm
eval.scm	25677	0644	edit dl rm
exceptions.scm	14730	0644	edit dl rm
expect.scm	5628	0644	edit dl rm
fdes-finalizers.scm	1084	0644	edit dl rm
format.scm	67038	0644	edit dl rm
ftw.scm	25666	0644	edit dl rm
futures.scm	10739	0644	edit dl rm
gap-buffer.scm	9825	0644	edit dl rm
getopt-long.scm	16888	0644	edit dl rm
hash-table.scm	1813	0644	edit dl rm
hcons.scm	2614	0644	edit dl rm
history.scm	2343	0644	edit dl rm
i18n.scm	21002	0644	edit dl rm
iconv.scm	3268	0644	edit dl rm
lineio.scm	3941	0644	edit dl rm
list.scm	1319	0644	edit dl rm
local-eval.scm	10072	0644	edit dl rm
ls.scm	3275	0644	edit dl rm
match.scm	2233	0644	edit dl rm
match.upstream.scm	36797	0644	edit dl rm
networking.scm	3407	0644	edit dl rm
null.scm	1239	0644	edit dl rm
occam-channel.scm	7436	0644	edit dl rm
optargs.scm	16123	0644	edit dl rm
peg.scm	1684	0644	edit dl rm
poe.scm	3382	0644	edit dl rm
poll.scm	5929	0644	edit dl rm
popen.scm	9490	0644	edit dl rm
ports.scm	19535	0644	edit dl rm
posix.scm	2793	0644	edit dl rm
pretty-print.scm	17289	0644	edit dl rm
psyntax-pp.scm	187271	0644	edit dl rm
psyntax.scm	152542	0644	edit dl rm
q.scm	4297	0644	edit dl rm
quasisyntax.scm	5348	0644	edit dl rm
r5rs.scm	1602	0644	edit dl rm
r6rs-libraries.scm	10633	0644	edit dl rm
r7rs-libraries.scm	4387	0644	edit dl rm
rdelim.scm	7902	0644	edit dl rm
read.scm	33301	0644	edit dl rm
readline.scm	9791	0644	edit dl rm
receive.scm	1082	0644	edit dl rm
regex.scm	9084	0644	edit dl rm
runq.scm	8379	0644	edit dl rm
rw.scm	1047	0644	edit dl rm
safe-r5rs.scm	7676	0644	edit dl rm
safe.scm	1279	0644	edit dl rm
sandbox.scm	35062	0644	edit dl rm
save-stack.scm	2198	0644	edit dl rm
scm-style-repl.scm	11900	0644	edit dl rm
serialize.scm	3869	0644	edit dl rm
session.scm	18146	0644	edit dl rm
slib.scm	1583	0644	edit dl rm
stack-catch.scm	1983	0644	edit dl rm
streams.scm	6004	0644	edit dl rm
string-fun.scm	9916	0644	edit dl rm
suspendable-ports.scm	30576	0644	edit dl rm
textual-ports.scm	2346	0644	edit dl rm
threads.scm	12839	0644	edit dl rm
time.scm	2121	0644	edit dl rm
top-repl.scm	2695	0644	edit dl rm
unicode.scm	1005	0644	edit dl rm
vlist.scm	22081	0644	edit dl rm
weak-vector.scm	1229	0644	edit dl rm

Edit: /usr/share/guile/3.0/ice-9/exceptions.scm (14730B)

;;; Exceptions
;;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
;;;
;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This library is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; Lesser General Public License for more details.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

;;; Commentary:
;;;
;;; Definition of the standard exception types.
;;;
;;; Code:

(define-module (ice-9 exceptions)
  #:re-export (&exception
               make-exception
               make-exception-type
               simple-exceptions
               exception?
               exception-type?
               exception-predicate
               exception-accessor

exception-kind
               exception-args

&error
               &programming-error
               &quit-exception
               &non-continuable

raise-exception
               with-exception-handler)
  #:export (define-exception-type

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

&warning
            make-warning
            warning?

make-error
            error?

&external-error
	    make-external-error
	    external-error?

make-quit-exception
            quit-exception?

make-programming-error
	    programming-error?

&assertion-failure
	    make-assertion-failure
	    assertion-failure?

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

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

make-non-continuable-error
            non-continuable-error?

&implementation-restriction
            make-implementation-restriction-error
            implementation-restriction-error?

&lexical
            make-lexical-error
            lexical-error?

&syntax
            make-syntax-error
            syntax-error?
            syntax-error-form
            syntax-error-subform

&undefined-variable
            make-undefined-variable-error
            undefined-variable-error?

raise-continuable

guard))

(define-syntax define-exception-type-procedures
  (syntax-rules ()
    ((_ exception-type supertype constructor predicate
	(field accessor) ...)
     (begin
       (define constructor (record-constructor exception-type))
       (define predicate (exception-predicate exception-type))
       (define accessor
         (exception-accessor exception-type
                             (record-accessor exception-type 'field)))
       ...))))

(define-syntax define-exception-type
  (syntax-rules ()
    ((_ exception-type supertype constructor predicate
	(field accessor) ...)
     (begin
       (define exception-type
         (make-record-type 'exception-type '((immutable field) ...)
                           #:parent supertype #:extensible? #t))
       (define-exception-type-procedures exception-type supertype
         constructor predicate (field accessor) ...)))))

(define-exception-type-procedures &error &exception
  make-error error?)
(define-exception-type-procedures &programming-error &error
  make-programming-error programming-error?)

(define-exception-type &assertion-failure &programming-error
  make-assertion-failure assertion-failure?)

(define-exception-type &message &exception 
  make-exception-with-message exception-with-message? 
  (message exception-message))

(define-exception-type &warning &exception
  make-warning warning?)

(define-exception-type &external-error &error
  make-external-error external-error?)

(define-exception-type &irritants &exception
  make-exception-with-irritants exception-with-irritants?
  (irritants exception-irritants))

(define-exception-type &origin &exception
  make-exception-with-origin exception-with-origin?
  (origin exception-origin))

(define-exception-type-procedures &non-continuable &programming-error
  make-non-continuable-error
  non-continuable-error?)

(define-exception-type &implementation-restriction &programming-error
  make-implementation-restriction-error
  implementation-restriction-error?)

(define-exception-type &lexical &programming-error
  make-lexical-error lexical-error?)

(define-exception-type &syntax &programming-error
  make-syntax-error syntax-error?
  (form syntax-error-form)
  (subform syntax-error-subform))

(define-exception-type &undefined-variable &programming-error
  make-undefined-variable-error undefined-variable-error?)

(define make-exception-with-kind-and-args
  (record-constructor &exception-with-kind-and-args))
(define make-quit-exception
  (record-constructor &quit-exception))
(define quit-exception?
  (exception-predicate &quit-exception))

(define (default-guile-exception-converter key args)
  (make-exception (make-error)
                  (guile-common-exceptions key args)))

(define (guile-common-exceptions key args)
  (apply (case-lambda
          ((subr msg margs . _)
           (make-exception
            (make-exception-with-origin subr)
            (make-exception-with-message msg)
            (make-exception-with-irritants margs)))
          (_ (make-exception-with-irritants args)))
         args))

(define (convert-guile-exception key args)
  (let ((converter (assv-ref guile-exception-converters key)))
    (make-exception (or (and converter (converter key args))
                        (default-guile-exception-converter key args))
                    (make-exception-with-kind-and-args key args))))

(define (raise-continuable obj)
  (raise-exception obj #:continuable? #t))

;;; Exception printing

(define (exception-printer port key args punt)
  (cond ((and (= 1 (length args))
              (exception? (car args)))
         (display "ERROR:\n" port)
         (format-exception port (car args)))
        (else
         (punt))))

(define (format-exception port exception)
  (let ((components (simple-exceptions exception)))
    (if (null? components)
        (format port "Empty exception object")
        (let loop ((i 1) (components components))
          (cond ((pair? components)
                 (format port "  ~a. " i)
                 (format-simple-exception port (car components))
                 (when (pair? (cdr components))
                   (newline port))
                 (loop (+ i 1) (cdr components))))))))

(define (format-simple-exception port exception)
  (let* ((type (struct-vtable exception))
         (name (record-type-name type))
         (fields (record-type-fields type)))
    (cond
     ((null? fields)
      (format port "~a" name))
     ((null? (cdr fields))
      (format port "~a: ~s" name (struct-ref exception 0)))
     (else
      (format port "~a:\n" name)
      (let lp ((fields fields) (i 0))
        (let ((field (car fields))
              (fields (cdr fields)))
          (format port "      ~a: ~s" field (struct-ref exception i))
          (unless (null? fields)
            (newline port)
            (lp fields (+ i 1)))))))))

(set-exception-printer! '%exception exception-printer)

;; Guile exception converters
;;
;; Each converter is a procedure (converter KEY ARGS) that returns
;; either an exception object or #f.  If #f is returned,
;; 'default-guile-exception-converter' will be used.

(define (guile-syntax-error-converter key args)
  (apply (case-lambda
          ((who what where form subform . extra)
           (make-exception (make-syntax-error form subform)
                           (make-exception-with-origin who)
                           (make-exception-with-message what)))
          (_ #f))
         args))

(define make-quit-exception (record-constructor &quit-exception))
(define (guile-quit-exception-converter key args)
  (define code
    (cond
     ((not (pair? args)) 0)
     ((integer? (car args)) (car args))
     ((not (car args)) 1)
     (else 0)))
  (make-exception (make-quit-exception code)
                  (guile-common-exceptions key args)))

(define (guile-lexical-error-converter key args)
  (make-exception (make-lexical-error)
                  (guile-common-exceptions key args)))

(define (guile-assertion-failure-converter key args)
  (make-exception (make-assertion-failure)
                  (guile-common-exceptions key args)))

(define (guile-undefined-variable-error-converter key args)
  (make-exception (make-undefined-variable-error)
                  (guile-common-exceptions key args)))

(define (guile-implementation-restriction-converter key args)
  (make-exception (make-implementation-restriction-error)
                  (guile-common-exceptions key args)))

(define (guile-external-error-converter key args)
  (make-exception (make-external-error)
                  (guile-common-exceptions key args)))

(define (guile-system-error-converter key args)
  (apply (case-lambda
          ((subr msg msg-args errno . rest)
           ;; XXX TODO we should return a more specific error
           ;; (usually an I/O error) as expected by R6RS programs.
           ;; Unfortunately this often requires the 'filename' (or
           ;; other?) which is not currently provided by the native
           ;; Guile exceptions.
           (make-exception (make-external-error)
                           (guile-common-exceptions key args)))
          (_ (guile-external-error-converter key args)))
         args))

;; TODO: Arrange to have the needed information included in native
;;       Guile I/O exceptions, and arrange here to convert them to the
;;       proper exceptions.  Remove the earlier exception conversion
;;       mechanism: search for 'with-throw-handler' in the 'rnrs'
;;       tree, e.g. 'with-i/o-filename-exceptions' and
;;       'with-i/o-port-error' in (rnrs io ports).

;; XXX TODO: How should we handle the 'misc-error', 'vm-error', and
;;           'signal' native Guile exceptions?

;; XXX TODO: Should we handle the 'quit' exception specially?

;; An alist mapping native Guile exception keys to converters.
(define guile-exception-converters
  `((quit                      . ,guile-quit-exception-converter)
    (read-error                . ,guile-lexical-error-converter)
    (syntax-error              . ,guile-syntax-error-converter)
    (unbound-variable          . ,guile-undefined-variable-error-converter)
    (wrong-number-of-args      . ,guile-assertion-failure-converter)
    (wrong-type-arg            . ,guile-assertion-failure-converter)
    (keyword-argument-error    . ,guile-assertion-failure-converter)
    (out-of-range              . ,guile-assertion-failure-converter)
    (regular-expression-syntax . ,guile-assertion-failure-converter)
    (program-error             . ,guile-assertion-failure-converter)
    (goops-error               . ,guile-assertion-failure-converter)
    (null-pointer-error        . ,guile-assertion-failure-converter)
    (system-error              . ,guile-system-error-converter)
    (host-not-found            . ,guile-external-error-converter)
    (getaddrinfo-error         . ,guile-external-error-converter)
    (no-data                   . ,guile-external-error-converter)
    (no-recovery               . ,guile-external-error-converter)
    (try-again                 . ,guile-external-error-converter)
    (stack-overflow            . ,guile-implementation-restriction-converter)
    (numerical-overflow        . ,guile-implementation-restriction-converter)
    (memory-allocation-error   . ,guile-implementation-restriction-converter)))

(define (set-guile-exception-converter! key proc)
  (set! guile-exception-converters
        (acons key proc guile-exception-converters)))

;; Override core definition.
(set! make-exception-from-throw convert-guile-exception)

(define-syntax guard
  (lambda (stx)
    "Establish an exception handler during the evaluation of an expression.

@example
(guard (@var{exn} @var{clause1} @var{clause2} ...)
  @var{body} @var{body*} ...)
@end example

Each @var{clause} should have the same form as a @code{cond} clause.

The @code{(begin body body* ...)} is evaluated with an exception
handler that binds the raised object to @var{exn} and within the scope of
that binding evaluates the clauses as if they were the clauses of a cond
expression.

When a clause of that implicit cond expression matches, its consequent
is evaluated with the continuation and dynamic environment of the
@code{guard} expression.

If every clause's test evaluates to false and there is no @code{else}
clause, then @code{raise-continuable} is re-invoked on the raised
object, within the dynamic environment of the original call to raise
except that the current exception handler is that of the guard
expression.

Note that in a slight deviation from SRFI-34, R6RS, and R7RS, Guile
evaluates the clause tests within the continuation of the exception
handler, not the continuation of the @code{guard}.  This allows
unhandled exceptions to continue to dispatch within the original
continuation, without unwinding then rewinding any intermediate
@code{dynamic-wind} invocations."
    (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))))))))

cmd: