Artifact 134f2d16d7df1c6b752f9525b143a6bdc9f7b61d:

• File srfi/s23/error/tricks.sls — part of check-in [80c8c83034] at 2016-07-07 18:11:39 on branch trunk — initial import (user: ovenpasta@pizzahack.eu size: 1599)

#!r6rs
;; Copyright (c) 2009 Derick Eddington.  All rights reserved.
;; Licensed under an MIT-style license.  My license is in the file
;; named LICENSE from the original collection this file is distributed
;; with.  If this file is redistributed with some other collection, my
;; license must also be included.

(library (srfi s23 error tricks)
  (export
    SRFI-23-error->R6RS)
  (import
    (rnrs))

  (define-syntax error-wrap
    (lambda (stx)
      (syntax-case stx ()
        ((_ ctxt signal expr ...)
         (with-syntax ((e (datum->syntax #'ctxt 'error)))
           #'(let-syntax ((e (identifier-syntax signal)))
               expr ...))))))

  (define (AV who)
    (lambda args (apply assertion-violation who args)))

  (define-syntax SRFI-23-error->R6RS
    (lambda (stx)
      (syntax-case stx ()
        ((ctxt ewho expr ...)
         (with-syntax ((e (datum->syntax #'ctxt 'error))
                       (d (datum->syntax #'ctxt 'define)))
           #'(let-syntax ((e (identifier-syntax (AV 'ewho)))
                          (d (lambda (stx)
                               (syntax-case stx ()
                                 ((kw (id . formals) . body)
                                  (identifier? #'id)
                                  #'(error-wrap kw (AV 'id)
                                     (d (id . formals) . body)))
                                 ((kw id . r)
                                  (identifier? #'id)
                                  #'(error-wrap kw (AV 'id)
                                     (d id . r)))))))
               expr ...))))))
)