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 R6RS fixes Date: Sat, 14 Aug 2010 18:12:13 +0200 Message-ID: <87aaopw4v6.fsf@delenn.lan> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1281802363 3698 80.91.229.12 (14 Aug 2010 16:12:43 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sat, 14 Aug 2010 16:12:43 +0000 (UTC) To: Guile Development Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sat Aug 14 18:12:41 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 1OkJLd-0007zU-37 for guile-devel@m.gmane.org; Sat, 14 Aug 2010 18:12:41 +0200 Original-Received: from localhost ([127.0.0.1]:59913 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OkJLc-0005WS-7n for guile-devel@m.gmane.org; Sat, 14 Aug 2010 12:12:40 -0400 Original-Received: from [140.186.70.92] (port=56871 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OkJLT-0005VU-RS for guile-devel@gnu.org; Sat, 14 Aug 2010 12:12:36 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.69) (envelope-from ) id 1OkJLO-0002Ro-Jk for guile-devel@gnu.org; Sat, 14 Aug 2010 12:12:31 -0400 Original-Received: from mailout-de.gmx.net ([213.165.64.23]:57078 helo=mail.gmx.net) by eggs.gnu.org with smtp (Exim 4.69) (envelope-from ) id 1OkJLO-0002Rb-71 for guile-devel@gnu.org; Sat, 14 Aug 2010 12:12:26 -0400 Original-Received: (qmail invoked by alias); 14 Aug 2010 16:12:24 -0000 Original-Received: from 83-215-154-5.hage.dyn.salzburg-online.at (EHLO nathot.lan) [83.215.154.5] by mail.gmx.net (mp011) with SMTP; 14 Aug 2010 18:12:24 +0200 X-Authenticated: #3102804 X-Provags-ID: V01U2FsdGVkX1++P/5sZ5G+EyFVqWQwU2mpCY6zAr7eslhHknmvhC bBp4gb2gqDMOLo Original-Received: from localhost (localhost.localdomain [127.0.0.1]) by nathot.lan (Postfix) with ESMTP id 120B23A695 for ; Sat, 14 Aug 2010 18:12:23 +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 ZySmxvzFcNFo for ; Sat, 14 Aug 2010 18:12:14 +0200 (CEST) Original-Received: from delenn.lan (delenn.lan [192.168.3.11]) by nathot.lan (Postfix) with ESMTP id 2F8523A693 for ; Sat, 14 Aug 2010 18:12:14 +0200 (CEST) Original-Received: by delenn.lan (Postfix, from userid 1000) id E63BC4A8441; Sat, 14 Aug 2010 18:12:13 +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:10764 Archived-At: --=-=-= Some smallish fixes to the (rnrs ...) modules. --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=rnrs-fixes.diff From: Andreas Rottmann Subject: Several fixes to R6RS libraries * module/rnrs/arithmetic/fixnums.scm (fixnum-width): Make this return an an exact integer instead of an inexact number. * module/rnrs/base.scm (assertion-violation): Implement. * module/rnrs/conditions.scm (simple-conditions): Allow also simple conditions as argument. * module/rnrs/enums.scm (define-enumeration): Properly construct empty enumeration sets. * module/rnrs/exceptions.scm (guard): Don't restrict the body to a single expression. * module/rnrs/records/syntactic.scm (define-record-type0): Expand into a series of definitions only. --- module/rnrs/arithmetic/fixnums.scm | 2 +- module/rnrs/base.scm | 20 ++++++++++++++++++++ module/rnrs/conditions.scm | 12 +++++++++++- module/rnrs/enums.scm | 1 - module/rnrs/exceptions.scm | 12 ++++++------ module/rnrs/records/syntactic.scm | 11 +++++++---- 6 files changed, 45 insertions(+), 13 deletions(-) diff --git a/module/rnrs/arithmetic/fixnums.scm b/module/rnrs/arithmetic/fixnums.scm index cda1933..c1f3571 100644 --- a/module/rnrs/arithmetic/fixnums.scm +++ b/module/rnrs/arithmetic/fixnums.scm @@ -93,7 +93,7 @@ (rnrs lists (6))) (define fixnum-width - (let ((w (round (/ (log (+ most-positive-fixnum 1)) (log 2))))) + (let ((w (inexact->exact (round (/ (log (+ most-positive-fixnum 1)) (log 2)))))) (lambda () w))) (define (greatest-fixnum) most-positive-fixnum) diff --git a/module/rnrs/base.scm b/module/rnrs/base.scm index e92089e..74fce31 100644 --- a/module/rnrs/base.scm +++ b/module/rnrs/base.scm @@ -94,4 +94,24 @@ ((negative? y) (values (- q 1) (+ r y))) (else (values (+ q 1) (+ r y))))))) + (define raise + (@ (rnrs exceptions) raise)) + (define condition + (@ (rnrs conditions) condition)) + (define make-assertion-violation + (@ (rnrs conditions) make-assertion-violation)) + (define make-who-condition + (@ (rnrs conditions) make-who-condition)) + (define make-message-condition + (@ (rnrs conditions) make-message-condition)) + (define make-irritants-condition + (@ (rnrs conditions) make-irritants-condition)) + + (define (assertion-violation who message . irritants) + (raise (condition + (make-assertion-violation) + (make-who-condition who) + (make-message-condition message) + (make-irritants-condition irritants)))) + ) diff --git a/module/rnrs/conditions.scm b/module/rnrs/conditions.scm index 53d4d0f..b897221 100644 --- a/module/rnrs/conditions.scm +++ b/module/rnrs/conditions.scm @@ -95,7 +95,17 @@ (define make-compound-condition (record-constructor (make-record-constructor-descriptor &compound-condition #f #f))) - (define simple-conditions (record-accessor &compound-condition 0)) + (define simple-conditions + (let ((compound-ref (record-accessor &compound-condition 0))) + (lambda (condition) + (cond ((compound-condition? condition) + (compound-ref condition)) + ((condition-internal? condition) + (list condition)) + (else + (assertion-violation 'simple-conditions + "not a condition" + condition)))))) (define (condition? obj) (or (compound-condition? obj) (condition-internal? obj))) diff --git a/module/rnrs/enums.scm b/module/rnrs/enums.scm index cd7e346..79d3417 100644 --- a/module/rnrs/enums.scm +++ b/module/rnrs/enums.scm @@ -137,7 +137,6 @@ (define-syntax constructor-syntax (lambda (s) (syntax-case s () - ((_) (syntax #f)) ((_ sym (... ...)) (let* ((universe '(symbol ...)) (syms (syntax->datum #'(sym (... ...)))) diff --git a/module/rnrs/exceptions.scm b/module/rnrs/exceptions.scm index cd5bacf..ff4049b 100644 --- a/module/rnrs/exceptions.scm +++ b/module/rnrs/exceptions.scm @@ -51,17 +51,17 @@ (define-syntax guard0 (syntax-rules () - ((_ (variable cond-clause ...) body) + ((_ (variable cond-clause ...) . body) (call/cc (lambda (continuation) (with-exception-handler (lambda (variable) (continuation (cond cond-clause ...))) - (lambda () body))))))) + (lambda () . body))))))) (define-syntax guard (syntax-rules (else) - ((_ (variable cond-clause ... . ((else else-clause ...))) body) - (guard0 (variable cond-clause ... (else else-clause ...)) body)) - ((_ (variable cond-clause ...) body) - (guard0 (variable cond-clause ... (else (raise variable))) body)))) + ((_ (variable cond-clause ... . ((else else-clause ...))) . body) + (guard0 (variable cond-clause ... (else else-clause ...)) . body)) + ((_ (variable cond-clause ...) . body) + (guard0 (variable cond-clause ... (else (raise variable))) . body)))) ) diff --git a/module/rnrs/records/syntactic.scm b/module/rnrs/records/syntactic.scm index d46efbc..5070212 100644 --- a/module/rnrs/records/syntactic.scm +++ b/module/rnrs/records/syntactic.scm @@ -177,10 +177,13 @@ (record-constructor (make-record-constructor-descriptor record-name #,parent-cd #,protocol))) - (register-record-type - #,record-name-sym - record-name (make-record-constructor-descriptor - record-name #,parent-cd #,protocol)) + (define dummy + (let () + (register-record-type + #,record-name-sym + record-name (make-record-constructor-descriptor + record-name #,parent-cd #,protocol)) + 'dummy)) (define predicate-name (record-predicate record-name)) #,@field-accessors #,@field-mutators)) -- tg: (802b47b..) t/rnrs-fixes (depends on: master) --=-=-= Cheers, Rotty -- Andreas Rottmann -- --=-=-=--