mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +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))))))))
)

15
module/rnrs/conditions.scm
View file

@ -115,7 +115,7 @@
(define (flatten cond)
(if (compound-condition? cond) (simple-conditions cond) (list cond)))
(or (for-all condition? conditions)
(raise (make-assertion-violation)))
(assertion-violation 'condition "non-condition argument" conditions))
(if (or (null? conditions) (> (length conditions) 1))
(make-compound-condition (apply append (map flatten conditions)))
(car conditions))))
@ -128,9 +128,7 @@
((transform-fields
(syntax-rules ()
((_ (f a) . rest)
(cons '(immutable f a) (transform-fields rest)))
((_ ((f a))) '((immutable f a)))
((_ ()) '())
(cons '(immutable f a) (transform-fields . rest)))
((_) '())))
(generate-accessors
@ -140,13 +138,8 @@
(condition-accessor
condition-type
(record-accessor condition-type counter)))
(generate-accessors (+ counter 1) rest)))
((_ counter ((f a)))
(define a
(condition-accessor
condition-type (record-accessor condition-type counter))))
((_ counter ()) (begin))
((_ counter) (begin)))))
(generate-accessors (+ counter 1) . rest)))
((_ counter) (begin)))))
(begin
(define condition-type
(make-record-type-descriptor

30
module/rnrs/records/inspection.scm
View file

@ -30,8 +30,6 @@
record-field-mutable?)
(import (rnrs arithmetic bitwise (6))
(rnrs base (6))
(rnrs conditions (6))
(rnrs exceptions (6))
(rnrs records procedural (6))
(only (guile) struct-ref struct-vtable vtable-index-layout @@))
@ -55,25 +53,29 @@
(or (and (record-internal? record)
(let ((rtd (struct-vtable record)))
(and (not (struct-ref rtd rtd-index-opaque?)) rtd)))
(raise (make-assertion-violation))))
(assertion-violation 'record-rtd "not a record" record)))
(define (ensure-rtd rtd)
(if (not (record-type-descriptor? rtd)) (raise (make-assertion-violation))))
(define (guarantee-rtd who rtd)
(if (record-type-descriptor? rtd)
rtd
(assertion-violation who "not a record type descriptor" rtd)))
(define (record-type-name rtd)
(ensure-rtd rtd) (struct-ref rtd rtd-index-name))
(struct-ref (guarantee-rtd 'record-type-name rtd) rtd-index-name))
(define (record-type-parent rtd)
(ensure-rtd rtd) (struct-ref rtd rtd-index-parent))
(define (record-type-uid rtd) (ensure-rtd rtd) (struct-ref rtd rtd-index-uid))
(struct-ref (guarantee-rtd 'record-type-parent rtd) rtd-index-parent))
(define (record-type-uid rtd)
(struct-ref (guarantee-rtd 'record-type-uid rtd) rtd-index-uid))
(define (record-type-generative? rtd)
(ensure-rtd rtd) (not (record-type-uid rtd)))
(not (record-type-uid (guarantee-rtd 'record-type-generative? rtd))))
(define (record-type-sealed? rtd)
(ensure-rtd rtd) (struct-ref rtd rtd-index-sealed?))
(struct-ref (guarantee-rtd 'record-type-sealed? rtd) rtd-index-sealed?))
(define (record-type-opaque? rtd)
(ensure-rtd rtd) (struct-ref rtd rtd-index-opaque?))
(struct-ref (guarantee-rtd 'record-type-opaque? rtd) rtd-index-opaque?))
(define (record-type-field-names rtd)
(ensure-rtd rtd) (struct-ref rtd rtd-index-field-names))
(struct-ref (guarantee-rtd 'record-type-field-names rtd) rtd-index-field-names))
(define (record-field-mutable? rtd k)
(ensure-rtd rtd)
(bitwise-bit-set? (struct-ref rtd rtd-index-field-bit-field) k))
(bitwise-bit-set? (struct-ref (guarantee-rtd 'record-field-mutable? rtd)
rtd-index-field-bit-field)
k))
)

10
module/rnrs/records/syntactic.scm
View file

@ -85,14 +85,16 @@
record-name-str "-" (symbol->string field-name) "-set!")))
(define (f x)
(define (lose)
(syntax-violation 'define-record-type "invalid field specifier" x))
(cond ((symbol? x) (list 'immutable x (guess-accessor-name x) #f))
((not (list? x)) (error))
((not (list? x)) (lose))
((eq? (car x) 'immutable)
(cons 'immutable
(case (length x)
((2) (list (cadr x) (guess-accessor-name (cadr x)) #f))
((3) (list (cadr x) (caddr x) #f))
(else (error)))))
(else (lose)))))
((eq? (car x) 'mutable)
(cons 'mutable
(case (length x)
@ -100,8 +102,8 @@
(guess-accessor-name (cadr x))
(guess-mutator-name (cadr x))))
((4) (cdr x))
(else (error)))))
(else (error))))
(else (lose)))))
(else (lose))))
(map f fields))
(define-syntax define-record-type0

14
test-suite/tests/r6rs-conditions.test
View file

@ -18,11 +18,16 @@
(define-module (test-suite test-rnrs-conditions)
:use-module ((rnrs base) :version (6))
:use-module ((rnrs conditions) :version (6))
:use-module (test-suite lib))
(define-condition-type &a &condition make-a-condition a-condition? (foo a-foo))
(define-condition-type &b &condition make-b-condition b-condition? (bar b-bar))
(define-condition-type &c &condition make-c-condition c-condition?
(baz c-baz)
(qux c-qux)
(frobotz c-frobotz))
(with-test-prefix "condition?"
(pass-if "condition? is #t for simple conditions"
@ -96,4 +101,11 @@
(with-test-prefix "define-condition-type"
(pass-if "define-condition-type produces proper accessors"
(let ((c (condition (make-a-condition 'foo) (make-b-condition 'bar))))
(and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar)))))
(and (eq? (a-foo c) 'foo) (eq? (b-bar c) 'bar))))
(pass-if "define-condition-type works for multiple fields"
(let ((c (condition (make-a-condition 'foo)
(make-c-condition 1 2 3))))
(and (eq? (a-foo c) 'foo)
(= (c-baz c) 1)
(= (c-qux c) 2)
(= (c-frobotz c) 3)))))