mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 02:00:26 +02:00
Code Activity

Some tweaks to the R6RS support

Browse source 
* module/rnrs/base.scm (error, assert): Define -- they were missing.
  (assertion-violation): Properly treat a #f `who' argument.

* module/rnrs/conditions.scm (condition): Use `assertion-violation'
  instead of the undefined `raise'.
  (define-condition-type): Fix for multiple fields.
* test-suite/tests/r6rs-conditions.test: Test accessors of a
  multiple-field condition.  Also import `(rnrs base)' to allow
  stand-alone running of the tests; apparently the `@' references
  scattered throughout the R6RS modules make the libraries sensitive to
  their load order -- for instance, trying to load `(rnrs conditions)'
  before `(rnrs base)' is loaded fails.

* module/rnrs/records/inspection.scm: Use `assertion-violation' instead
  of an explicit `raise'.
* module/rnrs/records/syntactic.scm (process-fields): Use
  `syntax-violation' instead of bogus invocations of `error'.
This commit is contained in:
Andreas Rottmann 2010-11-25 23:03:12 +01:00 • committed by Andy Wingo
parent 43ecaffc2f
commit c0f6c1638b
5 changed files with 63 additions and 36 deletions
Download patch file Download diff file Expand all files Collapse all files

30
module/rnrs/base.scm
View file

@ -73,7 +73,7 @@
let-syntax letrec-syntax
syntax-rules identifier-syntax)
(import (rename (guile)
(import (rename (except (guile) error raise)
(quotient div)
(modulo mod)
(exact->inexact inexact)
@ -137,6 +137,8 @@
(@ (rnrs exceptions) raise))
(define condition
(@ (rnrs conditions) condition))
(define make-error
(@ (rnrs conditions) make-error))
(define make-assertion-violation
(@ (rnrs conditions) make-assertion-violation))
(define make-who-condition
@ -145,12 +147,28 @@
(@ (rnrs conditions) make-message-condition))
(define make-irritants-condition
(@ (rnrs conditions) make-irritants-condition))
(define (error who message . irritants)
(raise (apply condition
(append (list (make-error))
(if who (list (make-who-condition who)) '())
(list (make-message-condition message)
(make-irritants-condition irritants))))))
(define (assertion-violation who message . irritants)
(raise (condition
(make-assertion-violation)
(make-who-condition who)
(make-message-condition message)
(make-irritants-condition irritants))))
(raise (apply condition
(append (list (make-assertion-violation))
(if who (list (make-who-condition who)) '())
(list (make-message-condition message)
(make-irritants-condition irritants))))))
(define-syntax assert
(syntax-rules ()
((_ expression)
(if (not expression)
(raise (condition
(make-assertion-violation)
(make-message-condition
(format #f "assertion failed: ~s" 'expression))))))))
)