Author: yamakenz
Date: Sat Sep 8 07:43:59 2007
New Revision: 4946
Added:
sigscheme-trunk/test/test-legacy-macro.scm
Modified:
sigscheme-trunk/QALog
sigscheme-trunk/src/eval.c
sigscheme-trunk/src/legacy-macro.c
sigscheme-trunk/test/Makefile.am
Log:
[QA] legacy-macro.c, eval.c
* src/legacy-macro.c
- (scm_s_define_macro):
* Fix defining non-closure value as an ordinary variable
* Modify error message
* src/eval.c
- (call): Modify comment
* test/test-legacy-macro.scm
- New file
- Add various tests for define-macro
* test/Makefile.am
- (sscm_tests): Add test-legacy-macro.scm
* QALog
- Update
Modified: sigscheme-trunk/QALog
==============================================================================
--- sigscheme-trunk/QALog (original)
+++ sigscheme-trunk/QALog Sat Sep 8 07:43:59 2007
@@ -282,7 +282,7 @@
yyyy yyy srfi module-srfi48.c
yyyy yy srfi module-srfi55.c
yyyyyyyy srfi module-srfi60.c
- opt legacy-macro.c
+yyyy yyy opt legacy-macro.c
y yy y opt module-sscm-ext.c
y yy y opt module-siod.c
other main.c
@@ -692,14 +692,14 @@
file: eval.c
category: core
-spec by eyes: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED],
[EMAIL PROTECTED], [EMAIL PROTECTED]
-spec by tests: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED],
[EMAIL PROTECTED]
-general review: [EMAIL PROTECTED]
-64-bit by eyes: [EMAIL PROTECTED]
-64-bit by tests:
-coding style: [EMAIL PROTECTED]
-normal case tests: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED]
-corner case tests: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED]
+spec by eyes: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED],
[EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED]
+spec by tests: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED],
[EMAIL PROTECTED], [EMAIL PROTECTED]
+general review: [EMAIL PROTECTED], [EMAIL PROTECTED]
+64-bit by eyes: [EMAIL PROTECTED], [EMAIL PROTECTED]
+64-bit by tests:
+coding style: [EMAIL PROTECTED], [EMAIL PROTECTED]
+normal case tests: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED],
[EMAIL PROTECTED]
+corner case tests: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED],
[EMAIL PROTECTED]
file: module.c
category: core
@@ -1066,14 +1066,14 @@
file: legacy-macro.c
category: opt
-spec by eyes:
-spec by tests:
-general review:
-64-bit by eyes:
-64-bit by tests:
-coding style:
-normal case tests:
-corner case tests:
+spec by eyes: [EMAIL PROTECTED]
+spec by tests: [EMAIL PROTECTED]
+general review: [EMAIL PROTECTED]
+64-bit by eyes: [EMAIL PROTECTED]
+64-bit by tests:
+coding style: [EMAIL PROTECTED]
+normal case tests: [EMAIL PROTECTED]
+corner case tests: [EMAIL PROTECTED]
file: module-sscm-ext.c
category: opt
@@ -1136,6 +1136,10 @@
2007-09-08 YamaKen <yamaken AT bp.iij4u.or.jp>
* module-srfi43.c
- QA done @r4943 with test-srfi43.scm
+
+ * legacy-macro.c
+ * eval.c
+ - QA done @r4946 for define-macro with test-legacy-macro.scm
2007-09-04 YamaKen <yamaken AT bp.iij4u.or.jp>
* module-srfi9.c
Modified: sigscheme-trunk/src/eval.c
==============================================================================
--- sigscheme-trunk/src/eval.c (original)
+++ sigscheme-trunk/src/eval.c Sat Sep 8 07:43:59 2007
@@ -263,7 +263,8 @@
ret = SCM_FINISH_TAILREC_CALL(ret, eval_state);
/* restore previous env */
eval_state->env = env;
- /* eval returned object again as a syntactic form. */
+ /* Instruct evaluating returned object again as a syntactic
+ * form. */
eval_state->ret_type = SCM_VALTYPE_NEED_EVAL;
#if SCM_STRICT_TOPLEVEL_DEFINITIONS
/* Workaround to allow toplevel definitions by the returned
Modified: sigscheme-trunk/src/legacy-macro.c
==============================================================================
--- sigscheme-trunk/src/legacy-macro.c (original)
+++ sigscheme-trunk/src/legacy-macro.c Sat Sep 8 07:43:59 2007
@@ -76,8 +76,8 @@
scm_gc_protect_with_init(&scm_syntactic_closure_env, syn_closure_env);
}
-/* To test ScmNestState, scm_s_define() needs eval_state although this is not a
- * tail-recursive syntax */
+/* To test ScmNestState, scm_s_define() needs ScmEvalState although this is not
+ * a tail-recursive syntax */
SCM_EXPORT ScmObj
scm_s_define_macro(ScmObj identifier, ScmObj rest, ScmEvalState *eval_state)
{
@@ -113,9 +113,11 @@
identifier = SCM_UNWRAP_KEYWORD(identifier);
closure = SCM_SYMBOL_VCELL(identifier);
+ if (!CLOSUREP(closure))
+ SCM_SYMBOL_SET_VCELL(identifier, SCM_UNBOUND);
ENSURE_CLOSURE(closure);
if (!scm_toplevel_environmentp(SCM_CLOSURE_ENV(closure)))
- ERR("syntactic closure must have toplevel environment");
+ ERR("syntactic closure in SigScheme must have toplevel environment");
/* destructively mark the closure as syntactic */
SCM_CLOSURE_SET_ENV(closure, SCM_SYNTACTIC_CLOSURE_ENV);
Modified: sigscheme-trunk/test/Makefile.am
==============================================================================
--- sigscheme-trunk/test/Makefile.am (original)
+++ sigscheme-trunk/test/Makefile.am Sat Sep 8 07:43:59 2007
@@ -24,6 +24,7 @@
test-formal-syntax.scm \
test-formatplus.scm \
test-lambda.scm \
+ test-legacy-macro.scm \
test-let.scm \
test-letstar.scm \
test-letrec.scm \
Added: sigscheme-trunk/test/test-legacy-macro.scm
==============================================================================
--- (empty file)
+++ sigscheme-trunk/test/test-legacy-macro.scm Sat Sep 8 07:43:59 2007
@@ -0,0 +1,220 @@
+;; Filename : test-legacy-macro.scm
+;; About : unit tests for legacy define-macro
+;;
+;; Copyright (c) 2007 SigScheme Project <uim-en AT googlegroups.com>
+;;
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;; 3. Neither the name of authors nor the names of its contributors
+;; may be used to endorse or promote products derived from this software
+;; without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;; SigScheme does not have gensym.
+
+(require-extension (unittest))
+
+
+(test-begin "define-macro invalid forms")
+;; invalid identifier
+(test-error (define-macro #\m (lambda () #t)))
+(test-error (define-macro "m" (lambda () #f)))
+;; invalid closure
+(test-error (define-macro m '(lambda () #t)))
+(test-error (define-macro m #f))
+(test-error m) ;; must be unbound here
+;; syntactic keyword
+(test-error (define-macro m and))
+;; another macro as alias
+(define-macro m (lambda () #t))
+(test-error (define-macro m2 m))
+(test-end)
+
+(test-begin "define-macro non-toplevel env")
+(cond-expand
+ (sigscheme
+ ;; SigScheme does not accept non-toplevel env for syntactic closures.
+ (test-error (define-macro m
+ (let ((?var 'val))
+ (lambda ()
+ ``,?var)))))
+ (else
+ (define-macro m
+ (let ((?var 'val))
+ (lambda ()
+ ``,?var)))
+ (test-eq 'val (m))))
+(test-end)
+
+(test-begin "define-macro referring runtime env")
+(define cnt 0)
+(define-macro m
+ (lambda ()
+ (set! cnt (+ cnt 1))
+ cnt))
+;; The macro is expanded for each instantiation.
+(test-eqv 1 (m))
+(test-eqv 2 (m))
+(test-eqv 3 (m))
+(define proc-m
+ (lambda ()
+ (m)))
+(cond-expand
+ (sigscheme
+ ;; SigScheme expands the macro for each procedure call.
+ (test-eqv 4 (proc-m))
+ (test-eqv 5 (proc-m))
+ (test-eqv 6 (proc-m)))
+ (else
+ ;; Ordinary implementations expand the macro only once.
+ (test-eqv 4 (proc-m))
+ (test-eqv 4 (proc-m))
+ (test-eqv 4 (proc-m))))
+(test-end)
+
+(test-begin "define-macro varname conflict")
+(define foo 1)
+(define bar 2)
+(define tmp 3)
+(define-macro swap
+ (lambda (x y)
+ `(let ((tmp ,x))
+ (set! ,x ,y)
+ (set! ,y tmp))))
+(swap foo bar)
+(test-eqv 2 foo)
+(test-eqv 1 bar)
+(test-eqv 3 tmp)
+(swap foo bar)
+(test-eqv 1 foo)
+(test-eqv 2 bar)
+(test-eqv 3 tmp)
+(swap foo tmp)
+(test-eqv 1 foo)
+(test-eqv 2 bar)
+(test-eqv 3 tmp)
+(swap foo tmp)
+(test-eqv 1 foo)
+(test-eqv 2 bar)
+(test-eqv 3 tmp)
+(test-end)
+
+(test-begin "define-macro evaluation timings")
+(define foo 3)
+(define bar 4)
+(define-macro m
+ (lambda ()
+ '(+ foo bar)))
+(define-macro m2
+ (lambda ()
+ (+ foo bar)))
+(define proc-m
+ (lambda ()
+ (m)))
+(define proc-m2
+ (lambda ()
+ (m2)))
+(test-eqv 7 (m))
+(test-eqv 7 (m2))
+(test-eqv 7 (proc-m))
+(test-eqv 7 (proc-m2))
+(set! foo 5)
+(test-eqv 9 (m))
+(test-eqv 9 (m2))
+(test-eqv 9 (proc-m))
+(cond-expand
+ (sigscheme
+ (test-eqv 9 (proc-m2)))
+ (else
+ (test-eqv 7 (proc-m2))))
+(test-end)
+
+(test-begin "define-macro syntactic keywords handling")
+(define-macro m
+ (lambda (op x y)
+ `(,op ,x ,y)))
+(test-false (m and #f #f))
+(test-false (m and #f #t))
+(test-false (m and #t #f))
+(test-true (m and #t #t))
+(test-false (m or #f #f))
+(test-true (m or #f #t))
+(test-true (m or #t #f))
+(test-true (m or #t #t))
+(define-macro m
+ (lambda args
+ `,args))
+(test-false (m and #f #f))
+(test-false (m and #f #t))
+(test-false (m and #t #f))
+(test-true (m and #t #t))
+(test-true (m and #t #t #t))
+(test-false (m or #f #f))
+(test-true (m or #f #t))
+(test-true (m or #t #f))
+(test-true (m or #t #t))
+(test-true (m or #t #t #f))
+(define-macro (m op x y)
+ `(,op ,x ,y))
+(test-false (m and #f #f))
+(test-false (m and #f #t))
+(test-false (m and #t #f))
+(test-true (m and #t #t))
+(test-false (m or #f #f))
+(test-true (m or #f #t))
+(test-true (m or #t #f))
+(test-true (m or #t #t))
+(define-macro (m . args)
+ `,args)
+(test-false (m and #f #f))
+(test-false (m and #f #t))
+(test-false (m and #t #f))
+(test-true (m and #t #t))
+(test-true (m and #t #t #t))
+(test-false (m or #f #f))
+(test-true (m or #f #t))
+(test-true (m or #t #f))
+(test-true (m or #t #t))
+(test-true (m or #t #t #f))
+(test-end)
+
+(test-begin "define-macro nested macro")
+(define-macro swap
+ (lambda (x y)
+ `(let ((?tmp ,x))
+ (set! ,x ,y)
+ (set! ,y ?tmp))))
+(define-macro m
+ (lambda (x y)
+ `(begin
+ (swap ,x ,y)
+ (- ,x ,y))))
+(define foo 3)
+(define bar 4)
+(test-eqv -1 (- foo bar))
+(test-eqv 1 (m foo bar))
+(test-eqv 4 foo)
+(test-eqv 3 bar)
+(test-end)
+
+(test-report-result)
