Kouhei Sutou
kou****@cozmi*****
2004年 4月 26日 (月) 00:00:39 JST
須藤です．
[Bug 532]にnamed letが無いと書いてあったので，テストのテスト
も兼ねて作ってみました．
# パッチには[Anthy-dev 781]の内容も含まれています．
普通(?)はnamed letをどう展開するかわからなかったので，
(let loop ((n1 a1)
(n2 a2)
...)
body)
を
(letrec ((loop (lambda (n1 n2 ...)
body)))
(loop a1 a2 ...))
というように展開するようにしました．
-------------- next part --------------
Index: test/test-macro.scm
===================================================================
--- test/test-macro.scm (revision 0)
+++ test/test-macro.scm (revision 0)
@@ -0,0 +1,35 @@
+#!/usr/bin/env gosh
+
+(use test.unit)
+
+(require "test/uim-test-utils")
+
+(define-uim-test-case "test macro"
+ ("test normal-let"
+ (assert-equal '(-1 "b" (c) d)
+ (uim '(let ((a -1)
+ (b "b")
+ (c '(c))
+ (d 'd))
+ (list a b c d))))
+ (assert-equal '() (uim '(let (a) a))))
+ ("test named-let"
+ (assert-equal '(4 3 2 1 0)
+ (uim '(let count-down ((lst '())
+ (i 0))
+ (if (< i 5)
+ (count-down (cons i lst) (+ i 1))
+ lst))))
+ (assert-equal '((6 1 3) (-5 -2))
+ (uim '(let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((> 0 (car numbers))
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg)))
+ (else
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg))))))))
Property changes on: test/test-macro.scm
___________________________________________________________________
Name: svn:executable
+ *
Index: test/test-uim-test-utils.scm
===================================================================
--- test/test-uim-test-utils.scm (revision 0)
+++ test/test-uim-test-utils.scm (revision 0)
@@ -0,0 +1,9 @@
+#!/usr/bin/env gosh
+
+(use test.unit)
+
+(require "test/uim-test-utils")
+
+(define-uim-test-case "test uim-test-utils"
+ ("test error"
+ (assert-error (lambda () (uim 'unbound-symbol)))))
Property changes on: test/test-uim-test-utils.scm
___________________________________________________________________
Name: svn:executable
+ *
Index: test/uim-test-utils.scm
===================================================================
--- test/uim-test-utils.scm (revision 751)
+++ test/uim-test-utils.scm (working copy)
@@ -1,5 +1,6 @@
(use gauche.process)
(use gauche.selector)
+(use srfi-13)
(use test.unit)
(sys-putenv "LIBUIM_SCM_FILES" "./scm")
@@ -13,40 +14,55 @@
(define add-test-case!
(with-module test.unit add-test-case!))
-(define *uim-process* #f)
-(define *uim-selector* (make <selector>))
+(define *uim-sh-process* #f)
+(define *uim-sh-selector* (make <selector>))
+
+(define (uim-sh-select port . timeout)
+ (selector-add! *uim-sh-selector*
+ port
+ (lambda (port flag)
+ (selector-delete! *uim-sh-selector* port #f #f))
+ '(r))
+ (not (zero? (apply selector-select *uim-sh-selector* timeout))))
+
+(define (uim-sh-write sexp out)
+ (set! (port-buffering out) :none)
+ (with-output-to-port out
+ (lambda ()
+ (write sexp)
+ (newline)
+ (flush))))
+
+(define (uim-sh-read in)
+ (set! (port-buffering in) :none)
+ (uim-sh-select in)
+ (let ((uim-sh-output (read in)))
+ (if (and (eq? 'ERROR: uim-sh-output)
+ (uim-sh-select output 3))
+ (error (string-trim-both (read-block 10000 in)))
+ uim-sh-output)))
+
(define (uim sexp)
- (write sexp (process-input *uim-process*))
- (flush-all-ports)
- (let ((output (process-output *uim-process*))
- (err (process-error *uim-process*)))
- (set! (port-buffering output) :none)
- (selector-add! *uim-selector*
- output
- (lambda (sock flag)
- (selector-delete! *uim-selector* sock #f #f))
- '(r))
- (selector-select *uim-selector*)
- (read output)))
+ (uim-sh-write sexp (process-input *uim-sh-process*))
+ (uim-sh-read (process-output *uim-sh-process*)))
(define (uim-bool sexp)
(not (null? (uim sexp))))
-(define (make-uim-setup-proc . args)
+(define (make-uim-sh-setup-proc . args)
(let-optionals* args ((additional-setup-proc (lambda () #f)))
(lambda ()
- (set! *uim-process* (run-process "uim/uim-sh"
- "-b"
- :input :pipe
- :output :pipe
- :error :pipe))
+ (set! *uim-sh-process* (run-process "uim/uim-sh"
+ "-b"
+ :input :pipe
+ :output :pipe))
(additional-setup-proc))))
-(define (make-uim-teadown-proc . args)
+(define (make-uim-sh-teadown-proc . args)
(let-optionals* args ((additional-teardown-proc (lambda () #f)))
(lambda ()
- (close-input-port (process-input *uim-process*))
- (set! *uim-process* #f)
+ (close-input-port (process-input *uim-sh-process*))
+ (set! *uim-sh-process* #f)
(additional-teardown-proc))))
(define-syntax define-uim-test-case
@@ -61,26 +77,26 @@
((_ name (setup setup-proc) (teardown teardown-proc) test ...)
(make <test-case>
:name name
- :setup (make-uim-setup-proc setup-proc)
- :teardown (make-uim-teadown-proc teardown-proc)
+ :setup (make-uim-sh-setup-proc setup-proc)
+ :teardown (make-uim-sh-teadown-proc teardown-proc)
:tests (make-tests test ...)))
((_ name (setup proc) test ...)
(make <test-case>
:name name
- :setup (make-uim-setup-proc proc)
- :teardown (make-uim-teadown-proc)
+ :setup (make-uim-sh-setup-proc proc)
+ :teardown (make-uim-sh-teadown-proc)
:tests (make-tests test ...)))
((_ name (teardown proc) test ...)
(make <test-case>
:name name
- :setup (make-uim-setup-proc)
- :teardown (make-uim-teadown-proc proc)
+ :setup (make-uim-sh-setup-proc)
+ :teardown (make-uim-sh-teadown-proc proc)
:tests (make-tests test ...)))
((_ name test ...)
(make <test-case>
:name name
- :setup (make-uim-setup-proc)
- :teardown (make-uim-teadown-proc)
+ :setup (make-uim-sh-setup-proc)
+ :teardown (make-uim-sh-teadown-proc)
:tests (make-tests test ...)))))
(provide "test/uim-test-utils")
Index: uim/slib.c
===================================================================
--- uim/slib.c (revision 751)
+++ uim/slib.c (working copy)
@@ -236,7 +236,6 @@
static LISP my_err(char *message, LISP obj);
static LISP lprint (LISP exp, LISP);
-
#define ENVLOOKUP_TRICK 1
static long inside_err = 0;
@@ -2965,37 +2964,82 @@
}
static LISP
-let_macro (LISP form)
+split_to_name_and_value (LISP bindings)
{
- LISP p, fl, al, tmp;
+ LISP fl, al, binding;
fl = NIL;
al = NIL;
- for (p = car (cdr (form)); NNULLP (p); p = cdr (p))
+ for (; NNULLP (bindings); bindings = cdr (bindings))
{
- tmp = car (p);
+ binding = car (bindings);
if SYMBOLP
- (tmp)
+ (binding)
{
- fl = cons (tmp, fl);
+ fl = cons (binding, fl);
al = cons (NIL, al);
}
else
{
- fl = cons (car (tmp), fl);
- al = cons (car (cdr (tmp)), al);
+ fl = cons (car (binding), fl);
+ al = cons (cadr (binding), al);
}
}
- p = cdr (cdr (form));
+ return (cons (fl, al));
+}
+
+static LISP
+named_let_macro (LISP form)
+{
+ LISP name, fl, al, bindings, body;
+
+ bindings = split_to_name_and_value (car (cddr (form)));
+ fl = car (bindings);
+ al = cdr (bindings);
+
+ name = cadr (form);
+ body = cdr (cddr (form));
+
+ setcdr (form,
+ listn (2,
+ listn (1,
+ listn (2,
+ name,
+ cons (sym_lambda, cons (reverse (fl), body)))),
+ cons (name, reverse (al)), NIL));
+ setcar (form, rintern ("letrec"));
+ return (form);
+}
+
+static LISP
+normal_let_macro (LISP form)
+{
+ LISP fl, al, bindings, body;
+
+ bindings = split_to_name_and_value (cadr (form));
+ fl = car (bindings);
+ al = cdr (bindings);
+
+ body = cddr (form);
if NULLP
- (cdr (p)) p = car (p);
+ (cdr (body)) body = car (body);
else
- p = cons (sym_progn, p);
- setcdr (form, cons (reverse (fl), cons (reverse (al), cons (p, NIL))));
+ body = cons (sym_progn, body);
+ setcdr (form, cons (reverse (fl), cons (reverse (al), cons (body, NIL))));
setcar (form, rintern ("let-internal"));
return (form);
}
static LISP
+let_macro (LISP form)
+{
+ if SYMBOLP
+ (cadr (form))
+ return (named_let_macro (form));
+ else
+ return (normal_let_macro (form));
+}
+
+static LISP
leval_quote (LISP args, LISP env)
{
return (car (args));