From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andreas Rottmann Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Some tweaks to the R6RS support Date: Wed, 27 Oct 2010 00:53:17 +0200 Message-ID: <87r5fcftwi.fsf@delenn.lan> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1288133720 20986 80.91.229.12 (26 Oct 2010 22:55:20 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Tue, 26 Oct 2010 22:55:20 +0000 (UTC) To: Guile Development Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Wed Oct 27 00:55:16 2010 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1PAsOz-0003O1-G4 for guile-devel@m.gmane.org; Wed, 27 Oct 2010 00:55:11 +0200 Original-Received: from localhost ([127.0.0.1]:53976 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PAsOq-0000fO-Fc for guile-devel@m.gmane.org; Tue, 26 Oct 2010 18:53:48 -0400 Original-Received: from [140.186.70.92] (port=46559 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1PAsOi-0000T0-K7 for guile-devel@gnu.org; Tue, 26 Oct 2010 18:53:44 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1PAsOX-0001hU-3g for guile-devel@gnu.org; Tue, 26 Oct 2010 18:53:31 -0400 Original-Received: from mailout-de.gmx.net ([213.165.64.23]:56745 helo=mail.gmx.net) by eggs.gnu.org with smtp (Exim 4.71) (envelope-from ) id 1PAsOW-0001h2-NJ for guile-devel@gnu.org; Tue, 26 Oct 2010 18:53:29 -0400 Original-Received: (qmail invoked by alias); 26 Oct 2010 22:53:25 -0000 Original-Received: from 83-215-154-5.hage.dyn.salzburg-online.at (EHLO nathot.lan) [83.215.154.5] by mail.gmx.net (mp023) with SMTP; 27 Oct 2010 00:53:25 +0200 X-Authenticated: #3102804 X-Provags-ID: V01U2FsdGVkX19FSg9wyExFtgSiiYKmIU9Jk8Yw2ecFa3nXhltwUT PbmGCe++ztuWg4 Original-Received: from localhost (localhost.localdomain [127.0.0.1]) by nathot.lan (Postfix) with ESMTP id E881D3A695 for ; Wed, 27 Oct 2010 00:53:24 +0200 (CEST) Original-Received: from nathot.lan ([127.0.0.1]) by localhost (nathot.lan [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id H9+84kEYj-aH for ; Wed, 27 Oct 2010 00:53:17 +0200 (CEST) Original-Received: from delenn.lan (delenn.lan [192.168.3.11]) by nathot.lan (Postfix) with ESMTP id BD6AA3A693 for ; Wed, 27 Oct 2010 00:53:17 +0200 (CEST) Original-Received: by delenn.lan (Postfix, from userid 1000) id 7B4E974EEF; Wed, 27 Oct 2010 00:53:17 +0200 (CEST) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/23.2 (gnu/linux) X-Y-GMX-Trusted: 0 X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:11071 Archived-At: --=-=-= * 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'. --=-=-= Content-Type: text/x-diff Content-Disposition: attachment; filename=rnrs-tweaks.diff From: Andreas Rottmann Subject: Some tweaks to the R6RS support * 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'. --- module/rnrs/base.scm | 31 +++++++++++++++++++++++++------ module/rnrs/conditions.scm | 15 ++++----------- module/rnrs/records/inspection.scm | 30 ++++++++++++++++-------------- module/rnrs/records/syntactic.scm | 10 ++++++---- test-suite/tests/r6rs-conditions.test | 14 +++++++++++++- 5 files changed, 64 insertions(+), 36 deletions(-) diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm index 74fce31..2357032 100644 --- a/module/rnrs/base.scm +++ b/module/rnrs/base.scm @@ -71,7 +71,8 @@ let-syntax letrec-syntax syntax-rules identifier-syntax) - (import (rename (guile) (quotient div) (modulo mod)) + (import (rename (except (guile) error raise) + (quotient div) (modulo mod)) (srfi srfi-11)) (define (vector-for-each proc . vecs) @@ -98,6 +99,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 @@ -106,12 +109,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)))))))) ) diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm index b897221..3fc1b85 100644 --- a/module/rnrs/conditions.scm +++ b/module/rnrs/conditions.scm @@ -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 diff --git a/module/rnrs/records/inspection.scm b/module/rnrs/records/inspection.scm index 315ef0c..68b78a9 100644 --- a/module/rnrs/records/inspection.scm +++ b/module/rnrs/records/inspection.scm @@ -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)) ) diff --git a/module/rnrs/records/syntactic.scm b/module/rnrs/records/syntactic.scm index 5070212..6431fcf 100644 --- a/module/rnrs/records/syntactic.scm +++ b/module/rnrs/records/syntactic.scm @@ -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 diff --git a/test-suite/tests/r6rs-conditions.test b/test-suite/tests/r6rs-conditions.test index 9432f37..7480b9c 100644 --- a/test-suite/tests/r6rs-conditions.test +++ b/test-suite/tests/r6rs-conditions.test @@ -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))))) -- tg: (fe15364..) t/rnrs-tweaks (depends on: master) --=-=-= Regards, Rotty -- Andreas Rottmann -- --=-=-=--