Author: yamakenz
Date: Fri Jun 29 08:18:47 2007
New Revision: 4613
Modified:
sigscheme-trunk/NEWS
sigscheme-trunk/QALog
sigscheme-trunk/lib/srfi-1.scm
sigscheme-trunk/src/env.c
sigscheme-trunk/src/module-srfi1.c
sigscheme-trunk/test/test-misc.scm
sigscheme-trunk/test/test-srfi1.scm
Log:
* src/module-srfi1.c
- (scm_p_srfi1_find_tail): Fix invalid error on element not found cases
* src/env.c
- (scm_valid_environment_extension_lengthp): Fix invalid assertion on
modifying optional arguments to a dotted or circular list. This bug only
appeared on --enable-debug
* test/test-misc.scm
- Add the tests for the optional arguments modification
* lib/srfi-1.scm
- (delete-duplicates!): Fix broken arguments receiving of the reference
implementation
* test/test-srfi1.scm
- Disable incorrect tests for null-list? not conforming to SRFI-1
* NEWS
* QALog
- Update
Modified: sigscheme-trunk/NEWS
==============================================================================
--- sigscheme-trunk/NEWS (original)
+++ sigscheme-trunk/NEWS Fri Jun 29 08:18:47 2007
@@ -39,6 +39,9 @@
- [SRFI-2] Fix body-less forms rejection on and-let* such as (and-let* ())
+ - [R5RS] Fix invalid assertion on modifying optional arguments to a dotted or
+ circular list (see test-misc.scm). This bug only appeared on --enable-debug
+
* Others
Modified: sigscheme-trunk/QALog
==============================================================================
--- sigscheme-trunk/QALog (original)
+++ sigscheme-trunk/QALog Fri Jun 29 08:18:47 2007
@@ -651,7 +651,7 @@
file: env.c
category: core
-spec by eyes: [EMAIL PROTECTED]
+spec by eyes: [EMAIL PROTECTED], [EMAIL PROTECTED]
spec by tests:
general review: [EMAIL PROTECTED]
64-bit by eyes: [EMAIL PROTECTED]
@@ -1081,6 +1081,10 @@
Log
---
+2007-06-30 YamaKen <yamaken AT bp.iij4u.or.jp>
+ * env.c
+ - QA done again @r4613 with test-misc.scm
+
2007-06-16 YamaKen <yamaken AT bp.iij4u.or.jp>
* module-sscm-ext.c
- QA done again @r4606 for newly added let-optionals* with
Modified: sigscheme-trunk/lib/srfi-1.scm
==============================================================================
--- sigscheme-trunk/lib/srfi-1.scm (original)
+++ sigscheme-trunk/lib/srfi-1.scm Fri Jun 29 08:18:47 2007
@@ -14,6 +14,7 @@
;; http://srfi.schemers.org/srfi-1/srfi-1-reference.scm
;; and adapted to SigScheme
;; 2007-06-15 yamaken Add for-each
+;; 2007-06-30 yamaken Fix broken arguments receiving of delete-duplicates!
;;; This is a library of list- and pair-processing functions. I wrote it after
@@ -1274,7 +1275,7 @@
(new-tail (recur (delete x tail elt=))))
(if (eq? tail new-tail) lis (cons x new-tail)))))))
-(define (delete-duplicates! lis maybe-=)
+(define (delete-duplicates! lis . maybe-=)
(let ((elt= (:optional maybe-= equal?)))
(check-arg procedure? elt= delete-duplicates!)
(let recur ((lis lis))
Modified: sigscheme-trunk/src/env.c
==============================================================================
--- sigscheme-trunk/src/env.c (original)
+++ sigscheme-trunk/src/env.c Fri Jun 29 08:18:47 2007
@@ -479,11 +479,20 @@
scm_valid_environment_extension_lengthp(scm_int_t formals_len,
scm_int_t actuals_len)
{
- if (SCM_LISTLEN_ERRORP(formals_len) || !SCM_LISTLEN_PROPERP(actuals_len))
+ if (SCM_LISTLEN_ERRORP(formals_len))
return scm_false;
if (SCM_LISTLEN_DOTTEDP(formals_len)) {
formals_len = SCM_LISTLEN_DOTTED(formals_len);
- return (formals_len <= actuals_len);
+ if (SCM_LISTLEN_PROPERP(actuals_len))
+ return (formals_len <= actuals_len);
+
+ /* (lambda args (set-cdr! args #t) args) */
+ if (SCM_LISTLEN_DOTTEDP(actuals_len))
+ return (formals_len <= SCM_LISTLEN_DOTTED(actuals_len));
+
+ /* (lambda args (set-cdr! args args) args) */
+ if (SCM_LISTLEN_CIRCULARP(actuals_len)) /* always true */
+ return scm_true;
}
return (formals_len == actuals_len);
}
Modified: sigscheme-trunk/src/module-srfi1.c
==============================================================================
--- sigscheme-trunk/src/module-srfi1.c (original)
+++ sigscheme-trunk/src/module-srfi1.c Fri Jun 29 08:18:47 2007
@@ -184,19 +184,19 @@
SCM_EXPORT ScmObj
scm_p_srfi1_find_tail(ScmObj pred, ScmObj lst)
{
- ScmObj tail, elm, rest, found;
+ ScmObj tail, elm, found, term;
DECLARE_FUNCTION("find-tail", procedure_fixed_2);
ENSURE_PROCEDURE(pred);
- rest = lst;
- FOR_EACH_PAIR (tail, rest) {
+ FOR_EACH_PAIR (tail, lst) {
elm = CAR(tail);
found = scm_call(pred, LIST_1(elm));
if (TRUEP(found))
return tail;
}
- CHECK_PROPER_LIST_TERMINATION(rest, lst);
+ term = CONSP(tail) ? CDR(tail) : tail;
+ CHECK_PROPER_LIST_TERMINATION(term, lst);
return SCM_FALSE;
}
Modified: sigscheme-trunk/test/test-misc.scm
==============================================================================
--- sigscheme-trunk/test/test-misc.scm (original)
+++ sigscheme-trunk/test/test-misc.scm Fri Jun 29 08:18:47 2007
@@ -89,5 +89,14 @@
(assert-eq? (tn) #f (procedure? '#(0 1 2)))
(assert-eq? (tn) #f (procedure? (vector 0 1 2)))
+(tn "Optional argument modification")
+;; Dotted
+(assert-equal? (tn)
+ '(a . #t)
+ ((lambda args (set-cdr! args #t) args) 'a 'b 'c))
+;; Circular
+(assert-equal? (tn)
+ 'a
+ (caddr ((lambda args (set-cdr! args args) args) 'a 'b)))
(total-report)
Modified: sigscheme-trunk/test/test-srfi1.scm
==============================================================================
--- sigscheme-trunk/test/test-srfi1.scm (original)
+++ sigscheme-trunk/test/test-srfi1.scm Fri Jun 29 08:18:47 2007
@@ -107,8 +107,10 @@
(assert-true "not-pair? test 4" (not-pair? null-lst))
; null-list?
(assert-false "null-list? test 1" (null-list? proper-lst))
-(assert-false "null-list? test 2" (null-list? circular-lst))
-(assert-error "null-list? test 3" (lambda () (null-list? dotted-lst)))
+;; It is an error to pass this procedure a value which is not a proper or
+;; circular list.
+;;(assert-false "null-list? test 2" (null-list? circular-lst))
+;;(assert-error "null-list? test 3" (lambda () (null-list? dotted-lst)))
(assert-true "null-list? test 4" (null-list? null-lst))
(define num-lst (iota 10 1))
