[uim-commit] r973 - in branches/r5rs: . sigscheme sigscheme/bench sigscheme/test

kzk at freedesktop.org kzk at freedesktop.org
Mon Jul 18 07:10:36 EST 2005


Author: kzk
Date: 2005-07-17 14:10:29 -0700 (Sun, 17 Jul 2005)
New Revision: 973

Added:
   branches/r5rs/sigscheme/
   branches/r5rs/sigscheme/Makefile.am
   branches/r5rs/sigscheme/bench/
   branches/r5rs/sigscheme/bench/bench-arithint.scm
   branches/r5rs/sigscheme/bench/bench-case.scm
   branches/r5rs/sigscheme/bench/bench-fib.scm
   branches/r5rs/sigscheme/bench/bench-let-loop.scm
   branches/r5rs/sigscheme/bench/bench-loop.scm
   branches/r5rs/sigscheme/bench/bench-mem.scm
   branches/r5rs/sigscheme/bench/bench-rec.scm
   branches/r5rs/sigscheme/bench/bench-tak.scm
   branches/r5rs/sigscheme/bench/bench-takl.scm
   branches/r5rs/sigscheme/bench/bench-takr.scm
   branches/r5rs/sigscheme/c_template
   branches/r5rs/sigscheme/compare-scm.sh
   branches/r5rs/sigscheme/datas.c
   branches/r5rs/sigscheme/debug.c
   branches/r5rs/sigscheme/encoding.c
   branches/r5rs/sigscheme/error.c
   branches/r5rs/sigscheme/eval.c
   branches/r5rs/sigscheme/h_template
   branches/r5rs/sigscheme/io.c
   branches/r5rs/sigscheme/main.c
   branches/r5rs/sigscheme/operations.c
   branches/r5rs/sigscheme/read.c
   branches/r5rs/sigscheme/runbench.sh
   branches/r5rs/sigscheme/runtest.sh
   branches/r5rs/sigscheme/sigscheme.c
   branches/r5rs/sigscheme/sigscheme.h
   branches/r5rs/sigscheme/sigschemetype.h
   branches/r5rs/sigscheme/test/
   branches/r5rs/sigscheme/test/define.scm
   branches/r5rs/sigscheme/test/for-each.scm
   branches/r5rs/sigscheme/test/io.scm
   branches/r5rs/sigscheme/test/map.scm
   branches/r5rs/sigscheme/test/quote.scm
   branches/r5rs/sigscheme/test/test-apply.scm
   branches/r5rs/sigscheme/test/test-case.scm
   branches/r5rs/sigscheme/test/test-char.scm
   branches/r5rs/sigscheme/test/test-define.scm
   branches/r5rs/sigscheme/test/test-delay-force.scm
   branches/r5rs/sigscheme/test/test-equation.scm
   branches/r5rs/sigscheme/test/test-eval.scm
   branches/r5rs/sigscheme/test/test-exp.scm
   branches/r5rs/sigscheme/test/test-let.scm
   branches/r5rs/sigscheme/test/test-num.scm
   branches/r5rs/sigscheme/test/test-string.scm
   branches/r5rs/sigscheme/test/unittest.scm
   branches/r5rs/sigscheme/test/vector.scm
Modified:
   branches/r5rs/Makefile.am
   branches/r5rs/configure.ac
Log:
Now add SigScheme to the repositry.


Modified: branches/r5rs/Makefile.am
===================================================================
--- branches/r5rs/Makefile.am	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/Makefile.am	2005-07-17 21:10:29 UTC (rev 973)
@@ -1,5 +1,5 @@
 AUTOMAKE_OPTIONS = foreign
-SUBDIRS = m4 doc uim scm gtk qt xim helper po tables test fep examples pixmaps
+SUBDIRS = m4 doc uim scm gtk qt xim helper po tables test fep examples pixmaps sigscheme
 EXTRA_DIST = README.ja INSTALL.ja test.sh.in uim.spec.in \
 	intltool-extract.in intltool-merge.in intltool-update.in \
 	uim.pc.in ChangeLog.old uim.desktop autogen.sh RELEASING

Modified: branches/r5rs/configure.ac
===================================================================
--- branches/r5rs/configure.ac	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/configure.ac	2005-07-17 21:10:29 UTC (rev 973)
@@ -731,6 +731,7 @@
                  helper/Makefile
                  doc/Makefile
                  uim/Makefile
+		 sigscheme/Makefile
                  scm/Makefile
                  gtk/Makefile
                  qt/Makefile

Added: branches/r5rs/sigscheme/Makefile.am
===================================================================
--- branches/r5rs/sigscheme/Makefile.am	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/Makefile.am	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,12 @@
+bin_PROGRAMS  = sscm
+sscm_CFLAGS   = @X_CFLAGS@ -Wall
+sscm_CXXFLAGS = @X_CFLAGS@ -Wall
+
+
+sscm_SOURCES = \
+	datas.c debug.c \
+	encoding.c error.c \
+	eval.c io.c \
+	main.c operations.c \
+	read.c sigscheme.c  \
+	sigscheme.h sigschemetype.h 

Added: branches/r5rs/sigscheme/bench/bench-arithint.scm
===================================================================
--- branches/r5rs/sigscheme/bench/bench-arithint.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/bench/bench-arithint.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,9 @@
+(define *max* 20001)
+
+(define (test x y)
+  (if (= x *max*)
+      x
+      (test (- x (+ (* y 2) (/ x (abs y))))
+	    (- y (+ (* x 2) (/ y (abs x)))))))
+
+(print (test 1 1))

Added: branches/r5rs/sigscheme/bench/bench-case.scm
===================================================================
--- branches/r5rs/sigscheme/bench/bench-case.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/bench/bench-case.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,10 @@
+(define loop
+  (lambda (i l)
+    (case 6
+      ((1 2 3 4 5) #f)
+      ((6)
+       (if (< i l)
+	   (loop (+ 1 i) l)
+	   l)))))
+
+(print (loop 0 20000))

Added: branches/r5rs/sigscheme/bench/bench-fib.scm
===================================================================
--- branches/r5rs/sigscheme/bench/bench-fib.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/bench/bench-fib.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,5 @@
+(define (fib n)
+  (if (<= n 2) 1
+      (+ (fib (- n 1)) (fib (- n 2)))))
+
+(print (fib 30))

Added: branches/r5rs/sigscheme/bench/bench-let-loop.scm
===================================================================
--- branches/r5rs/sigscheme/bench/bench-let-loop.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/bench/bench-let-loop.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,10 @@
+(define loop
+  (lambda (i l)
+    (let ((a 0)
+	  (b 1)
+	  (c 2))
+      (if (< i l)
+	  (loop (+ 1 i) l)
+	  l))))
+
+(print (loop 0 20000))

Added: branches/r5rs/sigscheme/bench/bench-loop.scm
===================================================================
--- branches/r5rs/sigscheme/bench/bench-loop.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/bench/bench-loop.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,7 @@
+(define loop
+  (lambda (i l)
+    (if (< i l)
+	(loop (+ 1 i) l)
+	l)))
+
+(print (loop 0 8000))

Added: branches/r5rs/sigscheme/bench/bench-mem.scm
===================================================================
--- branches/r5rs/sigscheme/bench/bench-mem.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/bench/bench-mem.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,15 @@
+(define *lifetime*  100)
+(define *blocksize* 100)
+  
+(define *vec* (make-vector *lifetime*))
+
+(define (foo i j)
+  (if (< i *lifetime*)
+      (begin
+	(vector-set! *vec* i (make-vector *blocksize*))
+	(foo (+ i 1) j))
+      (if (< 0 j)
+          (foo 0 (- j 1))
+	  '())))
+
+(print (foo 0 100))

Added: branches/r5rs/sigscheme/bench/bench-rec.scm
===================================================================
--- branches/r5rs/sigscheme/bench/bench-rec.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/bench/bench-rec.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,9 @@
+(define (test f g n)
+  (if (= n 0)
+      f
+      (let ((m (- n 1)))
+	((f g f m) f g m)
+	((g f g m) g f m)
+	g)))
+
+(test test test 10)

Added: branches/r5rs/sigscheme/bench/bench-tak.scm
===================================================================
--- branches/r5rs/sigscheme/bench/bench-tak.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/bench/bench-tak.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,8 @@
+(define (tak x y z)
+  (if (not (< y x))
+      z
+      (tak (tak (- x 1) y z)
+	   (tak (- y 1) z x)
+	   (tak (- z 1) x y))))
+
+(tak 18 12 6)

Added: branches/r5rs/sigscheme/bench/bench-takl.scm
===================================================================
--- branches/r5rs/sigscheme/bench/bench-takl.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/bench/bench-takl.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,29 @@
+(define (listn n)
+  (if (not (= 0 n))
+      (cons n (listn (- n 1)))
+    '()))
+ 
+(define l18 (listn 18))
+(define l12 (listn 12))
+(define  l6 (listn 6))
+ 
+(define (mas x y z)
+  (if (not (shorterp y x))
+      z
+      (mas (mas (cdr x)
+                 y z)
+            (mas (cdr y)
+                 z x)
+            (mas (cdr z)
+                 x y))))
+ 
+(define (shorterp x y)
+  (and (not (null? y))
+       (or (null? x)
+           (shorterp (cdr x)
+                     (cdr y)))))
+ 
+;;; call: (mas l18 l12 l6)
+ 
+(mas l18 l12 l6)
+

Added: branches/r5rs/sigscheme/bench/bench-takr.scm
===================================================================
--- branches/r5rs/sigscheme/bench/bench-takr.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/bench/bench-takr.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,509 @@
+(define (tak0 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak1 (tak37 (- x 1) y z)
+                 (tak11 (- y 1) z x)
+                 (tak17 (- z 1) x y)))))
+(define (tak1 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak2 (tak74 (- x 1) y z)
+                 (tak22 (- y 1) z x)
+                 (tak34 (- z 1) x y)))))
+(define (tak2 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak3 (tak11 (- x 1) y z)
+                 (tak33 (- y 1) z x)
+                 (tak51 (- z 1) x y)))))
+(define (tak3 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak4 (tak48 (- x 1) y z)
+                 (tak44 (- y 1) z x)
+                 (tak68 (- z 1) x y)))))
+(define (tak4 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak5 (tak85 (- x 1) y z)
+                 (tak55 (- y 1) z x)
+                 (tak85 (- z 1) x y)))))
+(define (tak5 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak6 (tak22 (- x 1) y z)
+                 (tak66 (- y 1) z x)
+                 (tak2 (- z 1) x y)))))
+(define (tak6 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak7 (tak59 (- x 1) y z)
+                 (tak77 (- y 1) z x)
+                 (tak19 (- z 1) x y)))))
+(define (tak7 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak8 (tak96 (- x 1) y z)
+                 (tak88 (- y 1) z x)
+                 (tak36 (- z 1) x y)))))
+(define (tak8 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak9 (tak33 (- x 1) y z)
+                 (tak99 (- y 1) z x)
+                 (tak53 (- z 1) x y)))))
+(define (tak9 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak10 (tak70 (- x 1) y z)
+                  (tak10 (- y 1) z x)
+                  (tak70 (- z 1) x y)))))
+(define (tak10 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak11 (tak7 (- x 1) y z)
+                  (tak21 (- y 1) z x)
+                  (tak87 (- z 1) x y)))))
+(define (tak11 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak12 (tak44 (- x 1) y z)
+                  (tak32 (- y 1) z x)
+                  (tak4 (- z 1) x y)))))
+(define (tak12 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak13 (tak81 (- x 1) y z)
+                  (tak43 (- y 1) z x)
+                  (tak21 (- z 1) x y)))))
+ 
+(define (tak13 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak14 (tak18 (- x 1) y z)
+                  (tak54 (- y 1) z x)
+                  (tak38 (- z 1) x y)))))
+(define (tak14 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak15 (tak55 (- x 1) y z)
+                  (tak65 (- y 1) z x)
+                  (tak55 (- z 1) x y)))))
+(define (tak15 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak16 (tak92 (- x 1) y z)
+                  (tak76 (- y 1) z x)
+                  (tak72 (- z 1) x y)))))
+(define (tak16 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak17 (tak29 (- x 1) y z)
+                  (tak87 (- y 1) z x)
+                  (tak89 (- z 1) x y)))))
+(define (tak17 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak18 (tak66 (- x 1) y z)
+                  (tak98 (- y 1) z x)
+                  (tak6 (- z 1) x y)))))
+(define (tak18 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak19 (tak3 (- x 1) y z)
+                  (tak9 (- y 1) z x)
+                  (tak23 (- z 1) x y)))))
+(define (tak19 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak20 (tak40 (- x 1) y z)
+                  (tak20 (- y 1) z x)
+                  (tak40 (- z 1) x y)))))
+(define (tak20 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak21 (tak77 (- x 1) y z)
+                  (tak31 (- y 1) z x)
+                  (tak57 (- z 1) x y)))))
+
+(define (tak21 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak22 (tak14 (- x 1) y z)
+                  (tak42 (- y 1) z x)
+                  (tak74 (- z 1) x y)))))
+(define (tak22 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak23 (tak51 (- x 1) y z)
+                  (tak53 (- y 1) z x)
+                  (tak91 (- z 1) x y)))))
+(define (tak23 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak24 (tak88 (- x 1) y z)
+                  (tak64 (- y 1) z x)
+                  (tak8 (- z 1) x y)))))
+(define (tak24 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak25 (tak25 (- x 1) y z)
+                  (tak75 (- y 1) z x)
+                  (tak25 (- z 1) x y)))))
+(define (tak25 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak26 (tak62 (- x 1) y z)
+                  (tak86 (- y 1) z x)
+                  (tak42 (- z 1) x y)))))
+(define (tak26 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak27 (tak99 (- x 1) y z)
+                  (tak97 (- y 1) z x)
+                  (tak59 (- z 1) x y)))))
+(define (tak27 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak28 (tak36 (- x 1) y z)
+                  (tak8 (- y 1) z x)
+                  (tak76 (- z 1) x y)))))
+(define (tak28 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak29 (tak73 (- x 1) y z)
+                  (tak19 (- y 1) z x)
+                  (tak93 (- z 1) x y)))))
+(define (tak29 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak30 (tak10 (- x 1) y z)
+                  (tak30 (- y 1) z x)
+                  (tak10 (- z 1) x y)))))
+(define (tak30 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak31 (tak47 (- x 1) y z)
+                  (tak41 (- y 1) z x)
+                  (tak27 (- z 1) x y)))))
+(define (tak31 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak32 (tak84 (- x 1) y z)
+                  (tak52 (- y 1) z x)
+                  (tak44 (- z 1) x y)))))
+(define (tak32 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak33 (tak21 (- x 1) y z)
+                  (tak63 (- y 1) z x)
+                  (tak61 (- z 1) x y)))))
+(define (tak33 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak34 (tak58 (- x 1) y z)
+                  (tak74 (- y 1) z x)
+                  (tak78 (- z 1) x y)))))
+(define (tak34 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak35 (tak95 (- x 1) y z)
+                  (tak85 (- y 1) z x)
+                  (tak95 (- z 1) x y)))))
+(define (tak35 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak36 (tak32 (- x 1) y z)
+                  (tak96 (- y 1) z x)
+                  (tak12 (- z 1) x y)))))
+(define (tak36 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak37 (tak69 (- x 1) y z)
+                  (tak7 (- y 1) z x)
+                  (tak29 (- z 1) x y)))))
+(define (tak37 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak38 (tak6 (- x 1) y z)
+                  (tak18 (- y 1) z x)
+                  (tak46 (- z 1) x y)))))
+(define (tak38 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak39 (tak43 (- x 1) y z)
+                  (tak29 (- y 1) z x)
+                  (tak63 (- z 1) x y)))))
+(define (tak39 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak40 (tak80 (- x 1) y z)
+                  (tak40 (- y 1) z x)
+                  (tak80 (- z 1) x y)))))
+(define (tak40 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak41 (tak17 (- x 1) y z)
+                  (tak51 (- y 1) z x)
+                  (tak97 (- z 1) x y)))))
+
+(define (tak41 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak42 (tak54 (- x 1) y z)
+                  (tak62 (- y 1) z x)
+                  (tak14 (- z 1) x y)))))
+(define (tak42 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak43 (tak91 (- x 1) y z)
+                  (tak73 (- y 1) z x)
+                  (tak31 (- z 1) x y)))))
+(define (tak43 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak44 (tak28 (- x 1) y z)
+                  (tak84 (- y 1) z x)
+                  (tak48 (- z 1) x y)))))
+(define (tak44 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak45 (tak65 (- x 1) y z)
+                  (tak95 (- y 1) z x)
+                  (tak65 (- z 1) x y)))))
+(define (tak45 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak46 (tak2 (- x 1) y z)
+                  (tak6 (- y 1) z x)
+                  (tak82 (- z 1) x y)))))
+(define (tak46 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak47 (tak39 (- x 1) y z)
+                  (tak17 (- y 1) z x)
+                  (tak99 (- z 1) x y)))))
+(define (tak47 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak48 (tak76 (- x 1) y z)
+                  (tak28 (- y 1) z x)
+                  (tak16 (- z 1) x y)))))
+(define (tak48 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak49 (tak13 (- x 1) y z)
+                  (tak39 (- y 1) z x)
+                  (tak33 (- z 1) x y)))))
+(define (tak49 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak50 (tak50 (- x 1) y z)
+                  (tak50 (- y 1) z x)
+                  (tak50 (- z 1) x y)))))
+(define (tak50 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak51 (tak87 (- x 1) y z)
+                  (tak61 (- y 1) z x)
+                  (tak67 (- z 1) x y)))))
+(define (tak51 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak52 (tak24 (- x 1) y z)
+                  (tak72 (- y 1) z x)
+                  (tak84 (- z 1) x y)))))
+(define (tak52 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak53 (tak61 (- x 1) y z)
+                  (tak83 (- y 1) z x)
+                  (tak1 (- z 1) x y)))))
+(define (tak53 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak54 (tak98 (- x 1) y z)
+                  (tak94 (- y 1) z x)
+                  (tak18 (- z 1) x y)))))
+(define (tak54 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak55 (tak35 (- x 1) y z)
+                  (tak5 (- y 1) z x)
+                  (tak35 (- z 1) x y)))))
+(define (tak55 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak56 (tak72 (- x 1) y z)
+                  (tak16 (- y 1) z x)
+                  (tak52 (- z 1) x y)))))
+(define (tak56 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak57 (tak9 (- x 1) y z)
+                  (tak27 (- y 1) z x)
+                  (tak69 (- z 1) x y)))))
+(define (tak57 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak58 (tak46 (- x 1) y z)
+                  (tak38 (- y 1) z x)
+                  (tak86 (- z 1) x y)))))
+(define (tak58 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak59 (tak83 (- x 1) y z)
+                  (tak49 (- y 1) z x)
+                  (tak3 (- z 1) x y)))))
+(define (tak59 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak60 (tak20 (- x 1) y z)
+                  (tak60 (- y 1) z x)
+                  (tak20 (- z 1) x y)))))
+(define (tak60 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak61 (tak57 (- x 1) y z)
+                  (tak71 (- y 1) z x)
+                  (tak37 (- z 1) x y)))))
+
+(define (tak61 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak62 (tak94 (- x 1) y z)
+                  (tak82 (- y 1) z x)
+                  (tak54 (- z 1) x y)))))
+(define (tak62 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak63 (tak31 (- x 1) y z)
+                  (tak93 (- y 1) z x)
+                  (tak71 (- z 1) x y)))))
+(define (tak63 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak64 (tak68 (- x 1) y z)
+                  (tak4 (- y 1) z x)
+                  (tak88 (- z 1) x y)))))
+(define (tak64 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak65 (tak5 (- x 1) y z)
+                  (tak15 (- y 1) z x)
+                  (tak5 (- z 1) x y)))))
+(define (tak65 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak66 (tak42 (- x 1) y z)
+                  (tak26 (- y 1) z x)
+                  (tak22 (- z 1) x y)))))
+(define (tak66 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak67 (tak79 (- x 1) y z)
+                  (tak37 (- y 1) z x)
+                  (tak39 (- z 1) x y)))))
+(define (tak67 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak68 (tak16 (- x 1) y z)
+                  (tak48 (- y 1) z x)
+                  (tak56 (- z 1) x y)))))
+(define (tak68 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak69 (tak53 (- x 1) y z)
+                  (tak59 (- y 1) z x)
+                  (tak73 (- z 1) x y)))))
+(define (tak69 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak70 (tak90 (- x 1) y z)
+                  (tak70 (- y 1) z x)
+                  (tak90 (- z 1) x y)))))
+(define (tak70 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak71 (tak27 (- x 1) y z)
+                  (tak81 (- y 1) z x)
+                  (tak7 (- z 1) x y)))))
+(define (tak71 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak72 (tak64 (- x 1) y z)
+                  (tak92 (- y 1) z x)
+                  (tak24 (- z 1) x y)))))
+(define (tak72 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak73 (tak1 (- x 1) y z)
+                  (tak3 (- y 1) z x)
+                  (tak41 (- z 1) x y)))))
+(define (tak73 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak74 (tak38 (- x 1) y z)
+                  (tak14 (- y 1) z x)
+                  (tak58 (- z 1) x y)))))
+(define (tak74 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak75 (tak75 (- x 1) y z)
+                  (tak25 (- y 1) z x)
+                  (tak75 (- z 1) x y)))))
+(define (tak75 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak76 (tak12 (- x 1) y z)
+                  (tak36 (- y 1) z x)
+                  (tak92 (- z 1) x y)))))
+(define (tak76 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak77 (tak49 (- x 1) y z)
+                  (tak47 (- y 1) z x)
+                  (tak9 (- z 1) x y)))))
+(define (tak77 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak78 (tak86 (- x 1) y z)
+                  (tak58 (- y 1) z x)
+                  (tak26 (- z 1) x y)))))
+(define (tak78 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak79 (tak23 (- x 1) y z)
+                  (tak69 (- y 1) z x)
+                  (tak43 (- z 1) x y)))))
+(define (tak79 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak80 (tak60 (- x 1) y z)
+                  (tak80 (- y 1) z x)
+                  (tak60 (- z 1) x y)))))
+(define (tak80 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak81 (tak97 (- x 1) y z)
+                  (tak91 (- y 1) z x)
+                  (tak77 (- z 1) x y)))))
+
+(define (tak81 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak82 (tak34 (- x 1) y z)
+                  (tak2 (- y 1) z x)
+                  (tak94 (- z 1) x y)))))
+(define (tak82 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak83 (tak71 (- x 1) y z)
+                  (tak13 (- y 1) z x)
+                  (tak11 (- z 1) x y)))))
+(define (tak83 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak84 (tak8 (- x 1) y z)
+                  (tak24 (- y 1) z x)
+                  (tak28 (- z 1) x y)))))
+(define (tak84 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak85 (tak45 (- x 1) y z)
+                  (tak35 (- y 1) z x)
+                  (tak45 (- z 1) x y)))))
+(define (tak85 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak86 (tak82 (- x 1) y z)
+                  (tak46 (- y 1) z x)
+                  (tak62 (- z 1) x y)))))
+(define (tak86 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak87 (tak19 (- x 1) y z)
+                  (tak57 (- y 1) z x)
+                  (tak79 (- z 1) x y)))))
+(define (tak87 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak88 (tak56 (- x 1) y z)
+                  (tak68 (- y 1) z x)
+                  (tak96 (- z 1) x y)))))
+(define (tak88 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak89 (tak93 (- x 1) y z)
+                  (tak79 (- y 1) z x)
+                  (tak13 (- z 1) x y)))))
+(define (tak89 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak90 (tak30 (- x 1) y z)
+                  (tak90 (- y 1) z x)
+                  (tak30 (- z 1) x y)))))
+(define (tak90 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak91 (tak67 (- x 1) y z)
+                  (tak1 (- y 1) z x)
+                  (tak47 (- z 1) x y)))))
+(define (tak91 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak92 (tak4 (- x 1) y z)
+                  (tak12 (- y 1) z x)
+                  (tak64 (- z 1) x y)))))
+(define (tak92 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak93 (tak41 (- x 1) y z)
+                  (tak23 (- y 1) z x)
+                  (tak81 (- z 1) x y)))))
+(define (tak93 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak94 (tak78 (- x 1) y z)
+                  (tak34 (- y 1) z x)
+                  (tak98 (- z 1) x y)))))
+(define (tak94 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak95 (tak15 (- x 1) y z)
+                  (tak45 (- y 1) z x)
+                  (tak15 (- z 1) x y)))))
+(define (tak95 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak96 (tak52 (- x 1) y z)
+                  (tak56 (- y 1) z x)
+                  (tak32 (- z 1) x y)))))
+(define (tak96 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak97 (tak89 (- x 1) y z)
+                  (tak67 (- y 1) z x)
+                  (tak49 (- z 1) x y)))))
+(define (tak97 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak98 (tak26 (- x 1) y z)
+                  (tak78 (- y 1) z x)
+                  (tak66 (- z 1) x y)))))
+(define (tak98 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak99 (tak63 (- x 1) y z)
+                  (tak89 (- y 1) z x)
+                  (tak83 (- z 1) x y)))))
+(define (tak99 x y z)
+  (cond ((not (< y x)) z)
+        (else (tak0 (tak0 (- x 1) y z)
+                 (tak0 (- y 1) z x)
+                 (tak0 (- z 1) x y)))))
+ 
+;;; call:  (tak0 18 12 6)
+ 
+(tak0 18 12 6)

Added: branches/r5rs/sigscheme/c_template
===================================================================
--- branches/r5rs/sigscheme/c_template	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/c_template	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,61 @@
+/*===========================================================================
+ *  FileName : .c
+ *  About    : 
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+
+/*=======================================
+  System Include
+=======================================*/
+
+/*=======================================
+  Local Include
+=======================================*/
+
+/*=======================================
+  File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+  File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+  Variable Declarations
+=======================================*/
+
+/*=======================================
+  File Local Function Declarations
+=======================================*/
+
+/*=======================================
+  Function Implementations
+=======================================*/

Added: branches/r5rs/sigscheme/compare-scm.sh
===================================================================
--- branches/r5rs/sigscheme/compare-scm.sh	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/compare-scm.sh	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,9 @@
+#!/bin/sh
+
+echo "Running benchmark $bench..."
+echo "[ SigScheme ]"
+time ./sscm $1
+echo "[ SIOD ]"
+time uim-sh -B < $1
+echo "[ Gauche ]"
+time gosh $1


Property changes on: branches/r5rs/sigscheme/compare-scm.sh
___________________________________________________________________
Name: svn:executable
   + *

Added: branches/r5rs/sigscheme/datas.c
===================================================================
--- branches/r5rs/sigscheme/datas.c	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/datas.c	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,682 @@
+/*===========================================================================
+ *  FileName : datas.c
+ *  About    : GC(Garbage Collection) and Allocation
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+
+/*
+ * Description of the Garbage Collection
+ *
+ * Our GC uses Mark-and-Sweep algorithm. So, we have MARK phase and SWEEP phase.
+ *
+ * [1] Mark phase : gc_mark()
+ *   - gc_mark_protected_obj()
+ *       marking protected Scheme object which are protected by calling gc_protect().
+ *
+ *   - gc_mark_stack()
+ *       marking the Scheme object which are pushed to the stack, so we need to
+ *       traverse the stack for marking the objects.
+ *
+ *   - gc_mark_symbol_hash()
+ *       marking the Scheme object which is interned by calling Scm_Intern().
+ *
+ * [2] Sweep phase : gc_sweep()
+ *   - scanning heaps and move non-marked object to the freelist.
+ */
+
+/*=======================================
+  System Include
+=======================================*/
+#include <string.h>
+#include <stdlib.h>
+#include <malloc.h>
+
+/*=======================================
+  Local Include
+=======================================*/
+#include "sigscheme.h"
+
+/*=======================================
+  File Local Struct Declarations
+=======================================*/
+typedef ScmObj ScmObjHeap;
+
+/* Represent protected from GC object */
+typedef struct gc_protected_obj_ gc_protected_obj;
+struct gc_protected_obj_ {
+    ScmObj obj;
+    gc_protected_obj *next_obj;
+};
+
+/*=======================================
+  File Local Macro Declarations
+=======================================*/
+#define NAMEHASH_SIZE 1024
+
+#define SCM_NEW_OBJ_INTERNAL(VALNAME)                                   \
+    if (EQ(scm_freelist, SCM_NIL))					\
+	gc_mark_and_sweep();						\
+    VALNAME = scm_freelist;						\
+    scm_freelist = SCM_FREECELL_CDR(scm_freelist);			\
+
+/*=======================================
+  Variable Declarations
+=======================================*/
+static int           SCM_HEAP_SIZE = 16384;
+static int           scm_heap_num  = 64;
+static ScmObjHeap   *scm_heaps     = NULL;
+static ScmObj        scm_freelist  = NULL;
+
+ScmObj *stack_start_pointer = NULL;
+
+
+static ScmObj *symbol_hash = NULL;
+static gc_protected_obj *protected_obj_list = NULL;
+
+/*=======================================
+  File Local Function Declarations
+=======================================*/
+static void *malloc_aligned(size_t size);
+
+static void allocate_heap(ScmObjHeap **heaps, int num_heap, int HEAP_SIZE, ScmObj *freelist);
+static void add_heap(ScmObjHeap **heaps, int *num_heap, int HEAP_SIZE, ScmObj *freelist);
+static void finalize_heap(void);
+
+static void gc_protect(ScmObj obj);
+
+
+static void gc_preprocess(void);
+static void gc_mark_and_sweep(void);
+
+/* GC Mark Related Functions */
+static void mark_obj(ScmObj obj);
+static int  is_pointer_to_heap(ScmObj obj);
+
+static void gc_mark_protected_obj();
+static void gc_mark_stack(ScmObj *start, ScmObj *end);
+static void gc_mark(void);
+
+/* GC Sweep Related Functions */
+static void sweep_obj(ScmObj obj);
+static void gc_sweep(void);
+
+static void initialize_symbol_hash(void);
+static void finalize_symbol_hash(void);
+static int  symbol_name_hash(const char *name);
+
+/*=======================================
+  Function Implementations
+=======================================*/
+void SigScm_InitStorage()
+{
+    allocate_heap(&scm_heaps, scm_heap_num, SCM_HEAP_SIZE, &scm_freelist);
+    initialize_symbol_hash();
+}
+
+void SigScm_FinalizeStorage()
+{
+    finalize_heap();
+    finalize_symbol_hash();
+}
+
+static void *malloc_aligned(size_t size)
+{
+    /* TODO : Need to reserch System Dependency! */
+    void *p;
+    posix_memalign(&p, 16, size);
+    return p;
+}
+
+
+static void allocate_heap(ScmObjHeap **heaps, int num_heap, int HEAP_SIZE, ScmObj *freelist)
+{
+    int i = 0;
+    int j = 0;
+    ScmObj prev = NULL;
+    ScmObj next = NULL;
+
+#if DEBUG_GC
+    printf("allocate_heap\n");
+#endif
+
+    /* allocate heap */
+    (*heaps) = (ScmObj*)malloc(sizeof(ScmObj) * num_heap);
+    (*freelist) = SCM_NIL;
+
+    /* fill with zero and construct free_list */
+    for (i = 0; i < num_heap; i++) {
+        /* Initialize Heap */
+        (*heaps)[i] = (ScmObj)malloc_aligned(sizeof(ScmObjInternal) * HEAP_SIZE);
+        memset((*heaps)[i], 0, sizeof(ScmObjInternal) * HEAP_SIZE);
+
+        /* link in order */
+        prev = NULL;
+        next = NULL;
+        for (j = 0; j < HEAP_SIZE; j++) {
+            next = &(*heaps)[i][j];
+	    SCM_SETFREECELL(next);
+
+	    /* prev's cdr is next */
+	    if (prev)
+		SCM_SETFREECELL_CDR(prev, next);
+
+            /* the last cons' cdr is freelist */
+            if (j == HEAP_SIZE - 1)
+		SCM_SETFREECELL_CDR(next, (*freelist));
+
+            prev = next;
+        }
+
+	/* and freelist is head of the heap */
+	(*freelist) = (*heaps)[i];
+    }
+}
+
+static void add_heap(ScmObjHeap **heaps, int *orig_num_heap, int HEAP_SIZE, ScmObj *freelist)
+{
+    int    i = 0;
+    int    num_heap = 0;
+    ScmObj prev     = NULL;
+    ScmObj next     = NULL;
+
+#if DEBUG_GC
+    printf("add_heap\n");
+#endif
+
+    /* increment num_heap */
+    (*orig_num_heap) += 1;
+    num_heap = (*orig_num_heap);
+
+    /* add heap */
+    (*heaps) = (ScmObj*)realloc((*heaps), sizeof(ScmObj) * num_heap);
+
+    /* allocate heap */
+    (*heaps)[num_heap - 1] = (ScmObj)malloc_aligned(sizeof(ScmObjInternal) * HEAP_SIZE);
+
+    /* link in order */
+    for (i = 0; i < HEAP_SIZE; i++) {
+        next = &(*heaps)[num_heap - 1][i];
+	SCM_SETFREECELL(next);
+
+        if (prev)
+	    SCM_SETFREECELL_CDR(prev, next);
+
+        /* the last cons' cdr is freelist */
+        if (i == HEAP_SIZE - 1)
+	    SCM_SETFREECELL_CDR(next, (*freelist));
+
+        prev = next;
+    }
+
+    (*freelist) = (*heaps)[num_heap - 1];
+}
+
+static void finalize_heap(void)
+{
+    int i = 0;
+    int j = 0;
+
+    for (i = 0; i < scm_heap_num; i++) {
+	for (j = 0; j < SCM_HEAP_SIZE; j++) {
+	    sweep_obj(&scm_heaps[i][j]);
+	}
+	free(scm_heaps[i]);
+    }
+    free(scm_heaps);
+}
+
+static void gc_preprocess(void)
+{
+    /* Initialize Mark Table */
+    int  i = 0;
+    long j = 0;
+    for (i = 0; i < scm_heap_num; i++) {
+	for (j = 0; j < SCM_HEAP_SIZE; j++) {
+	    SCM_DO_UNMARK(&scm_heaps[i][j]);
+	}
+    }
+}
+
+static void gc_mark_and_sweep(void)
+{
+#if DEBUG_GC
+    printf("[ gc start ]\n");
+#endif
+
+    gc_preprocess();
+
+    gc_mark();
+    gc_sweep();
+
+    /* we cannot sweep the object, so let's add new heap */
+    if (SCM_NULLP(scm_freelist))
+        add_heap(&scm_heaps, &scm_heap_num, SCM_HEAP_SIZE, &scm_freelist);
+}
+
+static void mark_obj(ScmObj obj)
+{
+    int i = 0;
+
+mark_loop:
+    /* no need to mark SCM_NIL */
+    if (SCM_NULLP(obj))
+        return;
+
+    /* avoid cyclic marking */
+    if (SCM_IS_MARKED(obj))
+        return;
+
+    /* mark this object */
+    SCM_DO_MARK(obj);
+
+    /* mark recursively */
+    switch (SCM_GETTYPE(obj)) {
+        case ScmCons:
+            mark_obj(SCM_CAR(obj));
+	    obj = SCM_CDR(obj);
+	    goto mark_loop;
+            break;
+        case ScmSymbol:
+            mark_obj(SCM_SYMBOL_VCELL(obj));
+            break;
+        case ScmClosure:
+            mark_obj(SCM_CLOSURE_EXP(obj));
+	    obj = SCM_CLOSURE_ENV(obj);
+	    goto mark_loop;
+	    break;
+	case ScmVector:
+	    for (i = 0; i < SCM_INT_VALUE(SCM_VECTOR_LEN(obj)); i++) {
+		mark_obj(SCM_VECTOR_VEC(obj)[i]);
+	    }
+	    obj = SCM_VECTOR_LEN(obj);
+	    goto mark_loop;
+	    break;
+	default:
+	    break;
+    }
+}
+
+static void gc_protect(ScmObj obj)
+{
+    gc_protected_obj *item = (gc_protected_obj*)malloc(sizeof(gc_protected_obj));
+    item->obj = obj;
+
+    if (protected_obj_list) {
+        item->next_obj = protected_obj_list;
+        protected_obj_list = item;
+    } else {
+        protected_obj_list = item;
+        protected_obj_list->next_obj = NULL; /* null terminated */
+    }
+}
+
+static int is_pointer_to_heap(ScmObj obj)
+{
+    /* The core part of Conservative GC */
+    int i;
+    ScmObj head = SCM_NIL;
+    for (i = 0; i < scm_heap_num; i++) {
+	if ((head = scm_heaps[i])
+	    && (head <= obj)
+	    && (obj  <  head + SCM_HEAP_SIZE)
+	    && ((((char*)obj - (char*)head) % sizeof(ScmObj)) == 0))
+	    return 1;
+    }
+
+    return 0;
+}
+
+static void gc_mark_protected_obj(void)
+{
+    gc_protected_obj *item;
+    for (item = protected_obj_list; item; item = item->next_obj) {
+        mark_obj(item->obj);
+    }
+}
+
+static void gc_mark_stack(ScmObj *start, ScmObj *end)
+{
+    int i    = 0;
+    int size = 0;
+    ScmObj *tmp = NULL;
+
+    /* swap end and start if (end < start) */
+    if (end < start) {
+        tmp = end;
+        end = start;
+        start = tmp;
+    }
+
+    /* get size */
+    size = end - start;
+
+#if DEBUG_GC
+	printf("gc_mark_stack() size = %d\n", size);
+#endif
+
+    /* mark stack */
+    for (i = 0; i < size; i++) {
+        if (is_pointer_to_heap(start[i])) {
+            mark_obj(start[i]);
+        }
+    }
+}
+
+static void gc_mark_symbol_hash(void)
+{
+    int i = 0;
+    for (i = 0; i < NAMEHASH_SIZE; i++) {
+        mark_obj(symbol_hash[i]);
+    }
+}
+
+static void gc_mark(void)
+{
+    ScmObj obj;
+
+#if DEBUG_GC
+    printf("gc_mark\n");
+#endif
+
+    gc_mark_protected_obj();
+    gc_mark_stack(stack_start_pointer, &obj);
+    gc_mark_symbol_hash();
+}
+
+static void sweep_obj(ScmObj obj)
+{
+    /* if the type has the pointer to free, then free it! */
+    switch (SCM_GETTYPE(obj)) {
+	case ScmChar:
+	    if (SCM_CHAR_CH(obj)) {
+		free(SCM_CHAR_CH(obj));
+	    }
+	    break;
+        case ScmString:
+	    if (SCM_STRING_STR(obj)){
+		free(SCM_STRING_STR(obj));
+	    }
+            break;
+	case ScmVector:
+	    if (SCM_VECTOR_VEC(obj)) {
+		free(SCM_VECTOR_VEC(obj));
+	    }
+	    break;
+	case ScmSymbol:
+	    if (SCM_SYMBOL_NAME(obj)) {
+		free(SCM_SYMBOL_NAME(obj));
+	    }
+	    break;
+	case ScmPort:
+	    if (SCM_PORT_PORTINFO(obj)) {
+		free(SCM_PORT_PORTINFO(obj));
+	    }
+	    break;
+	default:
+	    break;
+    }
+}
+
+static void gc_sweep(void)
+{
+    int i = 0;
+    int j = 0;
+    int corrected_obj_num = 0;
+
+    ScmObj obj = SCM_NIL;
+    ScmObj scm_new_freelist = SCM_NIL;
+    /* iterate heaps */
+    for (i = 0; i < scm_heap_num; i++) {
+	corrected_obj_num = 0;
+	
+	/* iterate in heap */
+	for (j = 0; j < SCM_HEAP_SIZE; j++) {
+	    obj = &scm_heaps[i][j];
+	    if (!SCM_IS_MARKED(obj)) {
+		sweep_obj(obj);
+
+		SCM_SETFREECELL(obj);
+		SCM_SETFREECELL_CAR(obj, SCM_NIL);
+		SCM_SETFREECELL_CDR(obj, scm_new_freelist);
+		scm_new_freelist = obj;
+		corrected_obj_num++;
+	    }
+	}
+	
+#if DEBUG_GC
+	printf("scm[%d] corrected = %d\n", i, corrected_obj_num);
+#endif
+    }
+    scm_freelist = scm_new_freelist;
+}
+
+
+/*===========================================================================
+  Allocate Structure Functions
+===========================================================================*/
+ScmObj Scm_NewCons(ScmObj a, ScmObj b)
+{
+    ScmObj obj = SCM_NIL;
+    SCM_NEW_OBJ_INTERNAL(obj);
+
+    SCM_SETCONS(obj);
+    SCM_SETCAR(obj, a);
+    SCM_SETCDR(obj, b);
+
+    return obj;
+}
+
+ScmObj Scm_NewInt(int val)
+{
+    ScmObj obj = SCM_NIL;
+    SCM_NEW_OBJ_INTERNAL(obj);
+
+    SCM_SETINT(obj);
+    SCM_SETINT_VALUE(obj, val);
+
+    return obj;
+}
+
+ScmObj Scm_NewSymbol(char *name, ScmObj v_cell)
+{
+    ScmObj obj = SCM_NIL;
+    SCM_NEW_OBJ_INTERNAL(obj);
+
+    SCM_SETSYMBOL(obj);
+    SCM_SETSYMBOL_NAME(obj, name);
+    SCM_SETSYMBOL_VCELL(obj, v_cell);
+
+    return obj;
+}
+
+ScmObj Scm_NewChar(char *ch)
+{
+    ScmObj obj = SCM_NIL;
+
+    /* check length */
+    if (SigScm_default_encoding_strlen(ch) != 1) {
+	printf("ch = [%s], len = %d\n", ch, SigScm_default_encoding_strlen(ch));
+	SigScm_Error("invalid character\n");
+    }
+
+    SCM_NEW_OBJ_INTERNAL(obj);
+
+    SCM_SETCHAR(obj);
+    SCM_SETCHAR_CH(obj, ch);
+
+    return obj;
+}
+
+ScmObj Scm_NewString(char *str)
+{
+    ScmObj obj = SCM_NIL;
+
+    SCM_NEW_OBJ_INTERNAL(obj);
+
+    SCM_SETSTRING(obj);
+    SCM_SETSTRING_STR(obj, str);
+    SCM_SETSTRING_LEN(obj, SigScm_default_encoding_strlen(str));
+
+    return obj;
+}
+
+ScmObj Scm_NewString_With_StrLen(char *str, int len)
+{
+    ScmObj obj = SCM_NIL;
+    SCM_NEW_OBJ_INTERNAL(obj);
+
+    SCM_SETSTRING(obj);
+    SCM_SETSTRING_STR(obj, str);
+    SCM_SETSTRING_LEN(obj, len);
+
+    return obj;
+}
+
+ScmObj Scm_NewFunc(enum ScmFuncArgNum num_arg, ScmFuncType func)
+{
+    ScmObj obj = SCM_NIL;
+    SCM_NEW_OBJ_INTERNAL(obj);
+
+    SCM_SETFUNC(obj);
+    SCM_SETFUNC_NUMARG(obj, num_arg);
+    SCM_SETFUNC_FUNC(obj, func);
+
+    return obj;
+}
+
+ScmObj Scm_NewClosure(ScmObj exp, ScmObj env)
+{
+    ScmObj obj = SCM_NIL;
+    SCM_NEW_OBJ_INTERNAL(obj);
+
+    SCM_SETCLOSURE(obj);
+    SCM_SETCLOSURE_EXP(obj, exp);
+    SCM_SETCLOSURE_ENV(obj, env);
+
+    return obj;
+}
+
+ScmObj Scm_NewVector(ScmObj *vec, ScmObj len)
+{
+    ScmObj obj = SCM_NIL;
+    SCM_NEW_OBJ_INTERNAL(obj);
+    
+    SCM_SETVECTOR(obj);
+    SCM_SETVECTOR_VEC(obj, vec);
+    SCM_SETVECTOR_LEN(obj, len);
+
+    return obj;
+}
+
+ScmObj Scm_NewPort(FILE *file, enum ScmPortType ptype)
+{
+    ScmObj obj = SCM_NIL;
+    ScmPortInfo *pinfo = NULL;
+
+    SCM_NEW_OBJ_INTERNAL(obj);
+
+    SCM_SETPORT(obj);
+    pinfo  = (ScmPortInfo *)malloc(sizeof(ScmPortInfo));
+    pinfo->file         = file;
+    pinfo->ungottenchar = 0;
+    SCM_SETPORT_PORTINFO(obj, pinfo);
+    SCM_SETPORT_PORTTYPE(obj, ptype);
+
+    return obj;
+}
+
+/*
+ * Symbol Name Hash Related Functions
+ *
+ * - Data Structure of Symbol Name Hash
+ *
+ *     - n = symbol_name_hash(name)
+ *     - symbol_hash[n] = sym_list
+ *     - sym_list = ( ScmObj(SYMBOL) ScmObj(SYMBOL) ... )
+ *
+ */
+static void initialize_symbol_hash(void)
+{
+    int i = 0;
+    symbol_hash = (ScmObj*)malloc(sizeof(ScmObj) * NAMEHASH_SIZE);
+    for (i = 0; i < NAMEHASH_SIZE; i++) {
+        symbol_hash[i] = SCM_NIL;
+    
+    }
+}
+
+static void finalize_symbol_hash(void)
+{
+    free(symbol_hash);
+}
+
+static int symbol_name_hash(const char *name)
+{
+    int hash = 0;
+    int c;
+    char *cname = (char *)name;
+    while ((c = *cname++)) {
+	hash = ((hash * 17) ^ c) % NAMEHASH_SIZE;
+    }
+    return hash;
+}
+
+ScmObj Scm_Intern(const char *name)
+{
+    int n = symbol_name_hash(name);
+    ScmObj sym      = SCM_NIL;
+    ScmObj list     = SCM_NIL;
+    ScmObj sym_list = symbol_hash[n];
+    char  *symname  = (char*)malloc(strlen(name) + 1);
+
+    /* copy string */
+    strcpy(symname, name);
+
+    /* Search Symbol by name */
+    list = sym_list;
+    for (; !SCM_NULLP(list); list = SCM_CDR(list)) {
+        sym = SCM_CAR(list);
+
+        if (strcmp(SCM_SYMBOL_NAME(sym), name) == 0) {
+            free(symname);
+            return sym;
+        }
+    }
+
+    /* If not in the sym_list, allocate new Symbol */
+    sym = Scm_NewSymbol(symname, SCM_UNBOUND);
+
+    /* And Append it to the head of symbol_hash */
+    sym_list = Scm_NewCons(sym, sym_list);
+    symbol_hash[n] = sym_list;
+
+    return sym;
+}

Added: branches/r5rs/sigscheme/debug.c
===================================================================
--- branches/r5rs/sigscheme/debug.c	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/debug.c	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,193 @@
+/*===========================================================================
+ *  FileName : debug.c
+ *  About    : Functions for debugging
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+/*=======================================
+  System Include
+=======================================*/
+#include <stdio.h>
+
+/*=======================================
+  Local Include
+=======================================*/
+#include "sigscheme.h"
+
+/*=======================================
+  File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+  File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+  Variable Declarations
+=======================================*/
+
+/*=======================================
+  File Local Function Declarations
+=======================================*/
+static void print_ScmObj_internal(FILE *f, ScmObj obj);
+static void print_list(FILE *f, ScmObj list);
+static void print_vector(FILE *f, ScmObj vec);
+
+/*=======================================
+   Function Implementations
+=======================================*/
+void SigScm_Display(ScmObj obj)
+{
+    print_ScmObj_internal(stdout, obj);
+    fprintf(stdout, "\n");
+}
+
+void SigScm_DisplayToPort(ScmObj port, ScmObj obj)
+{
+    FILE *f = SCM_PORTINFO_FILE(port);
+
+
+    print_ScmObj_internal(f, obj);
+}
+
+static void print_ScmObj_internal(FILE *f, ScmObj obj)
+{
+    if (SCM_CONSP(obj)) {
+	print_list(f, obj);
+    } else if (SCM_INTP(obj)) {
+	fprintf(f, "%d", SCM_INT_VALUE(obj));
+    } else if (SCM_SYMBOLP(obj)) {
+	fprintf(f, "%s", SCM_SYMBOL_NAME(obj));
+    } else if (SCM_CHARP(obj)) {
+	if (strcmp(SCM_CHAR_CH(obj), " ") == 0)
+	    fprintf(f, "#\\space");
+	else if(strcmp(SCM_CHAR_CH(obj), "\n") == 0)
+	    fprintf(f, "#\\newline");
+	else
+	    fprintf(f, "#\\%s", SCM_CHAR_CH(obj));
+    } else if (SCM_STRINGP(obj)) {
+	fprintf(f, "%s", SCM_STRING_STR(obj));
+    } else if (SCM_FUNCP(obj)) {
+	fprintf(f, "[ Func ]");
+    } else if (SCM_CLOSUREP(obj)) {
+	fprintf(f, "#<closure:");
+	print_ScmObj_internal(f, SCM_CLOSURE_EXP(obj));
+	fprintf(f, ">");
+    } else if (SCM_VECTORP(obj)) {
+	print_vector(f, obj);
+    } else if (SCM_FREECELLP(obj)) {
+	fprintf(f, "[ FreeCell ] \n");
+    } else {
+        if (EQ(obj, SCM_NIL)) {
+            fprintf(f, "()");
+        } else if (EQ(obj, SCM_TRUE)) {
+            fprintf(f, "#t");
+        } else if (EQ(obj, SCM_FALSE)) {
+            fprintf(f, "#f");
+	} else if (EQ(obj, SCM_EOF)) {
+	    fprintf(f, "EOF");
+        } else if (EQ(obj, SCM_QUOTE)) {
+            fprintf(f, "QUOTE");
+        } else if (EQ(obj, SCM_QUASIQUOTE)) {
+            fprintf(f, "QUASIQUOTE");
+        } else if (EQ(obj, SCM_UNQUOTE)) {
+            fprintf(f, "UNQUOTE");
+        } else if (EQ(obj, SCM_UNQUOTE_SPLICING)) {
+            fprintf(f, "UNQUOTE_SPLICING");
+        } else if (EQ(obj, SCM_UNBOUND)) {
+	    fprintf(f, "UNBOUND");
+	} else if (EQ(obj, SCM_UNSPECIFIED)) {
+	    fprintf(f, "UNSPECIFIED");
+	} else if (EQ(obj, SCM_UNDEF)) {
+	    fprintf(f, "UNDEF");
+	}
+    }
+}
+
+static void print_list(FILE *f, ScmObj list)
+{
+    ScmObj car = SCM_NIL;
+    ScmObj cdr = SCM_NIL;
+    ScmObj tmp = SCM_NIL;
+
+    /* print left parenthesis */
+    fprintf(f, "(");
+
+    /* get car and cdr */
+    car = SCM_CAR(list);
+    cdr = SCM_CDR(list);
+    
+    /* print car */
+    print_ScmObj_internal(f, car);
+    if (!SCM_NULLP(cdr))
+	fprintf(f, " ");
+
+    /* print else for-each */
+    for (tmp = cdr; ; tmp = SCM_CDR(tmp)) {
+	if (SCM_CONSP(tmp)) {
+	    print_ScmObj_internal(f, SCM_CAR(tmp));
+	    if (SCM_NULLP(SCM_CDR(tmp))) {
+		fprintf(f, ")");
+		return;
+	    } else {
+		if (!SCM_NULLP(SCM_CDR(tmp)))
+		    fprintf(f, " ");
+	    }
+	} else {
+	    if (!SCM_NULLP(tmp)) {
+		fprintf(f, ". ");
+		print_ScmObj_internal(f, tmp);
+	    }
+
+	    fprintf(f, ")");
+	    return;
+	}
+    }
+}
+
+static void print_vector(FILE *f, ScmObj vec)
+{
+    ScmObj *v = SCM_VECTOR_VEC(vec); 
+    int c_len = SCM_INT_VALUE(SCM_VECTOR_LEN(vec));
+    int i     = 0;
+
+    /* print left parenthesis with '#' */
+    fprintf(f, "#(");
+
+    /* print each element */
+    for (i = 0; i < c_len; i++) {
+	print_ScmObj_internal(f, v[i]);
+
+	if (i != c_len - 1)
+	    fprintf(f, " ");
+    }
+
+    fprintf(f, ")");
+}

Added: branches/r5rs/sigscheme/encoding.c
===================================================================
--- branches/r5rs/sigscheme/encoding.c	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/encoding.c	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,146 @@
+/*===========================================================================
+ *  FileName : encoding.c
+ *  About    : handling encoding
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+/*=======================================
+  System Include
+=======================================*/
+
+/*=======================================
+  Local Include
+=======================================*/
+#include "sigscheme.h"
+
+/*=======================================
+  File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+  File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+  Variable Declarations
+=======================================*/
+
+/*=======================================
+  File Local Function Declarations
+=======================================*/
+static int eucjp_strlen(const char *p);
+static const char* eucjp_str_startpos(const char *p, int k);
+static const char* eucjp_str_endpos(const char *p, int k);
+
+/*=======================================
+  Function Implementations
+=======================================*/
+int SigScm_default_encoding_strlen(const char *str)
+{
+#if USE_EUCJP
+    return eucjp_strlen(str);
+#endif
+}
+
+const char* SigScm_default_encoding_str_startpos(const char *str, int k)
+{
+#if USE_EUCJP
+    return eucjp_str_startpos(str, k);
+#endif    
+}
+
+const char* SigScm_default_encoding_str_endpos(const char *str, int k)
+{
+#if USE_EUCJP
+    return eucjp_str_endpos(str, k);
+#endif    
+}
+
+static int eucjp_strlen(const char *str)
+{
+    int len = 0;
+    const unsigned char *cur = (const unsigned char *)str;
+    while (*cur) {
+	if (*cur > 127) {
+	    /* 2 bytes */
+	    cur++;
+	}
+
+	cur++;
+	len++;
+    }
+
+    return len;
+}
+
+static const char* eucjp_str_startpos(const char *str, int k)
+{
+    int len = 0;
+    const unsigned char *cur = (const unsigned char *)str;
+    while (*cur) {
+	if (len == k)
+	    return (const char *)cur;
+
+	if (*cur > 127) {
+	    /* 2 bytes */
+	    cur++;
+	}
+
+	cur++;
+	len++;
+    }
+
+    SigScm_Error("eucjp_str_startpos : unreachable point\n");
+    return NULL;
+}
+
+static const char* eucjp_str_endpos(const char *str, int k)
+{
+    int len = 0;
+    const unsigned char *cur = (const unsigned char *)str;
+    while (*cur) {
+	if (*cur > 127) {
+	    /* 2 bytes */
+	    cur++;
+	}
+
+	cur++;
+	len++;
+
+	if (len == k + 1)
+	    return (const char *)cur;
+    }
+    
+    if (len == k + 1)
+	return (const char *)cur;
+
+    SigScm_Error("eucjp_str_startpos : unreachable point\n");
+    return NULL;
+}

Added: branches/r5rs/sigscheme/error.c
===================================================================
--- branches/r5rs/sigscheme/error.c	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/error.c	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,70 @@
+/*===========================================================================
+ *  FileName : error.c
+ *  About    : handling errors
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+/*=======================================
+  System Include
+=======================================*/
+#include <stdio.h>
+
+/*=======================================
+  Local Include
+=======================================*/
+#include "sigscheme.h"
+
+/*=======================================
+  File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+  File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+  File Local Function Declarations
+=======================================*/
+
+/*=======================================
+  Function Implementations
+=======================================*/
+int SigScm_Die(const char *msg, const char *filename, int line) {
+    printf("SigScheme Died : %s (file : %s, line : %d)\n", msg, filename, line);
+    exit(-1);
+
+    return -1;
+}
+
+void SigScm_Error(const char *msg)
+{
+    fprintf(stderr, "%s\n", msg);
+    exit(-1);
+}

Added: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/eval.c	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,983 @@
+/*===========================================================================
+ *  FileName : eval.c
+ *  About    : Evaluation and basic Syntactic Expression
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+
+/*
+ * Descrioption of Environment
+ *
+ * [1] Data Structure of Environment
+ *     Environment is the simple list that is formed as below.
+ *
+ *     - Frame = ( (var1 var2 var3 ...)
+ *                 (val1 val2 val3 ...) )
+ *     - Env   = ( Frame1 Frame2 Frame3 ...)
+ *
+ */
+
+/*=======================================
+  System Include
+=======================================*/
+
+/*=======================================
+  Local Include
+=======================================*/
+#include "sigscheme.h"
+
+/*=======================================
+  File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+  File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+  Variable Declarations
+=======================================*/
+
+/*=======================================
+  File Local Function Declarations
+=======================================*/
+static ScmObj extend_environment(ScmObj vars, ScmObj vals, ScmObj env);
+static ScmObj add_environment(ScmObj var, ScmObj val, ScmObj env);
+static ScmObj lookup_environment(ScmObj var, ScmObj env);
+static ScmObj lookup_frame(ScmObj var, ScmObj frame);
+
+static ScmObj symbol_value(ScmObj var, ScmObj env);
+
+static ScmObj map_eval(ScmObj args, ScmObj env);
+static ScmObj eval_unquote(ScmObj args, ScmObj env);
+static ScmObj ScmOp_last_pair(ScmObj list);
+
+/*=======================================
+  Function Implementations
+=======================================*/
+static ScmObj extend_environment(ScmObj vars, ScmObj vals, ScmObj env)
+{
+    ScmObj frame = SCM_NIL;
+
+    /* sanity check */
+    if (SCM_NULLP(vars) && SCM_NULLP(vals))
+	return env;
+
+    /* create new frame */
+    frame   = Scm_NewCons(vars, vals);
+
+    /* add to env */
+    if (SCM_NULLP(env))
+        env = Scm_NewCons(frame, SCM_NIL);
+    else if (SCM_CONSP(env))
+        env = Scm_NewCons(frame, env);
+    else
+        SigScm_Error("Broken environment.\n");
+
+    return env;
+}
+
+
+static ScmObj add_environment(ScmObj var, ScmObj val, ScmObj env)
+{
+    ScmObj newest_frame, tmp;
+    ScmObj new_varlist, new_vallist;
+
+    /* sanity check */
+    if (SCM_NULLP(var) && SCM_NULLP(val))
+	return env;
+
+    /* add (var val) pair to the newest frame in env */
+    if (SCM_NULLP(env)) {
+	env = Scm_NewCons(Scm_NewCons(var, val),
+			  SCM_NIL);
+    } else if (SCM_CONSP(env)) {
+	newest_frame = SCM_CAR(env);
+	new_varlist  = Scm_NewCons(var, SCM_CAR(newest_frame));
+
+	tmp = SCM_CDR(newest_frame);
+	tmp = SCM_CAR(tmp);
+
+	new_vallist  = Scm_NewCons(val, tmp);
+	env = Scm_NewCons(Scm_NewCons(new_varlist, new_vallist), SCM_CDR(newest_frame));
+    } else {
+	SigScm_Error("broken environment\n");
+    }
+
+    return env;
+}
+
+/*========================================================
+  ScmObj lookup_environment(ScmObj var, ScmObj env)
+
+  @return list which represent (val vals-in-frame).
+          val is the value of var.
+
+  TODO : describe more precicely
+========================================================*/
+static ScmObj lookup_environment(ScmObj var, ScmObj env)
+{
+    ScmObj frame = SCM_NIL;
+    ScmObj val   = SCM_NIL;
+
+    /* sanity check */
+    if (SCM_NULLP(env))
+        return SCM_NIL;
+    if (!SCM_CONSP(env))
+        SigScm_Error("Broken environent.\n");
+
+    /* lookup frames */
+    for (; !SCM_NULLP(env); env = SCM_CDR(env)) {
+        frame = SCM_CAR(env);
+        val   = lookup_frame(var, frame);
+        if (!SCM_NULLP(val))
+            return val;
+    }
+
+    return SCM_NIL;
+}
+
+static ScmObj lookup_frame(ScmObj var, ScmObj frame)
+{
+    ScmObj vals = SCM_NIL;
+    ScmObj vars = SCM_NIL;
+
+    /* sanity check */
+    if (SCM_NULLP(frame))
+        return SCM_NIL;
+    else if (!SCM_CONSP(frame))
+        SigScm_Error("Broken frame.\n");
+
+    /* lookup in frame */
+    vals = SCM_CDR(frame);
+    vars = SCM_CAR(frame);
+    for (; !SCM_NULLP(vars) && !SCM_NULLP(vals); vars = SCM_CDR(vars), vals = SCM_CDR(vals)) {
+        if (SCM_EQ(SCM_CAR(vars), var)) {
+            return vals;
+	}
+    }
+
+    return SCM_NIL;
+}
+
+/*===========================================================================
+  S-Expression Evaluation
+===========================================================================*/
+ScmObj ScmOp_eval(ScmObj obj, ScmObj env)
+{
+    ScmObj tmp  = SCM_NIL;
+    ScmObj arg  = SCM_NIL;
+
+    switch (SCM_GETTYPE(obj)) {
+        case ScmSymbol:
+            return symbol_value(obj, env);
+
+	/*====================================================================
+	  Evaluating Expression
+	====================================================================*/
+        case ScmCons:
+            {
+		/*============================================================
+		  Evaluating CAR
+		============================================================*/
+                tmp = SCM_CAR(obj);
+                switch (SCM_GETTYPE(tmp)) {
+		    case ScmFunc:
+			break;
+                    case ScmSymbol:
+                        tmp = symbol_value(tmp, env);
+                        break;
+		    case ScmClosure:
+			break;
+                    case ScmCons:
+                        tmp = ScmOp_eval(tmp, env);
+                        break;
+		    case ScmEtc:
+			/* QUOTE case */
+			break;
+		    default:
+			SigScm_Display(tmp);
+			SigScm_Error("eval : invalid operation\n");
+			break;
+                }
+		/*============================================================
+		  Evaluating the rest of the List by the type of CAR
+		============================================================*/
+                switch (SCM_GETTYPE(tmp)) {
+                    case ScmFunc:
+                        switch (SCM_FUNC_NUMARG(tmp)) {
+                            case ARGNUM_L:
+                                {
+                                    return SCM_FUNC_EXEC_SUBRL(tmp,
+                                                               map_eval(SCM_CDR(obj), env),
+							       env);
+                                }
+			    case ARGNUM_R:
+				{
+                                    return SCM_FUNC_EXEC_SUBRR(tmp,
+                                                               SCM_CDR(obj),
+							       env);
+				}
+			    case ARGNUM_2N:
+				{
+				    obj = SCM_CDR(obj);
+				    arg = ScmOp_eval(SCM_CAR(obj), env);
+				    for (obj = SCM_CDR(obj); !SCM_NULLP(obj); obj = SCM_CDR(obj)) {
+					arg = SCM_FUNC_EXEC_SUBR2N(tmp,
+								   arg,
+								   ScmOp_eval(SCM_CAR(obj), env));
+				    }
+				    return arg;
+				}
+                            case ARGNUM_0:
+                                return SCM_FUNC_EXEC_SUBR0(tmp);
+                            case ARGNUM_1:
+                                return SCM_FUNC_EXEC_SUBR1(tmp, ScmOp_eval(SCM_CAR(SCM_CDR(obj)),env));
+                            case ARGNUM_2:
+                                {
+                                    obj = SCM_CDR(obj);
+                                    arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
+                                    return SCM_FUNC_EXEC_SUBR2(tmp,
+                                                               arg,
+                                                               ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env)); /* 2nd arg */
+                                }
+			    case ARGNUM_3:
+				{
+				    obj = SCM_CDR(obj);
+				    arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
+				    obj = SCM_CDR(obj);
+				    return SCM_FUNC_EXEC_SUBR3(tmp,
+							       arg,
+							       ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
+							       ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env)); /* 3rd arg */
+				}
+			    case ARGNUM_4:
+				{
+				    obj = SCM_CDR(obj);
+				    arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
+				    obj = SCM_CDR(obj);
+				    return SCM_FUNC_EXEC_SUBR4(tmp,
+							       arg,
+							       ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
+							       ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env), /* 3rd arg */
+							       ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(obj))), env)); /* 4th arg */
+				}
+			    case ARGNUM_5:
+				{
+				    obj = SCM_CDR(obj);
+				    arg = ScmOp_eval(SCM_CAR(obj), env); /* 1st arg */
+				    obj = SCM_CDR(obj);
+				    return SCM_FUNC_EXEC_SUBR5(tmp,
+							       arg,
+							       ScmOp_eval(SCM_CAR(obj), env), /* 2nd arg */
+							       ScmOp_eval(SCM_CAR(SCM_CDR(obj)), env), /* 3rd arg */
+							       ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(obj))), env), /* 4th arg */
+							       ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(obj)))), env)); /* 5th arg */
+
+				}
+                        }
+                        break;
+		    case ScmClosure:
+			{
+			    env = extend_environment(SCM_CAR(SCM_CLOSURE_EXP(tmp)),
+						     map_eval(SCM_CDR(obj), env),
+						     SCM_CLOSURE_ENV(tmp));
+			    return ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CLOSURE_EXP(tmp))), env);
+			}
+		    case ScmEtc:
+			if (EQ(tmp, SCM_QUOTE)) {
+			    return SCM_CDR(obj);
+			}
+			if (EQ(tmp, SCM_QUASIQUOTE)) {
+			    return eval_unquote(SCM_CDR(obj), env);
+			}
+			return tmp;
+                    default:
+			SigScm_Display(tmp);
+                        /* What? */
+                        SigScm_Error("eval : What type of function?\n");
+                }
+
+            }
+        default:
+            return obj;
+    }
+
+    return SCM_NIL;
+}
+
+ScmObj ScmOp_apply(ScmObj args, ScmObj env)
+{
+    ScmObj proc = SCM_NIL;
+    ScmObj obj  = SCM_NIL;
+
+    /* sanity check */
+    if CHECK_2_ARGS(args)
+	SigScm_Error("apply : Wrong number of arguments\n");
+
+    /* 1st elem of list is proc */
+    proc = SCM_CAR(args);
+
+    /* apply proc */
+    switch (SCM_GETTYPE(proc)) {
+	case ScmFunc:
+	    switch (SCM_FUNC_NUMARG(proc)) {
+		case ARGNUM_L:
+		    {
+			return SCM_FUNC_EXEC_SUBRL(proc,
+						   map_eval(SCM_CAR(SCM_CDR(args)), env),
+						   env);
+		    }
+		case ARGNUM_R:
+		    {
+			return SCM_FUNC_EXEC_SUBRR(proc,
+						   SCM_CAR(SCM_CDR(args)),
+						   env);
+		    }
+		case ARGNUM_2N:
+		    {
+			args = SCM_CAR(SCM_CDR(args));
+			obj  = SCM_CAR(args);
+			for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
+			    obj = SCM_FUNC_EXEC_SUBR2N(proc,
+						       obj,
+						       ScmOp_eval(SCM_CAR(args), env));
+			}	
+			return obj;
+		    }
+		case ARGNUM_0:
+		    {
+			return SCM_FUNC_EXEC_SUBR0(proc);
+		    }
+		case ARGNUM_1:
+		    {
+			return SCM_FUNC_EXEC_SUBR1(proc,
+						   SCM_CAR(SCM_CDR(args)));
+		    }
+		case ARGNUM_2:
+		    {
+			return SCM_FUNC_EXEC_SUBR2(proc,
+						   SCM_CAR(SCM_CDR(args)),
+						   SCM_CAR(SCM_CDR(SCM_CDR(args))));
+		    }
+		case ARGNUM_3:
+		    {
+			return SCM_FUNC_EXEC_SUBR3(proc,
+						   SCM_CAR(SCM_CDR(args)),
+						   SCM_CAR(SCM_CDR(SCM_CDR(args))),
+						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(args)))));
+		    }
+		case ARGNUM_4:
+		    {
+			return SCM_FUNC_EXEC_SUBR4(proc,
+						   SCM_CAR(SCM_CDR(args)),
+						   SCM_CAR(SCM_CDR(SCM_CDR(args))),
+						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(args)))),
+						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(args))))));
+		    }
+		case ARGNUM_5:
+		    {
+			return SCM_FUNC_EXEC_SUBR5(proc,
+						   SCM_CAR(SCM_CDR(args)),
+						   SCM_CAR(SCM_CDR(SCM_CDR(args))),
+						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(args)))),
+						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(args))))),
+						   SCM_CAR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(args)))))));
+		    }
+	    }
+	    break;
+	case ScmClosure:
+	    {
+		env = extend_environment(SCM_CAR(SCM_CLOSURE_EXP(proc)),
+					 SCM_CAR(SCM_CDR(args)),
+					 SCM_CLOSURE_ENV(proc));
+		return ScmOp_eval(SCM_CAR(SCM_CDR(SCM_CLOSURE_EXP(proc))), env);
+	    }
+	case ScmEtc:
+	    if (EQ(proc, SCM_QUOTE)) {
+		return SCM_CDR(args);
+	    }
+	    if (EQ(proc, SCM_QUASIQUOTE)) {
+		return eval_unquote(SCM_CDR(args), env);
+	    }
+	default:
+	    SigScm_Display(proc);
+	    SigScm_Error("apply : What type of function?\n");
+    }
+
+    /* never reaches here */
+    return SCM_NIL;
+}
+
+static ScmObj symbol_value(ScmObj var, ScmObj env)
+{
+    ScmObj val = SCM_NIL;
+    
+    /* sanity check */
+    if (!SCM_SYMBOLP(var))
+	SigScm_Error("not symbol.\n");
+
+    /* First, lookup the Environment */
+    val = lookup_environment(var, env);
+    if (!SCM_NULLP(val)) {
+        /* Variable is found in Environment, so returns its value */
+        return SCM_CAR(val);
+    }
+
+    /* Next, look at the VCELL */
+    val = SCM_SYMBOL_VCELL(var);
+    if (EQ(val, SCM_UNBOUND)) {
+        SigScm_Error("symbol_value : unbound variable.\n");
+    }
+
+    return val;
+}
+
+ScmObj map_eval(ScmObj args, ScmObj env)
+{
+    ScmObj result  = SCM_NIL;
+    ScmObj tail    = SCM_NIL;
+    ScmObj newtail = SCM_NIL;
+
+    /* sanity check */
+    if (SCM_NULLP(args))
+        return SCM_NIL;
+
+    /* eval each element of args */
+    result  = Scm_NewCons( ScmOp_eval(SCM_CAR(args), env), SCM_NIL );
+    tail    = result;
+    newtail = SCM_NIL;
+    for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
+	newtail = Scm_NewCons( ScmOp_eval(SCM_CAR(args), env), SCM_NIL );
+	SCM_SETCDR(tail, newtail);
+	tail = newtail;
+    }
+
+    return result;
+}
+
+/*
+ * TODO : implement this properly as defined in R5RS!!
+ *
+ * Quasiquote forms may be nested. Substitutions are made only
+ * for unquoted components appearing at the same nesting level
+ * as the outermost backquote. The nesting level increases by
+ * one inside each successive quasiquotation, and decreases by
+ * one inside each unquotation.
+ */
+static ScmObj eval_unquote(ScmObj args, ScmObj env)
+{
+    ScmObj list = args;
+    ScmObj prev = list;
+    ScmObj obj  = SCM_NIL;
+
+    /* scanning list */
+    for (; !SCM_NULLP(list); list = SCM_CDR(list))
+    {
+	obj = SCM_CAR(list);
+
+	/* handle quotes */
+	if (SCM_CONSP(obj)) {
+	    /* handle nested SCM_QUASIQUOTE(`) */
+	    if (EQ(SCM_CDR(obj), SCM_QUASIQUOTE)) {
+		continue; /* left untouched */
+	    }
+
+	    /* handle SCM_UNQUOTE(,) */
+	    if (EQ(SCM_CAR(obj), SCM_UNQUOTE)) {
+		SCM_SETCAR(list, ScmOp_eval(SCM_CDR(obj), env));
+	    }
+
+	    /* handle SCM_UNQUOTE_SPLICING(,@) */
+	    if (EQ(SCM_CAR(obj), SCM_UNQUOTE_SPLICING)) {
+		obj = ScmOp_eval(SCM_CDR(obj), env);
+		if (!SCM_CONSP(obj))
+		    SigScm_Error("invalid unquote-splicing (,@)\n");
+
+		SCM_SETCDR(ScmOp_last_pair(obj), SCM_CDR(SCM_CDR(prev)));
+		SCM_SETCDR(prev, obj);
+	    }
+	}
+
+	prev = list;
+    }
+
+    return args;
+}
+
+static ScmObj ScmOp_last_pair(ScmObj list)
+{
+    /* sanity check */
+    if (SCM_NULLP(list))
+	return SCM_NIL;
+    if (!SCM_CONSP(list))
+	SigScm_Error("last_pair : require list\n");
+
+    while (1) {
+        if (!SCM_CONSP(list) || SCM_NULLP(SCM_CDR(list)))
+            return list;
+
+        list = SCM_CDR(list);
+    }
+
+    return SCM_NIL;
+}
+
+/*=======================================
+  R5RS : 4.1 Primitive expression types
+=======================================*/
+/*===========================================================================
+  R5RS : 4.1 Primitive expression types : 4.1.2 Literal expressions
+===========================================================================*/
+ScmObj ScmOp_quote(ScmObj obj)
+{
+    ScmObj quotedObj = Scm_NewCons(SCM_QUOTE, obj);
+
+    return quotedObj;
+}
+
+/*===========================================================================
+  R5RS : 4.1 Primitive expression types : 4.1.4 Procedures
+===========================================================================*/
+ScmObj ScmExp_lambda(ScmObj exp, ScmObj env)
+{
+    if CHECK_2_ARGS(exp)
+	SigScm_Error("lambda : few argument\n");
+
+    return Scm_NewClosure(exp, env);
+}
+
+/*===========================================================================
+  R5RS : 4.1 Primitive expression types : 4.1.5 Conditionals
+===========================================================================*/
+ScmObj ScmExp_if(ScmObj exp, ScmObj env)
+{
+    ScmObj pred      = SCM_NIL;
+    ScmObj false_exp = SCM_NIL;
+
+    /* sanity check */
+    if (SCM_NULLP(exp) || SCM_NULLP(SCM_CDR(exp)))
+	SigScm_Error("if : syntax error\n");
+
+    /* eval predicates */
+    pred = ScmOp_eval(SCM_CAR(exp), env);
+
+    /* if pred is SCM_TRUE */
+    if (EQ(pred, SCM_TRUE))
+	return ScmOp_eval(SCM_CAR(SCM_CDR(exp)), env);
+
+    /* if pred is SCM_FALSE */
+    false_exp = SCM_CDR(SCM_CDR(exp));
+    if (SCM_NULLP(false_exp))
+	return SCM_UNDEF;
+
+    return ScmOp_eval(SCM_CAR(false_exp), env);
+}
+
+/*===========================================================================
+  R5RS : 4.1 Primitive expression types : 4.1.6 Assignment
+===========================================================================*/
+ScmObj ScmExp_set(ScmObj arg, ScmObj env)
+{
+    ScmObj sym = SCM_CAR(arg);
+    ScmObj val = SCM_CAR(SCM_CDR(arg));
+    ScmObj ret = SCM_NIL;
+    ScmObj tmp = SCM_NIL;
+
+    if (SCM_NULLP(val))
+	SigScm_Error("set! : syntax error\n");
+
+    ret = ScmOp_eval(val, env);
+    tmp = lookup_environment(sym, env);
+    if (SCM_NULLP(tmp)) {
+	/*
+	 * not found in the environment
+	 * if symbol is not bounded, error occurs
+	 */
+	if (EQ(ScmOp_boundp(sym), SCM_FALSE))
+	    SigScm_Error("set! : unbound variable\n");
+
+	SCM_SETSYMBOL_VCELL(sym, ret);
+    } else {
+	/* found in the environment*/
+	SCM_SETCAR(tmp, ret);
+    }
+
+    return ret;
+}
+
+
+/*=======================================
+  R5RS : 4.2 Derived expression types
+=======================================*/
+/*===========================================================================
+  R5RS : 4.2 Derived expression types : 4.2.1 Conditionals
+===========================================================================*/
+ScmObj ScmExp_cond(ScmObj arg, ScmObj env)
+{
+    ScmObj clause = SCM_NIL;
+    ScmObj test   = SCM_NIL;
+    ScmObj exps   = SCM_NIL;
+    /* looping in each clause */
+    for (; !SCM_NULLP(arg); arg = SCM_CDR(arg)) {
+	clause = SCM_CAR(arg);
+	test   = SCM_CAR(clause);
+	exps   = SCM_CDR(clause);
+	if (SCM_NULLP(clause) || SCM_NULLP(test) || SCM_NULLP(exps))
+	    SigScm_Error("cond : syntax error\n");
+
+	/* evaluate test and check the result */
+	if (SCM_EQ(ScmOp_eval(test, env), SCM_TRUE)) {
+	    return ScmExp_begin(exps, env);
+	}
+    }
+
+    SigScm_Error("cond : invalid expression\n");
+    return SCM_NIL;
+}
+
+ScmObj ScmExp_case(ScmObj arg, ScmObj env)
+{
+    ScmObj key    = ScmOp_eval(SCM_CAR(arg), env);
+    ScmObj clause = SCM_NIL;
+    ScmObj datums = SCM_NIL;
+    ScmObj exps   = SCM_NIL;
+
+    /* looping in each clause */
+    for (arg = SCM_CDR(arg); !SCM_NULLP(arg); arg = SCM_CDR(arg)) {
+	clause = SCM_CAR(arg);
+	datums = SCM_CAR(clause);
+	exps   = SCM_CDR(clause);
+	if (SCM_NULLP(clause) || SCM_NULLP(datums) || SCM_NULLP(exps))
+	    SigScm_Error("cond : syntax error\n");
+
+	/* check "else" symbol */
+	if (SCM_NULLP(SCM_CDR(arg)) && !SCM_CONSP(datums) && EQ(SCM_SYMBOL_VCELL(datums), SCM_TRUE))
+	    return ScmExp_begin(exps, env);
+
+	/* evaluate datums and compare to key by eqv? */
+	for (; !SCM_NULLP(datums); datums = SCM_CDR(datums)) {
+	    if (EQ(ScmOp_eqvp(ScmOp_eval(SCM_CAR(datums), env), key), SCM_TRUE)) {
+		return ScmExp_begin(exps, env);
+	    }
+	}
+    }
+
+    return SCM_UNSPECIFIED;
+}
+
+ScmObj ScmExp_and(ScmObj arg, ScmObj env)
+{
+    ScmObj obj = SCM_NIL;
+    ScmObj ret = SCM_NIL;
+
+    /* sanity check */
+    if (SCM_NULLP(arg))
+	return SCM_TRUE;
+    if (EQ(ScmOp_listp(arg), SCM_FALSE))
+	SigScm_Error("and : cannot evaluate improper list\n");
+
+    /* check recursively */
+    for (; !SCM_NULLP(arg); arg = SCM_CDR(arg)) {
+	obj = SCM_CAR(arg);
+	ret = ScmOp_eval(obj, env);
+	if (EQ(ret, SCM_FALSE))
+	    return SCM_FALSE;
+
+	/* return last item */
+	if (SCM_NULLP(SCM_CDR(arg))) {
+	    return ret;
+	}
+    }
+
+    return SCM_NIL;
+}
+
+ScmObj ScmExp_or(ScmObj arg, ScmObj env)
+{
+    ScmObj obj = SCM_NIL;
+    ScmObj ret = SCM_NIL;
+
+    /* sanity check */
+    if (SCM_NULLP(arg))
+	return SCM_FALSE;
+    if (EQ(ScmOp_listp(arg), SCM_FALSE))
+	SigScm_Error("or : cannot evaluate improper list\n");
+
+    /* check recursively */
+    for (; !SCM_NULLP(arg); arg = SCM_CDR(arg)) {
+	obj = SCM_CAR(arg);
+	ret = ScmOp_eval(obj, env);
+	if (EQ(ret, SCM_TRUE))
+	    return SCM_TRUE;
+
+	/* return last item */
+	if (SCM_NULLP(SCM_CDR(arg))) {
+	    return ret;
+	}
+    }
+
+    return SCM_NIL;
+}
+
+/*===========================================================================
+  R5RS : 4.2 Derived expression types : 4.2.2 Binding constructs
+===========================================================================*/
+ScmObj ScmExp_let(ScmObj arg, ScmObj env)
+{
+    ScmObj bindings = SCM_NIL;
+    ScmObj body     = SCM_NIL;
+
+    /* sanity check */
+    if CHECK_2_ARGS(arg)
+	SigScm_Error("let : syntax error\n");
+
+    /* get bindings and body */
+    bindings = SCM_CAR(arg);
+    body     = SCM_CDR(arg);
+
+    /*========================================================================
+      (let <bindings> <body>)
+      <bindings> == ((<variable1> <init1>)
+                     (<variable2> <init2>)
+                     ...)
+    ========================================================================*/
+    if (SCM_CONSP(bindings)) {
+	ScmObj vars = SCM_NIL;
+	ScmObj vals = SCM_NIL;
+	ScmObj binding = SCM_NIL;
+	for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
+	    binding = SCM_CAR(bindings);
+	    vars = Scm_NewCons(SCM_CAR(binding), vars);
+	    vals = Scm_NewCons(ScmOp_eval(SCM_CAR(SCM_CDR(binding)), env), vals);
+	}
+
+	/* create new environment for */
+	env = extend_environment(vars, vals, env);
+
+	return ScmExp_begin(body, env);
+    }
+
+    return SCM_UNDEF;
+}
+
+/*===========================================================================
+  R5RS : 4.2 Derived expression types : 4.2.3 Sequencing
+===========================================================================*/
+ScmObj ScmExp_begin(ScmObj arg, ScmObj env)
+{
+    ScmObj exp = SCM_NIL;
+    ScmObj ret = SCM_NIL;
+
+    /* sanity check */
+    if (SCM_NULLP(arg))
+	return SCM_UNDEF;
+    if (EQ(ScmOp_listp(arg), SCM_FALSE))
+	SigScm_Error("begin : improper list\n");       	
+
+    /* eval recursively */
+    for (; !SCM_NULLP(arg); arg = SCM_CDR(arg)) {
+	exp = SCM_CAR(arg);
+	ret = ScmOp_eval(exp, env);
+
+	/* return last expression's result */
+	if (EQ(SCM_CDR(arg), SCM_NIL)) {
+	    return ret;
+	}
+    }
+
+    return SCM_UNDEF;
+}
+
+/*===========================================================================
+  R5RS : 4.2 Derived expression types : 4.2.4 Iteration
+===========================================================================*/
+ScmObj ScmExp_do(ScmObj arg, ScmObj env)
+{
+    /*
+    if (SCM_INT_VALUE(ScmOp_length(arg)) < 2)
+	SigScm_Error("do : syntax error\n");
+
+    // (do ((<variable1> <init1> <step1>)
+    //      (<variable2> <init2> <step2>)
+    //      ...)
+    //     (<test> <expression> ...)
+    //   <command> ...)
+
+    // Construct Environment and steps
+    ScmObj steps    = SCM_NIL;
+    ScmObj bindings = SCM_CAR(arg);
+    for (; !SCM_NULLP(bindings); bindings = SCM_CDR(bindings)) {
+	// TODO : creating new frame for each binding is heavy?
+	// may be able to optimize this process.
+	ScmObj binding = SCM_CAR(bindings);
+	ScmObj vars = Scm_NewCons(SCM_CAR(binding), SCM_NIL);
+	ScmObj vals = Scm_NewCons(ScmOp_eval(SCM_CAR(SCM_CDR(binding)), env), SCM_NIL);
+	env = extend_environment(vars, vals, env);
+
+	ScmObj step = SCM_CAR(SCM_CAR(SCM_CDR(binding)));
+	if (!SCM_NULLP(step)) {
+	    ScmOp_append(steps, step);
+	}
+    }
+
+    // Construct test
+    ScmObj testframe  = SCM_CAR(SCM_CDR(arg));
+    ScmObj test       = SCM_CAR(testframe);
+    ScmObj expression = SCM_CAR(SCM_CDR(testframe));
+
+    // Construct commands
+    ScmObj commands = SCM_CDR(SCM_CDR(arg));
+
+    SigScm_PrintScmObj(steps);
+    SigScm_PrintScmObj(env);
+    SigScm_PrintScmObj(test);
+    SigScm_PrintScmObj(expression);
+    SigScm_PrintScmObj(commands);
+
+
+    return SCM_NIL;
+    */
+
+    return SCM_NIL;
+}
+
+/*===========================================================================
+  R5RS : 4.2 Derived expression types : 4.2.5 Delayed evaluation
+===========================================================================*/
+ScmObj ScmOp_delay(ScmObj arg, ScmObj env)
+{
+    if (SCM_INT_VALUE(ScmOp_length(arg)) != 1)
+        SigScm_Error("delay : Wrong number of arguments\n");
+
+    /* closure exp = ( () SCM_CAR(arg) ) */
+    return Scm_NewClosure(Scm_NewCons(SCM_NIL, Scm_NewCons(SCM_CAR(arg), SCM_NIL)), env);
+}
+
+/*===========================================================================
+  R5RS : 4.2 Derived expression types : 4.2.6 Quasiquotation
+===========================================================================*/
+ScmObj ScmOp_quasiquote(ScmObj temp)
+{
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_unquote(ScmObj exp)
+{
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_unquote_splicint(ScmObj exp)
+{
+    return SCM_FALSE;
+}
+
+
+/*=======================================
+  R5RS : 5.2 Definitions
+=======================================*/
+ScmObj ScmExp_define(ScmObj arg, ScmObj env)
+{
+    ScmObj var     = SCM_CAR(arg);
+    ScmObj body    = SCM_CAR(SCM_CDR(arg));
+    ScmObj val     = SCM_NIL;
+    ScmObj formals = SCM_NIL;
+
+    /* sanity check */
+    if (SCM_NULLP(var))
+	SigScm_Error("define : syntax error\n");
+
+    /*========================================================================
+      (define <variable> <expression>)
+    ========================================================================*/
+    if (SCM_SYMBOLP(var)) {
+	if (SCM_NULLP(env)) {
+	    /* given NIL environment */
+	    SCM_SETSYMBOL_VCELL(var, ScmOp_eval(body, env));
+	} else {
+	    /* lookup environment */
+	    val = lookup_environment(var, env);
+
+	    if (!SCM_NULLP(val)) {
+		/* found in the environment. set the new variable in env. */
+		SCM_SETCAR(val, ScmOp_eval(body, env));
+	    } else {
+		/* add to environment (not create new frame) */
+		add_environment(var, ScmOp_eval(body, env), env);
+	    }
+	}
+
+	return var;
+    }
+
+    /*========================================================================
+      (define (<val> <formals>) <body>)
+
+      => (define <val>
+             (lambda (<formals>) <body>))
+
+      (define <val> <expression>)
+    ========================================================================*/
+    if (EQ(ScmOp_listp(var), SCM_TRUE)) {
+	val     = SCM_CAR(var);
+	formals = SCM_CDR(var);
+	if (!SCM_CONSP(formals))
+	    formals = Scm_NewCons(formals, SCM_NIL);
+
+	/* (val (lambda (formals) body))  */
+	return ScmExp_define(Scm_NewCons(val,
+					 Scm_NewCons(ScmExp_lambda(Scm_NewCons(formals,
+									       Scm_NewCons(body, SCM_NIL)),
+								   env),
+						     SCM_NIL)),
+			     env);
+    }
+
+    /*========================================================================
+      (define (<variable> . <formals>) <body>)
+      TODO : implement this
+    ========================================================================*/
+
+
+    return SCM_NIL;
+}
+
+/*=======================================
+  R5RS : 6.5 Eval
+=======================================*/
+ScmObj ScmOp_scheme_report_environment(ScmObj version)
+{
+    return SCM_NIL;
+}
+
+ScmObj ScmOp_null_environment(ScmObj version)
+{
+    return SCM_NIL;
+}

Added: branches/r5rs/sigscheme/h_template
===================================================================
--- branches/r5rs/sigscheme/h_template	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/h_template	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,67 @@
+/*===========================================================================
+ *  FileName : h.c
+ *  About    : 
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+#ifndef ___H
+#define ___H
+
+/*=======================================
+   System Include
+=======================================*/
+
+
+/*=======================================
+   Local Include
+=======================================*/
+
+
+/*=======================================
+   Struct Declarations
+=======================================*/
+
+
+/*=======================================
+   Variable Declarations
+=======================================*/
+
+
+/*=======================================
+   Macro Declarations
+=======================================*/
+
+
+/*=======================================
+   Function Declarations
+=======================================*/
+
+
+#endif /* ___H */

Added: branches/r5rs/sigscheme/io.c
===================================================================
--- branches/r5rs/sigscheme/io.c	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/io.c	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,456 @@
+/*===========================================================================
+ *  FileName : io.c
+ *  About    : io related functions
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+/*=======================================
+  System Include
+=======================================*/
+#include <stdio.h>
+
+/*=======================================
+  Local Include
+=======================================*/
+#include "sigscheme.h"
+
+/*=======================================
+  File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+  File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+  Variable Declarations
+=======================================*/
+
+/*=======================================
+  File Local Function Declarations
+=======================================*/
+ScmObj current_input_port  = NULL;
+ScmObj current_output_port = NULL;
+
+/*=======================================
+  Function Implementations
+=======================================*/
+/*=======================================
+  R5RS : 6.6 Input and Output
+=======================================*/
+/*===========================================================================
+  R5RS : 6.6 Input and Output : 6.6.1 Ports
+===========================================================================*/
+ScmObj ScmOp_call_with_input_file(ScmObj filepath, ScmObj proc)
+{
+    ScmObj port = SCM_NIL;
+    ScmObj ret  = SCM_NIL;
+
+    if (!SCM_STRINGP(filepath))
+	SigScm_Error("call-with-input-file : string required\n");
+    if (!SCM_FUNCP(proc) && !SCM_CLOSUREP(proc))
+	SigScm_Error("call-with-input-file : proc required\n");
+    
+    /* open port */
+    port = ScmOp_open_input_file(filepath);
+    
+    /* (eval '(proc port) '())*/
+    ret = ScmOp_eval(Scm_NewCons(proc, Scm_NewCons(port, SCM_NIL)), SCM_NIL);
+
+    /* close port */
+    ScmOp_close_input_port(port);
+
+    return ret;
+}
+
+ScmObj ScmOp_call_with_output_file(ScmObj filepath, ScmObj proc)
+{
+    ScmObj port = SCM_NIL;
+    ScmObj ret  = SCM_NIL;
+
+    if (!SCM_STRINGP(filepath))
+	SigScm_Error("call-with-output-file : string required\n");
+    if (!SCM_FUNCP(proc) && !SCM_CLOSUREP(proc))
+	SigScm_Error("call-with-output-file : proc required\n");
+    
+    /* open port */
+    port = ScmOp_open_output_file(filepath);
+    
+    /* (eval '(proc port) '())*/
+    ret = ScmOp_eval(Scm_NewCons(proc, Scm_NewCons(port, SCM_NIL)), SCM_NIL);
+
+    /* close port */
+    ScmOp_close_output_port(port);
+
+    return ret;
+}
+
+ScmObj ScmOp_input_portp(ScmObj obj)
+{
+    if (SCM_PORTP(obj) && SCM_PORT_PORTTYPE(obj) == PORT_INPUT)
+	return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_output_portp(ScmObj obj)
+{
+    if (SCM_PORTP(obj) && SCM_PORT_PORTTYPE(obj) == PORT_OUTPUT)
+	return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_current_input_port(void)
+{
+    return current_input_port;
+}
+
+ScmObj ScmOp_current_output_port(void)
+{
+    return current_output_port;
+}
+
+ScmObj ScmOp_with_input_from_file(ScmObj filepath, ScmObj thunk)
+{
+    ScmObj tmp_port = SCM_NIL;
+    ScmObj ret      = SCM_NIL;
+
+    if (!SCM_STRINGP(filepath))
+	SigScm_Error("with-input-from-file : string required\n");
+    if (!SCM_FUNCP(thunk) && !SCM_CLOSUREP(thunk))
+	SigScm_Error("with-input-from-file : proc required\n");
+    
+    /* set current_input_port */
+    tmp_port = current_input_port;
+    current_input_port = ScmOp_open_input_file(filepath);
+    
+    /* (eval '(thunk) '())*/
+    ret = ScmOp_eval(Scm_NewCons(thunk, SCM_NIL), SCM_NIL);
+
+    /* close port */
+    ScmOp_close_input_port(current_input_port);
+
+    /* restore current_input_port */
+    current_input_port = tmp_port;
+
+    return ret;
+}
+
+ScmObj ScmOp_with_output_to_file(ScmObj filepath, ScmObj thunk)
+{
+    ScmObj tmp_port = SCM_NIL;
+    ScmObj ret      = SCM_NIL;
+
+    if (!SCM_STRINGP(filepath))
+	SigScm_Error("with-output-to-file : string required\n");
+    if (!SCM_FUNCP(thunk) && !SCM_CLOSUREP(thunk))
+	SigScm_Error("with-output-to-file : proc required\n");
+    
+    /* set current_output_port */
+    tmp_port = current_output_port;
+    current_output_port = ScmOp_open_output_file(filepath);
+    
+    /* (eval '(thunk) '())*/
+    ret = ScmOp_eval(Scm_NewCons(thunk, SCM_NIL), SCM_NIL);
+
+    /* close port */
+    ScmOp_close_output_port(current_output_port);
+
+    /* restore current_output_port */
+    current_output_port = tmp_port;
+
+    return ret;
+}
+
+ScmObj ScmOp_open_input_file(ScmObj filepath)
+{
+    FILE *f = NULL;
+
+    if (!SCM_STRINGP(filepath))
+	SigScm_Error("open-input-file : string requred\n");
+
+    /* Open File */
+    f = fopen(SCM_STRING_STR(filepath), "r");
+    if (!f)
+        SigScm_Error("cannot open file.\n");
+
+    /* Allocate ScmPort */
+    return Scm_NewPort(f, PORT_INPUT);
+}
+
+ScmObj ScmOp_open_output_file(ScmObj filepath)
+{
+    FILE *f = NULL;
+
+    if (!SCM_STRINGP(filepath))
+	SigScm_Error("open-output-file : string requred\n");
+
+    /* Open File */
+    f = fopen(SCM_STRING_STR(filepath), "w");
+    if (!f) {
+        SigScm_Error("cannot open file.\n");
+    }
+
+    /* Return new ScmPort */
+    return Scm_NewPort(f, PORT_OUTPUT);
+}
+
+ScmObj ScmOp_close_input_port(ScmObj port)
+{
+    if (!SCM_PORTP(port))
+	SigScm_Error("close-input-port : port requred\n");
+
+    if (SCM_PORTINFO_FILE(port))
+	fclose(SCM_PORTINFO_FILE(port));
+
+    return SCM_UNDEF;
+}
+
+ScmObj ScmOp_close_output_port(ScmObj port)
+{
+    if (!SCM_PORTP(port))
+	SigScm_Error("close-output-port : port requred\n");
+    
+    if (SCM_PORTINFO_FILE(port))
+	fclose(SCM_PORTINFO_FILE(port));
+
+    return SCM_UNDEF;
+}
+
+/*===========================================================================
+  R5RS : 6.6 Input and Output : 6.6.2 Input
+===========================================================================*/
+ScmObj ScmOp_read(ScmObj arg, ScmObj env)
+{
+    ScmObj port = SCM_NIL;
+    if (SCM_NULLP(arg)) {
+	/* (read) */
+	port = current_input_port;
+    } else if (!SCM_NULLP(SCM_CDR(arg)) && SCM_PORTP(SCM_CAR(SCM_CDR(arg)))) {
+	/* (read port) */
+	port = SCM_CAR(SCM_CDR(arg));
+    } else {
+	SigScm_Error("read : invalid paramter\n");
+    }
+
+    return SigScm_Read(port);
+}
+
+ScmObj ScmOp_read_char(ScmObj arg, ScmObj env)
+{
+    ScmObj port = SCM_NIL;
+    if (SCM_NULLP(arg)) {
+	/* (read-char) */
+	port = current_input_port;
+    } else if (!SCM_NULLP(SCM_CDR(arg)) && SCM_PORTP(SCM_CAR(SCM_CDR(arg)))) {
+	/* (read-char port) */
+	port = SCM_CAR(SCM_CDR(arg));
+    } else {
+	SigScm_Error("read-char : invalid paramter\n");
+    }
+
+    return SigScm_Read_Char(port);
+}
+
+ScmObj ScmOp_peek_char(ScmObj arg, ScmObj env)
+{
+    /* TODO : implement this */
+}
+
+ScmObj ScmOp_eof_objectp(ScmObj obj)
+{
+    if(EQ(obj, SCM_EOF))
+	return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_char_readyp(ScmObj arg, ScmObj env)
+{
+    /* TODO : implement this */
+}
+
+/*===========================================================================
+  R5RS : 6.6 Input and Output : 6.6.3 Output
+===========================================================================*/
+
+/*
+ * TODO : implement this properly!!!
+ */
+ScmObj ScmOp_write(ScmObj arg, ScmObj env)
+{
+    ScmObj obj  = SCM_NIL;
+    ScmObj port = SCM_NIL;
+
+    if CHECK_1_ARG(arg)
+	SigScm_Error("write : invalid paramter\n");
+
+    /* get obj */
+    obj = SCM_CAR(arg);
+    arg = SCM_CDR(arg);
+
+    /* get port */
+    port = SCM_NIL;
+    if (SCM_NULLP(arg)) {
+	/* (write obj) */
+	port = current_input_port;
+    } else if (!SCM_NULLP(SCM_CDR(arg)) && SCM_PORTP(SCM_CAR(SCM_CDR(arg)))) {
+	/* (write obj port) */
+	port = SCM_CAR(SCM_CDR(arg));
+    } else {
+	SigScm_Error("write : invalid paramter\n");
+    }
+
+    SigScm_DisplayToPort(port, obj);
+    return SCM_UNDEF;
+}
+
+/*
+ * TODO : implement this properly!!!
+ */
+ScmObj ScmOp_display(ScmObj arg, ScmObj env)
+{
+    ScmObj obj  = SCM_NIL;
+    ScmObj port = SCM_NIL;
+
+    if CHECK_1_ARG(arg)
+	SigScm_Error("display : invalid paramter\n");
+
+    /* get obj */
+    obj = SCM_CAR(arg);
+    arg = SCM_CDR(arg);
+
+    /* get port */
+    port = SCM_NIL;
+    if (SCM_NULLP(arg)) {
+	/* (write obj) */
+	port = current_output_port;
+    } else if (!SCM_NULLP(SCM_CDR(arg)) && SCM_PORTP(SCM_CAR(SCM_CDR(arg)))) {
+	/* (write obj port) */
+	port = SCM_CAR(SCM_CDR(arg));
+    } else {
+	SigScm_Error("display : invalid paramter\n");
+    }
+
+    SigScm_DisplayToPort(port, obj);
+    return SCM_UNDEF;
+}
+
+ScmObj ScmOp_newline(ScmObj arg, ScmObj env)
+{
+    /* get port */
+    ScmObj port = SCM_NIL;
+    if (SCM_NULLP(arg)) {
+	/* (write obj) */
+	port = current_output_port;
+    } else if (!SCM_NULLP(SCM_CDR(arg)) && SCM_PORTP(SCM_CAR(SCM_CDR(arg)))) {
+	/* (write obj port) */
+	port = SCM_CAR(SCM_CDR(arg));
+    } else {
+	SigScm_Error("newline : invalid paramter\n");
+    }
+
+    fprintf(SCM_PORTINFO_FILE(port), "\n");
+    return SCM_UNDEF;
+}
+
+ScmObj ScmOp_write_char(ScmObj arg, ScmObj env)
+{
+    ScmObj obj  = SCM_NIL;
+    ScmObj port = SCM_NIL;
+
+    if CHECK_1_ARG(arg)
+	SigScm_Error("write-char : invalid paramter\n");
+
+    /* get obj */
+    obj = SCM_CAR(arg);
+    arg = SCM_CDR(arg);
+    if (!SCM_CHARP(obj))
+	SigScm_Error("write-char : char required\n");
+
+    /* get port */
+    port = SCM_NIL;
+    if (SCM_NULLP(arg)) {
+	/* (write obj) */
+	port = current_input_port;
+    } else if (!SCM_NULLP(SCM_CDR(arg)) && SCM_PORTP(SCM_CAR(SCM_CDR(arg)))) {
+	/* (write obj port) */
+	port = SCM_CAR(SCM_CDR(arg));
+    } else {
+	SigScm_Error("write : invalid paramter\n");
+    }
+
+    SigScm_DisplayToPort(port, obj);
+    return SCM_UNDEF;
+}
+
+/*===========================================================================
+  R5RS : 6.6 Input and Output : 6.6.4 System Interface
+===========================================================================*/
+ScmObj SigScm_load(char *c_filename)
+{
+    ScmObj stack_start;
+    ScmObj port         = SCM_NIL;
+    ScmObj s_expression = SCM_NIL;
+
+    /* set stack start */
+    stack_start_pointer = &stack_start;
+
+    /* open port */
+    port = ScmOp_open_input_file(Scm_NewString(c_filename));
+    s_expression = SCM_NIL;
+
+
+    /* read & eval cycle */
+    for (s_expression = SigScm_Read(port);
+	 !EQ(s_expression, SCM_EOF);
+	 s_expression = SigScm_Read(port))
+    {
+	ScmOp_eval(s_expression, SCM_NIL);
+    }
+
+    /* close port */
+    ScmOp_close_input_port(port);
+
+    stack_start_pointer = NULL;
+
+    return SCM_UNSPECIFIED;
+}
+
+ScmObj ScmOp_load(ScmObj filename)
+{
+    char *c_filename = SCM_STRING_STR(filename);
+    SigScm_load(c_filename);
+
+    /* TODO : investigate */
+    return SCM_NIL;
+}
+

Added: branches/r5rs/sigscheme/main.c
===================================================================
--- branches/r5rs/sigscheme/main.c	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/main.c	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,73 @@
+/*===========================================================================
+ *  FileName : main.c
+ *  About    : main function
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+/*=======================================
+  System Include
+=======================================*/
+
+/*=======================================
+  Local Include
+=======================================*/
+#include "sigscheme.h"
+
+/*=======================================
+  File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+  Variable Declarations
+=======================================*/
+
+/*=======================================
+  File Local Function Declarations
+=======================================*/
+
+/*=======================================
+  Function Implementations
+=======================================*/
+int main(int argc, char **argv)
+{
+    char *filename = argv[1];
+
+    if (argc < 2)
+	SigScm_Error("usage : sscm <filename>\n");
+
+    SigScm_Initialize();
+
+    SigScm_load(filename);
+
+    SigScm_Finalize();
+
+    return 0;
+}
+

Added: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/operations.c	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,1620 @@
+/*===========================================================================
+ *  FileName : operations.c
+ *  About    : basic scheme procedure
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+/*=======================================
+  System Include
+=======================================*/
+#include <string.h>
+
+/*=======================================
+  Local Include
+=======================================*/
+#include "sigscheme.h"
+
+/*=======================================
+  File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+  File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+  Variable Declarations
+=======================================*/
+
+/*=======================================
+  File Local Function Declarations
+=======================================*/
+static ScmObj list_gettail(ScmObj head);
+static ScmObj ScmOp_listtail_internal(ScmObj obj, int k);
+
+/*=======================================
+  Function Implementations
+=======================================*/
+/*==============================================================================
+  R5RS : 6.1 Equivalence predicates
+==============================================================================*/
+ScmObj ScmOp_eqvp(ScmObj obj1, ScmObj obj2)
+{
+    enum ScmObjType type = (enum ScmObjType)SCM_GETTYPE(obj1);
+
+    /* different type */
+    if (type != SCM_GETTYPE(obj2))
+        return SCM_FALSE;
+
+    /* same type */
+    switch (type) {
+        case ScmInt:
+            /* both numbers, are numerically equal */
+            if ((SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2)))
+            {
+                return SCM_TRUE;
+            }
+            break;
+        case ScmSymbol:
+            /* symbols which have same name */
+            if (strcmp(SCM_SYMBOL_NAME(obj1), SCM_SYMBOL_NAME(obj2)) == 0)
+            {
+                return SCM_TRUE;
+            }
+            break;
+        case ScmChar:
+            /* chars and are the same character according to the char=? */
+            if (EQ(ScmOp_char_equal(obj1, obj2), SCM_TRUE))
+            {
+                return SCM_TRUE;
+            }
+            break;
+        case ScmCons:
+        case ScmVector:
+        case ScmString:
+        case ScmFunc:
+        case ScmClosure:
+	case ScmPort:
+            if (EQ(obj1, obj2))
+            {
+                return SCM_TRUE;
+            }
+            break;
+        case ScmEtc:
+            /* obj1 and obj2 are both #t or both #f */
+            if (((EQ(obj1, SCM_TRUE) && EQ(obj2, SCM_TRUE)))
+                || (EQ(obj1, SCM_FALSE) && EQ(obj2, SCM_FALSE)))
+            {
+                return SCM_TRUE;
+            }
+            /* both obj1 and obj2 are the empty list */
+            if (SCM_NULLP(obj1) && SCM_NULLP(obj2))
+            {
+                return SCM_TRUE;
+            }
+            break;
+        case ScmFreeCell:
+            SigScm_Error("eqv? : cannnot compare freecell, gc broken?\n");
+            break;
+    }
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_eqp(ScmObj obj1, ScmObj obj2)
+{
+    return ScmOp_eqvp(obj1, obj2);
+}
+
+/*==============================================================================
+  R5RS : 6.2 Numbers
+==============================================================================*/
+ScmObj ScmOp_plus2n(ScmObj obj1, ScmObj obj2)
+{
+    if (!SCM_INTP(obj1) || !SCM_INTP(obj2))
+        SigScm_Error("+ : integer required\n");
+
+    return Scm_NewInt(SCM_INT_VALUE(obj1) + SCM_INT_VALUE(obj2));
+}
+
+ScmObj ScmOp_minus2n(ScmObj obj1, ScmObj obj2)
+{
+    if (!SCM_INTP(obj1) || !SCM_INTP(obj2))
+        SigScm_Error("- : integer required\n");
+
+    return Scm_NewInt(SCM_INT_VALUE(obj1) - SCM_INT_VALUE(obj2));
+}
+
+ScmObj ScmOp_multi2n(ScmObj obj1, ScmObj obj2)
+{
+    if (!SCM_INTP(obj1) || !SCM_INTP(obj2))
+        SigScm_Error("* : integer required\n");
+
+    return Scm_NewInt(SCM_INT_VALUE(obj1) * SCM_INT_VALUE(obj2));
+}
+
+ScmObj ScmOp_divide2n(ScmObj obj1, ScmObj obj2)
+{
+    if (!SCM_INTP(obj1) || !SCM_INTP(obj2))
+        SigScm_Error("/ : integer required\n");
+
+    if (EQ(ScmOp_zerop(obj2), SCM_TRUE))
+        SigScm_Error("/ : divide by zero\n");
+
+    return Scm_NewInt(SCM_INT_VALUE(obj1) / SCM_INT_VALUE(obj2));
+}
+
+ScmObj ScmOp_numberp(ScmObj obj)
+{
+    if (SCM_INTP(obj))
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_equal(ScmObj args, ScmObj env)
+{
+    int    val = 0;
+    ScmObj obj = SCM_NIL;
+
+    /* type check */
+    if (EQ(ScmOp_numberp(SCM_CAR(args)), SCM_FALSE))
+        SigScm_Error("= : number required\n");
+
+    /* arglen check */
+    if CHECK_2_ARGS(args)
+        SigScm_Error("= : Wrong number of arguments\n");
+
+    /* Get first value */
+    val = SCM_INT_VALUE(SCM_CAR(args));
+
+    /* compare following value */
+    for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
+        obj = SCM_CAR(args);
+        if (EQ(ScmOp_numberp(obj), SCM_FALSE))
+            SigScm_Error("number required\n");
+
+        if (SCM_INT_VALUE(obj) != val)
+        {
+            return SCM_FALSE;
+        }
+    }
+
+    return SCM_TRUE;
+}
+
+ScmObj ScmOp_bigger(ScmObj args, ScmObj env )
+{
+    int    val     = 0;
+    int    car_val = 0;
+    ScmObj obj     = SCM_NIL;
+
+    if (SCM_NULLP(args) || SCM_NULLP(SCM_CDR(args)))
+        SigScm_Error("< : Wrong number of arguments\n");
+
+    /* type check */
+    if (EQ(ScmOp_numberp(SCM_CAR(args)), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    /* Get first value */
+    val = SCM_INT_VALUE(SCM_CAR(args));
+
+    /* compare following value */
+    for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
+        obj = SCM_CAR(args);
+        if (EQ(ScmOp_numberp(obj), SCM_FALSE))
+            SigScm_Error("number required\n");
+
+        car_val = SCM_INT_VALUE(obj);
+        if (val < car_val)
+            val = car_val;
+        else
+            return SCM_FALSE;
+    }
+
+    return SCM_TRUE;
+}
+
+ScmObj ScmOp_smaller(ScmObj args, ScmObj env )
+{
+    int    val     = 0;
+    int    car_val = 0;
+    ScmObj obj     = SCM_NIL;
+
+    /* type check */
+    if (EQ(ScmOp_numberp(SCM_CAR(args)), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    /* arglen check */
+    if CHECK_2_ARGS(args)
+        SigScm_Error("> : Wrong number of arguments\n");
+
+    /* Get first value */
+    val = SCM_INT_VALUE(SCM_CAR(args));
+
+    /* compare following value */
+    for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
+        obj = SCM_CAR(args);
+        if (EQ(ScmOp_numberp(obj), SCM_FALSE))
+            SigScm_Error("number required\n");
+
+        car_val = SCM_INT_VALUE(obj);
+        if (val > car_val)
+            val = car_val;
+        else
+            return SCM_FALSE;
+    }
+
+    return SCM_TRUE;
+}
+
+ScmObj ScmOp_biggerEq(ScmObj args, ScmObj env )
+{
+    int    val     = 0;
+    int    car_val = 0;
+    ScmObj obj     = SCM_NIL;
+
+    /* type check */
+    if (EQ(ScmOp_numberp(SCM_CAR(args)), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    /* arglen check */
+    if CHECK_2_ARGS(args)
+        SigScm_Error("<= : Wrong number of arguments\n");
+
+    /* Get first value */
+    val = SCM_INT_VALUE(SCM_CAR(args));
+
+    /* compare following value */
+    obj = SCM_NIL;
+    for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
+        obj = SCM_CAR(args);
+        if (EQ(ScmOp_numberp(obj), SCM_FALSE))
+            SigScm_Error("number required\n");
+
+        car_val = SCM_INT_VALUE(obj);
+        if (val <= car_val)
+            val = car_val;
+        else
+            return SCM_FALSE;
+    }
+
+    return SCM_TRUE;
+}
+
+ScmObj ScmOp_smallerEq(ScmObj args, ScmObj env )
+{
+    int    val     = 0;
+    int    car_val = 0;
+    ScmObj obj     = SCM_NIL;
+
+    /* type check */
+    if (EQ(ScmOp_numberp(SCM_CAR(args)), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    /* arglen check */
+    if CHECK_2_ARGS(args)
+        SigScm_Error(">= : Wrong number of arguments\n");
+
+    /* Get first value */
+    val = SCM_INT_VALUE(SCM_CAR(args));
+
+    /* compare following value */
+    obj = SCM_NIL;
+    for (args = SCM_CDR(args); !SCM_NULLP(args); args = SCM_CDR(args)) {
+        obj = SCM_CAR(args);
+        if (EQ(ScmOp_numberp(obj), SCM_FALSE))
+            SigScm_Error("number required\n");
+
+        car_val = SCM_INT_VALUE(obj);
+        if (val >= car_val)
+            val = car_val;
+        else
+            return SCM_FALSE;
+    }
+
+    return SCM_TRUE;
+}
+
+ScmObj ScmOp_zerop(ScmObj scm_num)
+{
+    if (EQ(ScmOp_numberp(scm_num), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    if (SCM_INT_VALUE(scm_num) == 0)
+        return SCM_TRUE;
+    else
+        return SCM_FALSE;
+}
+
+ScmObj ScmOp_positivep(ScmObj scm_num)
+{
+    if (EQ(ScmOp_numberp(scm_num), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    if (SCM_INT_VALUE(scm_num) > 0)
+        return SCM_TRUE;
+    else
+        return SCM_FALSE;
+}
+
+ScmObj ScmOp_negativep(ScmObj scm_num)
+{
+    if (EQ(ScmOp_numberp(scm_num), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    if (SCM_INT_VALUE(scm_num) < 0)
+        return SCM_TRUE;
+    else
+        return SCM_FALSE;
+}
+
+ScmObj ScmOp_oddp(ScmObj scm_num)
+{
+    if (EQ(ScmOp_numberp(scm_num), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    if (SCM_INT_VALUE(scm_num) % 2 == 1)
+        return SCM_TRUE;
+    else
+        return SCM_FALSE;
+}
+
+ScmObj ScmOp_evenp(ScmObj scm_num)
+{
+    if (EQ(ScmOp_numberp(scm_num), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    if (SCM_INT_VALUE(scm_num) % 2 == 0)
+        return SCM_TRUE;
+    else
+        return SCM_FALSE;
+}
+
+ScmObj ScmOp_max(ScmObj args, ScmObj env )
+{
+    int    max     = 0;
+    int    car_val = 0;
+    ScmObj car     = SCM_NIL;
+
+    if (SCM_NULLP(args)) SigScm_Error("number required\n");
+
+    for (; !SCM_NULLP(args); args = SCM_CDR(args)) {
+        car = SCM_CAR(args);
+        if (EQ(ScmOp_numberp(car), SCM_FALSE))
+            SigScm_Error("number required\n");
+
+        car_val = SCM_INT_VALUE(SCM_CAR(args));
+        if (max < car_val)
+            max = car_val;
+    }
+
+    return Scm_NewInt(max);
+}
+
+ScmObj ScmOp_min(ScmObj args, ScmObj env )
+{
+    int    min     = 0;
+    int    car_val = 0;
+    ScmObj car     = SCM_NIL;
+
+    if (SCM_NULLP(args)) SigScm_Error("number required\n");
+
+    for (; !SCM_NULLP(args); args = SCM_CDR(args)) {
+        car = SCM_CAR(args);
+        if (EQ(ScmOp_numberp(car), SCM_FALSE))
+            SigScm_Error("number required\n");
+
+        car_val = SCM_INT_VALUE(SCM_CAR(args));
+        if (car_val < min)
+            min = car_val;
+    }
+
+    return Scm_NewInt(min);
+}
+
+
+ScmObj ScmOp_abs(ScmObj scm_num)
+{
+    int num = 0;
+
+    if (EQ(ScmOp_numberp(scm_num), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    num = SCM_INT_VALUE(scm_num);
+    if (0 < num)
+        return scm_num;
+
+    return Scm_NewInt(-num);
+}
+
+ScmObj ScmOp_quotient(ScmObj scm_n1, ScmObj scm_n2)
+{
+    int n1 = 0;
+    int n2 = 0;
+
+    if (EQ(ScmOp_numberp(scm_n1), SCM_FALSE)
+        || EQ(ScmOp_numberp(scm_n2), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    if (EQ(ScmOp_zerop(scm_n2), SCM_TRUE))
+        SigScm_Error("divide by zero\n");
+
+    n1 = SCM_INT_VALUE(scm_n1);
+    n2 = SCM_INT_VALUE(scm_n2);
+
+    return Scm_NewInt((int)(n1 / n2));
+}
+
+ScmObj ScmOp_modulo(ScmObj scm_n1, ScmObj scm_n2)
+{
+    int n1  = 0;
+    int n2  = 0;
+    int rem = 0;
+
+    if (EQ(ScmOp_numberp(scm_n1), SCM_FALSE)
+        || EQ(ScmOp_numberp(scm_n2), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    if (EQ(ScmOp_zerop(scm_n2), SCM_TRUE))
+        SigScm_Error("divide by zero\n");
+
+    n1 = SCM_INT_VALUE(scm_n1);
+    n2 = SCM_INT_VALUE(scm_n2);
+
+    rem  = n1 % n2;
+    if (n1 < 0 && n2 > 0) {
+        rem += n2;
+    } else if (n1 > 0 && n2 < 0) {
+        rem += n2;
+    }
+
+    return Scm_NewInt(rem);
+}
+
+ScmObj ScmOp_reminder(ScmObj scm_n1, ScmObj scm_n2)
+{
+    int n1  = 0;
+    int n2  = 0;
+
+    if (EQ(ScmOp_numberp(scm_n1), SCM_FALSE)
+        || EQ(ScmOp_numberp(scm_n2), SCM_FALSE))
+        SigScm_Error("number required\n");
+
+    if (EQ(ScmOp_zerop(scm_n2), SCM_TRUE))
+        SigScm_Error("divide by zero\n");
+
+    n1 = SCM_INT_VALUE(scm_n1);
+    n2 = SCM_INT_VALUE(scm_n2);
+
+    return Scm_NewInt(n1 % n2);
+}
+
+/*===================================
+  R5RS : 6.3 Other data types
+===================================*/
+/*==============================================================================
+  R5RS : 6.3 Other data types : 6.3.1 Booleans
+==============================================================================*/
+ScmObj ScmOp_not(ScmObj obj)
+{
+    if (EQ(obj, SCM_FALSE))
+        return SCM_TRUE;
+    else
+        return SCM_FALSE;
+}
+
+ScmObj ScmOp_booleanp(ScmObj obj)
+{
+    if (EQ(obj, SCM_FALSE) || EQ(obj, SCM_TRUE))
+        return SCM_TRUE;
+    else
+        return SCM_FALSE;
+}
+
+/*==============================================================================
+  R5RS : 6.3 Other data types : 6.3.2 Pairs and lists
+==============================================================================*/
+ScmObj ScmOp_car(ScmObj obj)
+{
+    if (SCM_NULLP(obj))
+        SigScm_Error("car error : empty list\n");
+    if (!SCM_CONSP(obj))
+        SigScm_Error("car error : not list\n");
+
+    return SCM_CAR(obj);
+}
+
+ScmObj ScmOp_cdr(ScmObj obj)
+{
+    if (SCM_NULLP(obj))
+        SigScm_Error("car error : empty list");
+    if (!SCM_CONSP(obj))
+        SigScm_Error("car error : not list\n");
+
+    return SCM_CDR(obj);
+}
+
+ScmObj ScmOp_pairp(ScmObj obj)
+{
+    if (SCM_CONSP(obj))
+        return SCM_TRUE;
+    else
+        return SCM_FALSE;
+}
+
+ScmObj ScmOp_cons(ScmObj car, ScmObj cdr)
+{
+    return Scm_NewCons(car, cdr);
+}
+
+ScmObj ScmOp_setcar(ScmObj pair, ScmObj car)
+{
+    if (SCM_CONSP(pair)) {
+        SCM_SETCAR(pair, car);
+    } else {
+        SigScm_Error("setcar error\n");
+    }
+
+    return SCM_UNSPECIFIED;
+}
+
+ScmObj ScmOp_setcdr(ScmObj pair, ScmObj cdr)
+{
+    if (SCM_CONSP(pair)) {
+        SCM_SETCDR(pair, cdr);
+    } else {
+        SigScm_Error("setcdr error\n");
+    }
+
+    return SCM_UNSPECIFIED;
+}
+
+ScmObj ScmOp_caar(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_car(pair) );
+}
+ScmObj ScmOp_cadr(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_cdr(pair) );
+}
+ScmObj ScmOp_cdar(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_car(pair) );
+}
+ScmObj ScmOp_cddr(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_cdr(pair) );
+}
+ScmObj ScmOp_caaar(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_car( ScmOp_car(pair) ));
+}
+ScmObj ScmOp_caadr(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_car( ScmOp_cdr(pair) ));
+}
+ScmObj ScmOp_cadar(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_cdr( ScmOp_car(pair) ));
+}
+ScmObj ScmOp_caddr(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_cdr( ScmOp_cdr(pair) ));
+}
+ScmObj ScmOp_cdaar(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_car( ScmOp_car(pair) ));
+}
+ScmObj ScmOp_cdadr(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_car( ScmOp_cdr(pair) ));
+}
+ScmObj ScmOp_cddar(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_cdr( ScmOp_car(pair) ));
+}
+ScmObj ScmOp_cdddr(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_cdr( ScmOp_cdr(pair) ));
+}
+ScmObj ScmOp_caaaar(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_car( ScmOp_car( ScmOp_car(pair) )));
+}
+ScmObj ScmOp_caaadr(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_car( ScmOp_car( ScmOp_cdr(pair) )));
+}
+ScmObj ScmOp_caadar(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_car( ScmOp_cdr( ScmOp_car(pair) )));
+}
+ScmObj ScmOp_caaddr(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_car( ScmOp_cdr( ScmOp_cdr(pair) )));
+}
+ScmObj ScmOp_cadaar(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_cdr( ScmOp_car( ScmOp_car(pair) )));
+}
+ScmObj ScmOp_cadadr(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_cdr( ScmOp_car( ScmOp_cdr(pair) )));
+}
+ScmObj ScmOp_caddar(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_cdr( ScmOp_cdr( ScmOp_car(pair) )));
+}
+ScmObj ScmOp_cadddr(ScmObj pair)
+{
+    return ScmOp_car( ScmOp_cdr( ScmOp_cdr( ScmOp_cdr(pair) )));
+}
+ScmObj ScmOp_cdaaar(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_car( ScmOp_car( ScmOp_car(pair) )));
+}
+ScmObj ScmOp_cdaadr(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_car( ScmOp_car( ScmOp_cdr(pair) )));
+}
+ScmObj ScmOp_cdadar(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_car( ScmOp_cdr( ScmOp_car(pair) )));
+}
+ScmObj ScmOp_cdaddr(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_car( ScmOp_cdr( ScmOp_cdr(pair) )));
+}
+ScmObj ScmOp_cddaar(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_cdr( ScmOp_car( ScmOp_car(pair) )));
+}
+ScmObj ScmOp_cddadr(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_cdr( ScmOp_car( ScmOp_cdr(pair) )));
+}
+ScmObj ScmOp_cdddar(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_cdr( ScmOp_cdr( ScmOp_car(pair) )));
+}
+ScmObj ScmOp_cddddr(ScmObj pair)
+{
+    return ScmOp_cdr( ScmOp_cdr( ScmOp_cdr( ScmOp_cdr(pair) )));
+}
+
+ScmObj ScmOp_list(ScmObj obj, ScmObj env )
+{
+    return obj;
+}
+
+ScmObj ScmOp_nullp(ScmObj obj)
+{
+    if (SCM_NULLP(obj))
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_listp(ScmObj obj)
+{
+    for (; !SCM_NULLP(obj); obj = SCM_CDR(obj)) {
+        /* check if valid list */
+        if (!SCM_CONSP(obj))
+            return SCM_FALSE;
+    }
+
+    return SCM_TRUE;
+}
+
+static ScmObj list_gettail(ScmObj head)
+{
+    ScmObj tail = head;
+
+    if (SCM_NULLP(head)) return SCM_NIL;
+
+    while (1) {
+        if (!SCM_CONSP(tail) || SCM_NULLP(SCM_CDR(tail)))
+            return tail;
+
+        tail = SCM_CDR(tail);
+    }
+
+    return SCM_NIL;
+}
+
+ScmObj ScmOp_length(ScmObj obj)
+{
+    int length = 0;
+    for (; !SCM_NULLP(obj); obj = SCM_CDR(obj)) {
+        /* check if valid list */
+        if (!SCM_NULLP(obj) && !SCM_CONSP(obj))
+            SigScm_Error("Bad List\n");
+
+        length++;
+    }
+
+    return Scm_NewInt(length);
+}
+
+ScmObj ScmOp_append(ScmObj head, ScmObj tail)
+{
+    ScmObj head_tail = SCM_NIL;
+
+    /* TODO : need to rewrite using ScmOp_listp? */
+    if (SCM_NULLP(head))
+        return tail;
+
+    if (!SCM_CONSP(head))
+        SigScm_Error("list required.\n");
+
+    head_tail = list_gettail(head);
+    if (SCM_NULLP(head_tail)) {
+        return tail;
+    } else if (SCM_CONSP(head_tail)) {
+        SCM_SETCDR(head_tail, tail);
+    } else {
+        SigScm_Error("list required\n");
+    }
+
+    return head;
+}
+
+ScmObj ScmOp_reverse(ScmObj list)
+{
+    ScmObj ret_list  = SCM_NIL;
+
+    if (EQ(ScmOp_listp(list), SCM_FALSE))
+        SigScm_Error("list required\n");
+
+    for (; !SCM_NULLP(list); list = SCM_CDR(list)) {
+        ret_list = Scm_NewCons(SCM_CAR(list), ret_list);
+    }
+
+    return ret_list;
+}
+
+/* TODO : not to use recursive call */
+ScmObj ScmOp_listtail_internal(ScmObj obj, int k)
+{
+    if (k == 0) {
+        return obj;
+    }
+
+    if (SCM_NULLP(obj))
+        SigScm_Error("already reached tail\n");
+
+    return ScmOp_listtail_internal(SCM_CDR(obj), k - 1);
+}
+
+ScmObj ScmOp_listtail(ScmObj list, ScmObj scm_k)
+{
+    if (EQ(ScmOp_listp(list), SCM_FALSE))
+        SigScm_Error("list required\n");
+    if (SCM_INTP(scm_k))
+        SigScm_Error("int required\n");
+
+    return ScmOp_listtail_internal(list, SCM_INT_VALUE(scm_k));
+}
+
+ScmObj ScmOp_listref(ScmObj list, ScmObj scm_k)
+{
+    ScmObj list_tail = SCM_NIL;
+
+    if (EQ(ScmOp_listp(list), SCM_FALSE))
+        SigScm_Error("list required\n");
+    if (SCM_INTP(scm_k))
+        SigScm_Error("int required\n");
+
+    list_tail = ScmOp_listtail_internal(list, SCM_INT_VALUE(scm_k));
+    if (SCM_NULLP(list_tail)) {
+        SigScm_Error("out of range\n");
+    }
+
+    return SCM_CAR(list_tail);
+}
+
+ScmObj ScmOp_memq(ScmObj obj, ScmObj list)
+{
+    ScmObj tmplist = SCM_NIL;
+    ScmObj tmpobj  = SCM_NIL;
+    for (tmplist = list; SCM_CONSP(tmplist); tmplist = SCM_CDR(tmplist)) {
+        tmpobj = SCM_CAR(tmplist);
+        if (EQ(ScmOp_eqp(obj, tmpobj), SCM_TRUE)) {
+            return tmplist;
+        }
+    }
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_memv(ScmObj obj, ScmObj list)
+{
+    ScmObj tmplist = SCM_NIL;
+    ScmObj tmpobj  = SCM_NIL;
+    for (tmplist = list; SCM_CONSP(tmplist); tmplist = SCM_CDR(tmplist)) {
+        tmpobj = SCM_CAR(tmplist);
+        if (EQ(ScmOp_eqvp(obj, tmpobj), SCM_TRUE)) {
+            return tmplist;
+        }
+    }
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_assq(ScmObj obj, ScmObj alist)
+{
+    ScmObj tmplist = SCM_NIL;
+    ScmObj tmpobj  = SCM_NIL;
+    for (tmplist = alist; SCM_CONSP(tmplist); tmplist = SCM_CDR(tmplist)) {
+        tmpobj = SCM_CAR(tmplist);
+        if (SCM_CONSP(tmpobj) && EQ(ScmOp_eqp(SCM_CAR(tmpobj), obj), SCM_TRUE))
+            return tmpobj;
+    }
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_assv(ScmObj obj, ScmObj alist)
+{
+    ScmObj tmplist = SCM_NIL;
+    ScmObj tmpobj  = SCM_NIL;
+    for (tmplist = alist; SCM_CONSP(tmplist); tmplist = SCM_CDR(tmplist)) {
+        tmpobj = SCM_CAR(tmplist);
+        if (SCM_CONSP(tmpobj) && EQ(ScmOp_eqvp(SCM_CAR(tmpobj), obj), SCM_TRUE))
+            return tmpobj;
+    }
+
+    return SCM_FALSE;
+}
+
+/*==============================================================================
+  R5RS : 6.3 Other data types : 6.3.3 Symbols
+==============================================================================*/
+ScmObj ScmOp_symbolp(ScmObj obj)
+{
+    if (SCM_SYMBOLP(obj))
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_boundp(ScmObj obj)
+{
+    if (SCM_SYMBOLP(obj)
+        && !SCM_EQ(SCM_SYMBOL_VCELL(obj), SCM_UNBOUND))
+    {
+        return SCM_TRUE;
+    }
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_symbol_to_string(ScmObj obj)
+{
+    int   size = 0;
+    char *name = NULL;
+
+    if (!SCM_SYMBOLP(obj))
+        return SCM_FALSE;
+
+    size = strlen(SCM_SYMBOL_NAME(obj));
+    name = (char*)malloc(sizeof(char) * size + 1);
+    strcpy(name, SCM_SYMBOL_NAME(obj));
+
+    return Scm_NewString(name);
+}
+
+ScmObj ScmOp_string_to_symbol(ScmObj str)
+{
+    char *name = NULL;
+
+    if(!SCM_STRINGP(str))
+        return SCM_FALSE;
+
+    name = (char*)alloca(strlen(SCM_STRING_STR(str)) + 1);
+    strcpy(name, SCM_STRING_STR(str));
+
+    return Scm_Intern(name);
+}
+
+/*==============================================================================
+  R5RS : 6.3 Other data types : 6.3.4 Characters
+==============================================================================*/
+ScmObj ScmOp_charp(ScmObj obj)
+{
+    if (SCM_CHARP(obj))
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_char_equal(ScmObj ch1, ScmObj ch2)
+{
+    if (!SCM_CHARP(ch1) || !SCM_CHARP(ch2))
+        SigScm_Error("char=? : char required\n");
+
+    if (strcmp(SCM_CHAR_CH(ch1), SCM_CHAR_CH(ch2)) == 0)
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_char_alphabeticp(ScmObj obj)
+{
+    if (!SCM_CHARP(obj))
+        SigScm_Error("char-alphabetic? : char required\n");
+
+    /* check multibyte */
+    if (strlen(SCM_CHAR_CH(obj)) != 1)
+        return SCM_FALSE;
+
+    /* check alphabet */
+    if (isalpha(SCM_CHAR_CH(obj)[0]) != 0)
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_char_numericp(ScmObj obj)
+{
+    if (!SCM_CHARP(obj))
+        SigScm_Error("char-alphabetic? : char required\n");
+
+    /* check multibyte */
+    if (strlen(SCM_CHAR_CH(obj)) != 1)
+        return SCM_FALSE;
+
+    /* check digit */
+    if (isdigit(SCM_CHAR_CH(obj)[0]) != 0)
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_char_whitespacep(ScmObj obj)
+{
+    if (!SCM_CHARP(obj))
+        SigScm_Error("char-alphabetic? : char required\n");
+
+    /* check multibyte */
+    if (strlen(SCM_CHAR_CH(obj)) != 1)
+        return SCM_FALSE;
+
+    /* check space */
+    if (isspace(SCM_CHAR_CH(obj)[0]) != 0)
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_char_upper_casep(ScmObj obj)
+{
+    if (!SCM_CHARP(obj))
+        SigScm_Error("char-alphabetic? : char required\n");
+
+    /* check multibyte */
+    if (strlen(SCM_CHAR_CH(obj)) != 1)
+        return SCM_FALSE;
+
+    /* check uppercase */
+    if (isupper(SCM_CHAR_CH(obj)[0]) != 0)
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_char_lower_casep(ScmObj obj)
+{
+    if (!SCM_CHARP(obj))
+        SigScm_Error("char-alphabetic? : char required\n");
+
+    /* check multibyte */
+    if (strlen(SCM_CHAR_CH(obj)) != 1)
+        return SCM_FALSE;
+
+    /* check lowercase */
+    if (islower(SCM_CHAR_CH(obj)[0]) != 0)
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+/*==============================================================================
+  R5RS : 6.3 Other data types : 6.3.5 Strings
+==============================================================================*/
+ScmObj ScmOp_stringp(ScmObj obj)
+{
+    if (SCM_STRINGP(obj))
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_make_string(ScmObj arg, ScmObj env)
+{
+    int argc = SCM_INT_VALUE(ScmOp_length(arg));
+    int len  = 0;
+    ScmObj str = SCM_NIL;
+    ScmObj ch  = SCM_NIL;
+
+    if (argc != 1 && argc != 2)
+        SigScm_Error("make-string : invalid use\n");
+    if (!SCM_INTP(SCM_CAR(arg)))
+        SigScm_Error("make-string : integer required\n");
+    if (argc == 2 && !SCM_CHARP(SCM_CAR(SCM_CDR(arg))))
+        SigScm_Error("make-string : character required\n");
+
+    len = SCM_INT_VALUE(SCM_CAR(arg));
+    if (argc == 1) {
+        return Scm_NewString_With_StrLen(NULL, len);
+    }
+
+    str = Scm_NewString_With_StrLen(NULL, len);
+    ch  = SCM_CAR(SCM_CDR(arg));
+    ScmOp_string_fill(str, ch);
+
+    return str;
+}
+
+ScmObj ScmOp_string(ScmObj arg, ScmObj env)
+{
+    return ScmOp_list_to_string(arg);
+}
+
+ScmObj ScmOp_string_length(ScmObj str)
+{
+    if (!SCM_STRINGP(str))
+        SigScm_Error("string-length : not string\n");
+
+    return Scm_NewInt(SigScm_default_encoding_strlen(SCM_STRING_STR(str)));
+}
+
+ScmObj ScmOp_string_ref(ScmObj str, ScmObj k)
+{
+    int   c_index = 0;
+    char *new_ch  = NULL;
+    const char *string_str   = NULL;
+    const char *ch_start_ptr = NULL;
+    const char *ch_end_ptr   = NULL;
+
+    if (!SCM_STRINGP(str))
+        SigScm_Error("string-ref : not string\n");
+    if (!SCM_INTP(k))
+        SigScm_Error("string-ref : not integer\n");
+
+    /* get start_ptr and end_ptr */
+    c_index = SCM_INT_VALUE(k);
+    string_str   = SCM_STRING_STR(str);
+    ch_start_ptr = SigScm_default_encoding_str_startpos(string_str, c_index);
+    ch_end_ptr   = SigScm_default_encoding_str_endpos(string_str, c_index);
+
+    /* copy from start_ptr to end_ptr */
+    new_ch = (char*)malloc(sizeof(char) * (ch_end_ptr - ch_start_ptr) + 1);
+    memset(new_ch, 0, sizeof(char) * (ch_end_ptr - ch_start_ptr) + 1);
+    strncpy(new_ch, ch_start_ptr, (ch_end_ptr - ch_start_ptr));
+
+    return Scm_NewChar(new_ch);
+}
+
+ScmObj ScmOp_string_set(ScmObj str, ScmObj k, ScmObj ch)
+{
+    int   c_start_index = 0;
+    int   front_size = 0;
+    int   newch_size = 0;
+    int   back_size  = 0;
+    int   total_size = 0;
+    char *new_str  = NULL;
+    const char *string_str   = NULL;
+    const char *ch_start_ptr = NULL;
+    const char *ch_end_ptr   = NULL;
+
+    if (!SCM_STRINGP(str))
+        SigScm_Error("string-set! : not string\n");
+    if (!SCM_INTP(k))
+        SigScm_Error("string-set! : not integer\n");
+    if (!SCM_CHARP(ch))
+        SigScm_Error("string-set! : not character\n");
+
+    /* get indexes */
+    c_start_index = SCM_INT_VALUE(k);
+    string_str    = SCM_STRING_STR(str);
+    ch_start_ptr  = SigScm_default_encoding_str_startpos(string_str, c_start_index);
+    ch_end_ptr    = SigScm_default_encoding_str_endpos(string_str, c_start_index);
+
+    /* calculate total size */
+    front_size = strlen(string_str) - strlen(ch_start_ptr);
+    newch_size = strlen(SCM_CHAR_CH(ch));
+    back_size  = strlen(ch_end_ptr);
+    total_size = front_size + newch_size + back_size;
+
+    /* copy each parts */
+    new_str = (char*)malloc(total_size + 1);
+    memset(new_str, 0, total_size + 1);
+    strncpy(new_str                           , string_str      , front_size);
+    strncpy(new_str + front_size              , SCM_CHAR_CH(ch) , newch_size);
+    strncpy(new_str + front_size + newch_size , ch_end_ptr      , back_size);
+
+    /* set */
+    if (SCM_STRING_STR(str))
+        free(SCM_STRING_STR(str));
+
+    SCM_SETSTRING_STR(str, new_str);
+
+    return SCM_UNSPECIFIED;
+}
+
+ScmObj ScmOp_string_equal(ScmObj str1, ScmObj str2)
+{
+    if (strcmp(SCM_STRING_STR(str1), SCM_STRING_STR(str2)) == 0)
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_string_substring(ScmObj str, ScmObj start, ScmObj end)
+{
+    int   c_start_index = 0;
+    int   c_end_index   = 0;
+    char *new_str  = NULL;
+    const char *string_str   = NULL;
+    const char *ch_start_ptr = NULL;
+    const char *ch_end_ptr   = NULL;
+
+    if (!SCM_STRINGP(str))
+        SigScm_Error("string-ref : not string\n");
+    if (!SCM_INTP(start) || !SCM_INTP(end))
+        SigScm_Error("string-ref : not integer\n");
+
+    /* get start_ptr and end_ptr */
+    c_start_index = SCM_INT_VALUE(start);
+    c_end_index   = SCM_INT_VALUE(end);
+    string_str    = SCM_STRING_STR(str);
+    ch_start_ptr  = SigScm_default_encoding_str_startpos(string_str, c_start_index);
+    ch_end_ptr    = SigScm_default_encoding_str_endpos(string_str, c_end_index);
+
+    /* copy from start_ptr to end_ptr */
+    new_str = (char*)malloc(sizeof(char) * (ch_end_ptr - ch_start_ptr) + 1);
+    memset(new_str, 0, sizeof(char) * (ch_end_ptr - ch_start_ptr) + 1);
+    strncpy(new_str, ch_start_ptr, sizeof(char) * (ch_end_ptr - ch_start_ptr));
+
+    return Scm_NewString(new_str);
+}
+
+ScmObj ScmOp_string_append(ScmObj arg, ScmObj env)
+{
+    int total_size = 0;
+    int total_len  = 0;
+    ScmObj strings = SCM_NIL;
+    ScmObj obj     = SCM_NIL;
+    char  *new_str = NULL;
+    char  *p       = NULL;
+
+    /* count total size of the new string */
+    for (strings = arg; !SCM_NULLP(strings); strings = SCM_CDR(strings)) {
+        obj = SCM_CAR(strings);
+        if (!SCM_STRINGP(obj))
+            SigScm_Error("string-append : list required\n");
+
+        total_size += strlen(SCM_STRING_STR(obj));
+        total_len  += SCM_STRING_LEN(obj);
+    }
+
+    /* allocate new string */
+    new_str = (char*)malloc(sizeof(char) * total_size + 1);
+
+    /* copy string by string */
+    p = new_str;
+    for (strings = arg; !SCM_NULLP(strings); strings = SCM_CDR(strings)) {
+        obj = SCM_CAR(strings);
+
+        strcpy(p, SCM_STRING_STR(obj));
+        p += strlen(SCM_STRING_STR(obj));
+    }
+
+    return Scm_NewString_With_StrLen(new_str, total_len);
+}
+
+ScmObj ScmOp_string_to_list(ScmObj string)
+{
+    char *string_str = NULL;
+    int   str_len    = 0;
+    ScmObj head = SCM_NIL;
+    ScmObj prev = NULL;
+    ScmObj next = NULL;
+    int i = 0;
+    const char *ch_start_ptr = NULL;
+    const char *ch_end_ptr   = NULL;
+    char *new_ch = NULL;
+
+    if (!SCM_STRINGP(string))
+        SigScm_Error("string->list : string required\n");
+
+    string_str = SCM_STRING_STR(string);
+    str_len    = SCM_STRING_LEN(string);
+    if (str_len == 0)
+        return SCM_NIL;
+
+    for (i = 0; i < str_len; i++) {
+        ch_start_ptr = SigScm_default_encoding_str_startpos(string_str, i);
+        ch_end_ptr   = SigScm_default_encoding_str_endpos(string_str, i);
+
+        new_ch = (char*)malloc(sizeof(char) * (ch_end_ptr - ch_start_ptr + 1));
+        memset(new_ch, 0, sizeof(char) * (ch_end_ptr - ch_start_ptr + 1));
+        strncpy(new_ch, ch_start_ptr, (sizeof(char) * (ch_end_ptr - ch_start_ptr)));
+
+        next = Scm_NewCons(Scm_NewChar(new_ch), SCM_NIL);
+        if (prev)
+            SCM_SETCDR(prev, next);
+        else
+            head = next;
+
+        prev = next;
+    }
+
+    return head;
+}
+
+ScmObj ScmOp_list_to_string(ScmObj list)
+{
+    int total_size = 0;
+    ScmObj chars   = SCM_NIL;
+    ScmObj obj     = SCM_NIL;
+    char  *new_str = NULL;
+    char  *p       = NULL;
+
+    if (EQ(ScmOp_listp(list), SCM_FALSE))
+        SigScm_Error("list->string : list required\n");
+
+    /* count total size of the string */
+    for (chars = list; !SCM_NULLP(chars); chars = SCM_CDR(chars)) {
+        obj = SCM_CAR(chars);
+        if (!SCM_CHARP(obj))
+            SigScm_Error("list->string : char required\n");
+
+        total_size += strlen(SCM_CHAR_CH(obj));
+    }
+
+    /* allocate new string */
+    new_str = (char*)malloc(sizeof(char) * total_size + 1);
+
+    /* copy char by char */
+    p = new_str;
+    for (chars = list; !SCM_NULLP(chars); chars = SCM_CDR(chars)) {
+        obj = SCM_CAR(chars);
+
+        strcpy(p, SCM_CHAR_CH(obj));
+        p += strlen(SCM_CHAR_CH(obj));
+    }
+
+    return Scm_NewString(new_str);
+}
+
+ScmObj ScmOp_string_copy(ScmObj string)
+{
+    char *orig_str = NULL;
+    char *dest_str = NULL;
+
+    if (!SCM_STRINGP(string))
+        SigScm_Error("string-copy : string required\n");
+
+    orig_str = SCM_STRING_STR(string);
+    dest_str = (char*)malloc(sizeof(char) * (strlen(orig_str) + 1));
+    strcpy(dest_str, orig_str);
+
+    return Scm_NewString(dest_str);
+}
+
+ScmObj ScmOp_string_fill(ScmObj string, ScmObj ch)
+{
+    int  char_size = 0;
+    int  str_len   = 0;
+    char *new_str  = NULL;
+    char *p        = NULL;
+    int   i        = 0;
+
+    if (!SCM_STRINGP(string))
+        SigScm_Error("string-fill! : string required\n");
+    if (!SCM_CHARP(ch))
+        SigScm_Error("string-fill! : character required\n");
+
+    /* create new str */
+    char_size = strlen(SCM_CHAR_CH(ch));
+    str_len   = SCM_STRING_LEN(string);
+    new_str   = (char*)realloc(SCM_STRING_STR(string), sizeof(char) * str_len * char_size + 1);
+    for (i = 0, p = new_str; i < char_size * str_len;) {
+        strcpy(p, SCM_CHAR_CH(ch));
+
+        p += char_size;
+        i += char_size;
+    }
+
+    SCM_SETSTRING_STR(string, new_str);
+
+    return SCM_UNSPECIFIED;
+}
+
+/*==============================================================================
+  R5RS : 6.3 Other data types : 6.3.6 Vectors
+==============================================================================*/
+ScmObj ScmOp_vectorp(ScmObj obj)
+{
+    if (SCM_VECTORP(obj))
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_make_vector(ScmObj arg, ScmObj env )
+{
+    ScmObj *vec   = NULL;
+    ScmObj  scm_k = SCM_CAR(arg);
+    ScmObj  fill  = SCM_NIL;
+    int c_k = 0;
+    int i   = 0;
+
+    if (!SCM_INTP(scm_k))
+        SigScm_Error("make-vector : integer required\n");
+
+    /* allocate vector */
+    c_k = SCM_INT_VALUE(scm_k);
+    vec = (ScmObj*)malloc(sizeof(ScmObj) * c_k);
+
+    /* fill vector */
+    fill = SCM_UNSPECIFIED;
+    if (!SCM_NULLP(SCM_CDR(arg)) && !SCM_NULLP(SCM_CAR(SCM_CDR(arg))))
+        fill = SCM_CAR(SCM_CDR(arg));
+
+    for (i = 0; i < c_k; i++) {
+        vec[i] = fill;
+    }
+
+    return Scm_NewVector(vec, scm_k);
+}
+
+ScmObj ScmOp_vector(ScmObj arg, ScmObj env )
+{
+    ScmObj scm_len = ScmOp_length(arg);
+    int c_len      = SCM_INT_VALUE(scm_len);
+    ScmObj *vec    = (ScmObj*)malloc(sizeof(ScmObj) * c_len); /* allocate vector */
+
+    /* set item */
+    int i = 0;
+    for (i = 0; i < c_len; i++) {
+        vec[i] = SCM_CAR(arg);
+        arg = SCM_CDR(arg);
+    }
+
+    return Scm_NewVector(vec, scm_len);
+}
+
+ScmObj ScmOp_vector_length(ScmObj vec)
+{
+    if (!SCM_VECTORP(vec))
+        SigScm_Error("vector-length : vector required\n");
+
+    return SCM_VECTOR_LEN(vec);
+}
+
+ScmObj ScmOp_vector_ref(ScmObj vec, ScmObj scm_k)
+{
+    if (!SCM_VECTORP(vec))
+        SigScm_Error("vector-ref : vector required\n");
+    if (!SCM_INTP(scm_k))
+        SigScm_Error("vector-ref : int required\n");
+
+    return SCM_VECTOR_REF(vec, scm_k);
+}
+
+ScmObj ScmOp_vector_set(ScmObj vec, ScmObj scm_k, ScmObj obj)
+{
+    if (!SCM_VECTORP(vec))
+        SigScm_Error("vector-set! : vector required\n");
+    if (!SCM_INTP(scm_k))
+        SigScm_Error("vector-set! : int required\n");
+
+    SCM_SETVECTOR_REF(vec, scm_k, obj);
+
+    return SCM_UNSPECIFIED;
+}
+
+ScmObj ScmOp_vector_to_list(ScmObj vec)
+{
+    ScmObj *v    = NULL;
+    ScmObj  prev = NULL;
+    ScmObj  next = NULL;
+    ScmObj  head = NULL;
+    int c_len = 0;
+    int i = 0;
+
+    if (!SCM_VECTORP(vec))
+        SigScm_Error("vector->list : vector required\n");
+
+    v = SCM_VECTOR_VEC(vec);
+    c_len = SCM_INT_VALUE(SCM_VECTOR_LEN(vec));
+    if (c_len == 0)
+        return SCM_NIL;
+
+    for (i = 0; i < c_len; i++) {
+        next = Scm_NewCons(v[i], SCM_NIL);
+
+        if (prev) {
+            SCM_SETCDR(prev, next);
+        } else {
+            head = next;
+        }
+
+        prev = next;
+    }
+
+    return head;
+}
+
+ScmObj ScmOp_list_to_vector(ScmObj list)
+{
+    ScmObj  scm_len = SCM_NIL;
+    ScmObj *v       = NULL;
+    int c_len = 0;
+    int i = 0;
+
+    /* TOOD : canbe optimized. scanning list many times */
+    if (EQ(ScmOp_listp(list), SCM_FALSE))
+        SigScm_Error("list->vector : list required\n");
+
+    scm_len = ScmOp_length(list);
+    c_len   = SCM_INT_VALUE(scm_len);
+    v       = (ScmObj*)malloc(sizeof(ScmObj) * c_len);
+    for (i = 0; i < c_len; i++) {
+        v[i] = SCM_CAR(list);
+        list = SCM_CDR(list);
+    }
+
+    return Scm_NewVector(v, scm_len);
+}
+
+ScmObj ScmOp_vector_fill(ScmObj vec, ScmObj fill)
+{
+    int c_len = 0;
+    int i = 0;
+
+    if (!SCM_VECTORP(vec))
+        SigScm_Error("vector->list : vector required\n");
+
+    c_len = SCM_INT_VALUE(SCM_VECTOR_LEN(vec));
+    for (i = 0; i < c_len; i++) {
+        SCM_VECTOR_VEC(vec)[i] = fill;
+    }
+
+    return SCM_UNSPECIFIED;
+}
+
+/*=======================================
+  R5RS : 6.4 Control Features
+=======================================*/
+ScmObj ScmOp_procedurep(ScmObj obj)
+{
+    if (SCM_FUNCP(obj) || SCM_CLOSUREP(obj))
+        return SCM_TRUE;
+
+    return SCM_FALSE;
+}
+
+ScmObj ScmOp_map(ScmObj map_arg, ScmObj env)
+{
+    int arg_len = SCM_INT_VALUE(ScmOp_length(map_arg));
+    ScmObj proc = SCM_CAR(map_arg);
+    ScmObj args = SCM_NIL;
+    ScmObj ret  = SCM_NIL;
+    ScmObj tmp  = SCM_NIL;
+
+    ScmObj arg_vector = SCM_NIL;
+    ScmObj arg1       = SCM_NIL;
+    int vector_len = 0;
+    int i = 0;
+
+    /* arglen check */
+    if (arg_len < 2)
+        SigScm_Error("map : Wrong number of arguments\n");
+
+
+    /* 1proc and 1arg case */
+    if (arg_len == 2) {
+        /* apply func to each item */
+        for (args = SCM_CAR(SCM_CDR(map_arg)); !SCM_NULLP(args); args = SCM_CDR(args)) {
+            /* create proc's arg */
+            tmp = SCM_CAR(args);
+            if (!SCM_CONSP(tmp)) {
+                /* arg must be the list */
+                tmp = Scm_NewCons(tmp, SCM_NIL);
+            }
+
+            /* create list for "apply" op */
+            tmp = Scm_NewCons(proc,
+                              Scm_NewCons(tmp,
+                                          SCM_NIL));
+
+            /* apply proc */
+            ret = Scm_NewCons(ScmOp_apply(tmp, env), ret);
+        }
+        return ScmOp_reverse(ret);
+    }
+
+    /* 1proc and many args case */
+    arg_vector = ScmOp_list_to_vector(SCM_CDR(map_arg));
+    vector_len = SCM_INT_VALUE(SCM_VECTOR_LEN(arg_vector));
+    while (1) {
+        /* create arg */
+        arg1 = SCM_NIL;
+        for (i = 0; i < vector_len; i++) {
+            tmp  = SCM_VECTOR_CREF(arg_vector, i);
+            /* check if we can continue next loop */
+            if (SCM_NULLP(tmp)) {
+                /* if next item is SCM_NIL, let's return! */
+                return ScmOp_reverse(ret);
+            }
+
+            arg1 = Scm_NewCons(SCM_CAR(tmp), arg1);
+            SCM_SETVECTOR_CREF(arg_vector, i, SCM_CDR(tmp));
+        }
+
+        /* reverse arg */
+        arg1 = ScmOp_reverse(arg1);
+
+        /* apply proc to arg1 */
+        ret = Scm_NewCons(ScmOp_apply(Scm_NewCons(proc,
+                                                  Scm_NewCons(arg1,
+                                                              SCM_NIL)),
+                                      env),
+                          ret);
+    }
+
+    /* never reaches here */
+    SigScm_Error("map bug?\n");
+    return SCM_NIL;
+}
+
+ScmObj ScmOp_for_each(ScmObj arg, ScmObj env)
+{
+    ScmOp_map(arg, env);
+
+    return SCM_UNSPECIFIED;
+}
+
+ScmObj ScmOp_force(ScmObj arg, ScmObj env)
+{
+    if (SCM_INT_VALUE(ScmOp_length(arg)) != 1)
+        SigScm_Error("force : Wrong number of arguments\n");
+    if (!SCM_CLOSUREP(SCM_CAR(arg)))
+        SigScm_Error("force : not proper delayed object\n");
+
+    /* evaluated exp = ( SCM_CAR(arg) ) */
+    return ScmOp_eval(Scm_NewCons(SCM_CAR(arg), SCM_NIL), env);
+}
+

Added: branches/r5rs/sigscheme/read.c
===================================================================
--- branches/r5rs/sigscheme/read.c	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/read.c	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,464 @@
+/*===========================================================================
+ *  FileName : read.c
+ *  About    : S-Expression reader
+ *
+ *  Copyright (C) 2000-2001 by Shiro Kawai (shiro at acm.org)
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+/*=======================================
+  System Include
+=======================================*/
+#include <ctype.h>
+#include <stdlib.h>
+#include <string.h>
+
+/*=======================================
+  Local Include
+=======================================*/
+#include "sigscheme.h"
+
+/*=======================================
+  File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+  File Local Macro Declarations
+=======================================*/
+#define SCM_PORT_GETC(port, c) 				\
+    do {						\
+	if (SCM_PORTINFO_UNGOTTENCHAR(port)) {		\
+	    c = SCM_PORTINFO_UNGOTTENCHAR(port);	\
+	    SCM_PORTINFO_UNGOTTENCHAR(port) = 0;	\
+	} else {					\
+	    c = getc(SCM_PORTINFO_FILE(port));		\
+	    SCM_PORTINFO_UNGOTTENCHAR(port) = 0;	\
+	}						\
+    } while (0);
+
+#define SCM_PORT_UNGETC(port,c )	\
+    SCM_PORTINFO_UNGOTTENCHAR(port) = c;
+
+/*=======================================
+  Variable Declarations
+=======================================*/
+
+/*=======================================
+  File Local Function Declarations
+=======================================*/
+static int    skip_comment_and_space(ScmObj port);
+static char*  read_char_sequence(ScmObj port);
+
+static ScmObj read_sexpression(ScmObj port);
+static ScmObj read_list(ScmObj port, int closeParen);
+static ScmObj read_char(ScmObj port);
+static ScmObj read_string(ScmObj port);
+static ScmObj read_symbol(ScmObj port);
+static ScmObj read_number_or_symbol(ScmObj port);
+static ScmObj read_quote(ScmObj port, ScmObj quoter);
+
+/*=======================================
+  Function Implementations
+=======================================*/
+/*===========================================================================
+  S-Expression Parser
+===========================================================================*/
+ScmObj SigScm_Read(ScmObj port)
+{
+    if (!SCM_PORTP(port))
+        SigScm_Error("invalid port\n");
+
+    return read_sexpression(port);
+}
+
+ScmObj SigScm_Read_Char(ScmObj port)
+{
+    if (!SCM_PORTP(port))
+        SigScm_Error("invalid port\n");
+
+    return read_char(port);
+}
+
+
+static int skip_comment_and_space(ScmObj port)
+{
+    int c = 0;
+    while (1) {
+	SCM_PORT_GETC(port, c);
+        if (c == EOF) {
+            return c;
+        } else if(c == ';') {
+            while (1) {
+		SCM_PORT_GETC(port, c);
+                if (c == '\n') break;
+                if (c == EOF ) return c;
+            }
+            continue;
+        } else if(isspace(c)) {
+            continue;
+        }
+
+        return c;
+    }
+}
+
+static ScmObj read_sexpression(ScmObj port)
+{
+#if DEBUG_PARSER
+    printf("read_sexpression\n");
+#endif
+
+    int c  = 0;
+    int c1 = 0;
+    while (1) {
+        c = skip_comment_and_space(port);
+
+#if DEBUG_PARSER
+        printf("read_sexpression c = %c\n", c);
+#endif
+
+        switch (c) {
+            case '(':
+                return read_list(port, ')');
+            case '\"':
+                return read_string(port);
+            case '0': case '1': case '2': case '3': case '4':
+            case '5': case '6': case '7': case '8': case '9':
+		SCM_PORT_UNGETC(port, c);
+                return read_number_or_symbol(port);
+	    case '+': case '-':
+                SCM_PORT_UNGETC(port, c);
+                return read_number_or_symbol(port);
+            case '\'':
+                return read_quote(port, SCM_QUOTE);
+	    case '`':
+		return read_quote(port, SCM_QUASIQUOTE);
+	    case ',':
+		{
+		    SCM_PORT_GETC(port, c1);
+		    if (c1 == EOF) {
+			SigScm_Error("eof in unquote\n");
+		    } else if (c1 == '@') {
+			return read_quote(port, SCM_UNQUOTE_SPLICING);
+		    } else {
+			SCM_PORT_UNGETC(port, c1);
+			return read_quote(port, SCM_UNQUOTE);
+		    }
+		}
+            case '#':
+                {
+		    SCM_PORT_GETC(port, c1);
+                    switch (c1) {
+                        case 't': case 'T':
+                            return SCM_TRUE;
+                        case 'f': case 'F':
+                            return SCM_FALSE;
+			case '(':
+			    return ScmOp_list_to_vector(read_list(port, ')'));
+			case '\\':
+			    return read_char(port);
+                        case EOF:
+                            SigScm_Error("end in #\n");
+                        default:
+                            SigScm_Error("Unsupported #\n");
+                    }
+                }
+		break;
+
+	    /* Error sequence */
+            case ')':
+                SigScm_Error("invalid close parenthesis\n");
+                break;
+            case EOF:
+                return SCM_EOF;
+
+            default:
+                SCM_PORT_UNGETC(port, c);
+                return read_symbol(port);
+        }
+    }
+}
+
+static ScmObj read_list(ScmObj port, int closeParen)
+{
+#if DEBUG_PARSER
+    printf("read_list\n");
+#endif
+
+    ScmObj list_head = SCM_NIL;
+    ScmObj list_tail = SCM_NIL;
+    ScmObj item = SCM_NIL;
+
+    int c = 0;
+    while (1) {
+        c = skip_comment_and_space(port);
+
+#if DEBUG_PARSER
+        printf("read_list c = [%c]\n", c);
+#endif
+
+        if (c == EOF) {
+            SigScm_Error("EOF inside list.\n");
+        } else if (c == closeParen) {
+            return list_head;
+        } else if (c == '.') {
+	    int c2 = 0;
+	    SCM_PORT_GETC(port, c2);
+#if DEBUG_PARSER
+        printf("read_list process_dot c2 = [%c]\n", c2);
+#endif
+            if (isspace(c2)) {
+                ScmObj cdr = read_sexpression(port);
+                if (SCM_NULLP(list_tail))
+                    SigScm_Error(".(dot) at the start of the list.\n");
+
+		c = skip_comment_and_space(port);
+		if (c != ')')
+		    SigScm_Error("bad dot syntax\n");
+
+                SCM_SETCDR(list_tail, cdr);
+		return list_tail;
+            }
+        } else {
+            SCM_PORT_UNGETC(port, c);
+            item = read_sexpression(port);
+        }
+
+        /* Append item to the list_tail. */
+        if (SCM_NULLP(list_tail)) {
+            /* create new list */
+            list_head = Scm_NewCons(item, SCM_NIL);
+            list_tail = list_head;
+        } else {
+            /* update list_tail */
+            SCM_SETCDR(list_tail, Scm_NewCons(item, SCM_NIL));
+            list_tail = SCM_CDR(list_tail);
+        }
+    }
+}
+
+static ScmObj read_char(ScmObj port)
+{
+#if DEBUG_PARSER
+    printf("read_char\n");
+#endif
+   
+    char *ch = read_char_sequence(port);
+
+#if DEBUG_PARSER
+    printf("ch = %s\n", ch);
+#endif
+
+    /* check special sequence "space" and "newline" */
+    if (strcmp(ch, "space") == 0) {
+	ch[0] = ' ';
+	ch[1] = '\0';
+    } else if (strcmp(ch, "newline") == 0) {
+	ch[0] = '\n';
+	ch[1] = '\0';
+    }
+
+    return Scm_NewChar(ch);
+}
+
+static ScmObj read_string(ScmObj port)
+{
+    char  stringbuf[1024];
+    int   stringlen = 0;
+    char *dst = NULL;
+    int   c = 0;
+
+#if DEBUG_PARSER
+    printf("read_string\n");
+#endif
+
+    while (1) {
+	SCM_PORT_GETC(port, c);
+
+#if DEBUG_PARSER
+        printf("read_string c = %c\n", c);
+#endif
+
+        switch (c) {
+            case EOF:
+                SigScm_Error("EOF in the string\n");
+                break;
+            case '\"':
+                {
+                    stringbuf[stringlen] = '\0';
+                    dst = (char *)malloc(strlen(stringbuf) + 1);
+                    strcpy(dst, stringbuf);
+                    return Scm_NewString(dst);
+                }
+            case '\\':
+                {
+		    /*
+		     * (R5RS) 6.3.5 String
+		     * A double quote can be written inside a string only by
+		     * escaping it with a backslash (\).
+		     */
+		    SCM_PORT_GETC(port, c);
+		    switch (c) {
+			case '\"':
+			    stringbuf[stringlen] = c;
+			    break;
+			case 'n':
+			    stringbuf[stringlen] = '\n';
+			    break;
+			case 't':
+			    stringbuf[stringlen] = '\t';
+			    break;
+			default:
+			    stringbuf[stringlen] = '\\';
+			    stringbuf[++stringlen] = c;
+			    break;			    
+		    }
+		    stringlen++;
+
+#if DEBUG_PARSER
+		    printf("read_string following \\ : c = %c\n", c);
+#endif
+                }
+		break;
+            default:
+                stringbuf[stringlen] = c;
+                stringlen++;
+                break;
+        }
+    }
+}
+
+static ScmObj read_symbol(ScmObj port)
+{
+    char  *sym_name = read_char_sequence(port);
+    ScmObj sym = Scm_Intern(sym_name);
+    free(sym_name);
+
+#if DEBUG_PARSER
+    printf("read_symbol\n");
+#endif
+
+    return sym;
+}
+
+static ScmObj read_number_or_symbol(ScmObj port)
+{
+    int i = 0;
+    int is_str  = 0;
+    int str_len = 0;
+    char  *str = NULL;
+    ScmObj obj = SCM_NIL;
+
+#if DEBUG_PARSER
+    printf("read_number_or_symbol\n");
+#endif
+
+    /* read char sequence */
+    str = read_char_sequence(port);
+    if (strlen(str) == 1
+	&& (strcmp(str, "+") == 0 || strcmp(str, "-") == 0))
+    {
+#if DEBUG_PARSER
+	printf("determined as symbol : %s\n", str);
+#endif
+
+	obj = Scm_Intern(str);
+	free(str);
+	return obj;
+    }
+
+    /* check whether each char is the digit */
+    for (i = 0; i < str_len; i++) {
+	if (i == 0 && (str[i] == '+' || str[i] == '-'))
+	    continue;
+
+	if (!isdigit(str[i])) {
+	    is_str = 1;
+	    break;
+	}
+    }
+
+    /* if symbol, then intern it. if number, return new int obj */
+    if (is_str) {
+#if DEBUG_PARSER
+	printf("determined as symbol : %s\n", str);
+#endif
+	obj = Scm_Intern(str);
+    } else {
+#if DEBUG_PARSER
+	printf("determined as num : %s\n", str);
+#endif
+	obj = Scm_NewInt((int)atof(str));
+    }
+    free(str);
+
+    return obj;
+}
+
+
+static char *read_char_sequence(ScmObj port)
+{
+    char  stringbuf[1024];
+    int   stringlen = 0;
+    int   c = 0;
+    char *dst = NULL;
+
+    while (1) {
+	SCM_PORT_GETC(port, c);
+
+#if DEBUG_PARSER
+	printf("c = %c\n", c);
+#endif
+
+        switch (c) {
+            case EOF:
+                SigScm_Error("EOF in the char sequence.\n");
+                break;
+
+            case '(':  case ')':  case ' ':  case ';':
+            case '\n': case '\t': case '\"': case '\'':
+                SCM_PORT_UNGETC(port, c);
+                stringbuf[stringlen] = '\0';
+		dst = (char *)malloc(strlen(stringbuf) + 1);
+                strcpy(dst, stringbuf);
+                return dst;
+
+            default:
+                stringbuf[stringlen] = (char)c;
+                stringlen++;
+                break;
+        }
+    }
+}
+
+static ScmObj read_quote(ScmObj port, ScmObj quoter)
+{
+    return Scm_NewCons(quoter, read_sexpression(port));
+}
+

Added: branches/r5rs/sigscheme/runbench.sh
===================================================================
--- branches/r5rs/sigscheme/runbench.sh	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/runbench.sh	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,7 @@
+#!/bin/sh
+
+for bench in bench/bench-*.scm
+do
+  echo "Running benchmark $bench..."
+  time ./sscm $bench
+done


Property changes on: branches/r5rs/sigscheme/runbench.sh
___________________________________________________________________
Name: svn:executable
   + *

Added: branches/r5rs/sigscheme/runtest.sh
===================================================================
--- branches/r5rs/sigscheme/runtest.sh	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/runtest.sh	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,7 @@
+#!/bin/sh
+
+for test in test/test-*.scm
+do
+  echo "Running test $test..."
+  ./sscm $test
+done


Property changes on: branches/r5rs/sigscheme/runtest.sh
___________________________________________________________________
Name: svn:executable
   + *

Added: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/sigscheme.c	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,319 @@
+/*===========================================================================
+ *  FileName : sigscheme.c
+ *  About    : initialization and finalization
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+/*=======================================
+  System Include
+=======================================*/
+
+/*=======================================
+  Local Include
+=======================================*/
+#include "sigscheme.h"
+
+/*=======================================
+  File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+  File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+  Variable Declarations
+=======================================*/
+
+/*=======================================
+  File Local Function Declarations
+=======================================*/
+static void Scm_InitSubr(char *name, enum ScmFuncArgNum argnum, ScmFuncType func);
+
+ScmObj SigScm_nil, SigScm_true, SigScm_false, SigScm_eof;
+ScmObj SigScm_quote, SigScm_quasiquote, SigScm_unquote, SigScm_unquote_splicing;
+ScmObj SigScm_unbound, SigScm_unspecified, SigScm_undef;
+ScmObjInternal SigScm_nil_impl, SigScm_true_impl, SigScm_false_impl, SigScm_eof_impl;
+ScmObjInternal SigScm_quote_impl, SigScm_quasiquote_impl, SigScm_unquote_impl, SigScm_unquote_splicing_impl;
+ScmObjInternal SigScm_unbound_impl, SigScm_unspecified_impl, SigScm_undef_impl;
+
+/*=======================================
+  Function Implementations
+=======================================*/
+void SigScm_Initialize(void)
+{
+    ScmObj obj;
+    stack_start_pointer = &obj;
+
+    /*=======================================================================
+      Etc Variable Initialization
+    =======================================================================*/
+    SCM_NEW_ETC(SigScm_nil,              SigScm_nil_impl,              1);
+    SCM_NEW_ETC(SigScm_true,             SigScm_true_impl,             2);
+    SCM_NEW_ETC(SigScm_false,            SigScm_false_impl,            3);
+    SCM_NEW_ETC(SigScm_eof,              SigScm_eof_impl,              4);
+    SCM_NEW_ETC(SigScm_quote,            SigScm_quote_impl,            5);
+    SCM_NEW_ETC(SigScm_quasiquote,       SigScm_quasiquote_impl,       6);
+    SCM_NEW_ETC(SigScm_unquote,          SigScm_unquote_impl,          7);
+    SCM_NEW_ETC(SigScm_unquote_splicing, SigScm_unquote_splicing_impl, 8);
+    SCM_NEW_ETC(SigScm_unbound,          SigScm_unbound_impl,          9);
+    SCM_NEW_ETC(SigScm_unspecified,      SigScm_unspecified_impl,      10);
+    SCM_NEW_ETC(SigScm_undef,            SigScm_undef_impl,            11);
+    /*=======================================================================
+      Storage Initialization
+    =======================================================================*/
+    SigScm_InitStorage();
+    /*=======================================================================
+      Export Scheme Special Symbols
+    =======================================================================*/
+    SCM_SYMBOL_VCELL(Scm_Intern("#t"))   = SCM_TRUE;
+    SCM_SYMBOL_VCELL(Scm_Intern("#f"))   = SCM_FALSE;
+    SCM_SYMBOL_VCELL(Scm_Intern("else")) = SCM_TRUE;
+
+    /*=======================================================================
+      Export Scheme Functions
+    =======================================================================*/
+    /* eval.c */
+    Scm_InitSubr2("eval"                 , ScmOp_eval);
+    Scm_InitSubrL("apply"                , ScmOp_apply);
+    Scm_InitSubrR("lambda"               , ScmExp_lambda);
+    Scm_InitSubrR("if"                   , ScmExp_if);
+    Scm_InitSubrR("set!"                 , ScmExp_set);
+    Scm_InitSubrR("cond"                 , ScmExp_cond);
+    Scm_InitSubrR("case"                 , ScmExp_case);
+    Scm_InitSubrR("and"                  , ScmExp_and);
+    Scm_InitSubrR("or"                   , ScmExp_or);
+    Scm_InitSubrR("let"                  , ScmExp_let);
+    Scm_InitSubrR("let*"                 , ScmExp_let);
+    Scm_InitSubrR("begin"                , ScmExp_begin);
+    Scm_InitSubrR("delay"                , ScmOp_delay);
+    Scm_InitSubrR("define"               , ScmExp_define);
+    Scm_InitSubr1("scheme-report-environment", ScmOp_scheme_report_environment);
+    Scm_InitSubr1("null-environment"         , ScmOp_null_environment);
+    /* operations.c */
+    Scm_InitSubr1("quote"                , ScmOp_quote);
+    Scm_InitSubr2("eqv?"                 , ScmOp_eqvp);
+    Scm_InitSubr2("eq?"                  , ScmOp_eqp);
+    Scm_InitSubr1("number?"              , ScmOp_numberp);
+    Scm_InitSubrL("="                    , ScmOp_equal);
+    Scm_InitSubrL("<"                    , ScmOp_bigger);
+    Scm_InitSubrL(">"                    , ScmOp_smaller);
+    Scm_InitSubrL("<="                   , ScmOp_biggerEq);
+    Scm_InitSubrL(">="                   , ScmOp_smallerEq);
+    Scm_InitSubr1("zero?"                , ScmOp_zerop);
+    Scm_InitSubr1("positive?"            , ScmOp_positivep);
+    Scm_InitSubr1("negative?"            , ScmOp_negativep);
+    Scm_InitSubr1("odd?"                 , ScmOp_oddp);
+    Scm_InitSubr1("even?"                , ScmOp_evenp);
+    Scm_InitSubrL("max"                  , ScmOp_max);
+    Scm_InitSubrL("min"                  , ScmOp_min);
+    Scm_InitSubr2N("+"                   , ScmOp_plus2n);
+    Scm_InitSubr2N("*"                   , ScmOp_multi2n);
+    Scm_InitSubr2N("-"                   , ScmOp_minus2n);
+    Scm_InitSubr2N("/"                   , ScmOp_divide2n);
+    Scm_InitSubr1("abs"                  , ScmOp_abs);
+    Scm_InitSubr2("quotient"             , ScmOp_quotient);
+    Scm_InitSubr2("modulo"               , ScmOp_modulo);
+    Scm_InitSubr2("reminder"             , ScmOp_reminder);
+    Scm_InitSubr1("not"                  , ScmOp_not);
+    Scm_InitSubr1("boolean?"             , ScmOp_booleanp);
+    Scm_InitSubr1("pairp?"               , ScmOp_pairp);
+    Scm_InitSubr2("cons"                 , ScmOp_cons);
+    Scm_InitSubr1("car"                  , ScmOp_car);
+    Scm_InitSubr1("cdr"                  , ScmOp_cdr);
+    Scm_InitSubr2("set-car!"             , ScmOp_setcar);
+    Scm_InitSubr2("set-cdr!"             , ScmOp_setcdr);
+    Scm_InitSubr1("caar"                 , ScmOp_caar);
+    Scm_InitSubr1("cadr"                 , ScmOp_cadr);
+    Scm_InitSubr1("cdar"                 , ScmOp_cdar);
+    Scm_InitSubr1("cddr"                 , ScmOp_cddr);
+    Scm_InitSubr1("caaar"                , ScmOp_caaar);
+    Scm_InitSubr1("caadr"                , ScmOp_caadr);
+    Scm_InitSubr1("cadar"                , ScmOp_cadar);
+    Scm_InitSubr1("caddr"                , ScmOp_caddr);
+    Scm_InitSubr1("cdaar"                , ScmOp_cdaar);
+    Scm_InitSubr1("cdadr"                , ScmOp_cdadr);
+    Scm_InitSubr1("cddar"                , ScmOp_cddar);
+    Scm_InitSubr1("cdddr"                , ScmOp_cdddr);
+    Scm_InitSubr1("caaaar"               , ScmOp_caaaar);
+    Scm_InitSubr1("caaadr"               , ScmOp_caaadr);
+    Scm_InitSubr1("caadar"               , ScmOp_caadar);
+    Scm_InitSubr1("caaddr"               , ScmOp_caaddr);
+    Scm_InitSubr1("cadaar"               , ScmOp_cadaar);
+    Scm_InitSubr1("cadadr"               , ScmOp_cadadr);
+    Scm_InitSubr1("caddar"               , ScmOp_caddar);
+    Scm_InitSubr1("cadddr"               , ScmOp_cadddr);
+    Scm_InitSubr1("cdaaar"               , ScmOp_cdaaar);
+    Scm_InitSubr1("cdaadr"               , ScmOp_cdaadr);
+    Scm_InitSubr1("cdadar"               , ScmOp_cdadar);
+    Scm_InitSubr1("cdaddr"               , ScmOp_cdaddr);
+    Scm_InitSubr1("cddaar"               , ScmOp_cddaar);
+    Scm_InitSubr1("cddadr"               , ScmOp_cddadr);
+    Scm_InitSubr1("cdddar"               , ScmOp_cdddar);
+    Scm_InitSubr1("cddddr"               , ScmOp_cddddr);
+    Scm_InitSubr1("null?"                , ScmOp_nullp);
+    Scm_InitSubr1("list?"                , ScmOp_listp);
+    Scm_InitSubrL("list"                 , ScmOp_list);
+    Scm_InitSubr1("length"               , ScmOp_length);
+    Scm_InitSubr1("reverse"              , ScmOp_reverse);
+    Scm_InitSubr2("list-tail"            , ScmOp_listtail);
+    Scm_InitSubr2("list-ref"             , ScmOp_listref);
+    Scm_InitSubr2("memq"                 , ScmOp_memq);
+    Scm_InitSubr2("memv"                 , ScmOp_memv);
+    Scm_InitSubr2("assq"                 , ScmOp_assq);
+    Scm_InitSubr2("assv"                 , ScmOp_assv);
+    Scm_InitSubr1("symbol?"              , ScmOp_symbolp);
+    Scm_InitSubr1("symbol->string"       , ScmOp_symbol_to_string);
+    Scm_InitSubr1("string->symbol"       , ScmOp_string_to_symbol);
+    Scm_InitSubr1("char?"                , ScmOp_charp);
+    Scm_InitSubr2("char=?"               , ScmOp_char_equal);
+    Scm_InitSubr1("char-alphabetic?"     , ScmOp_char_alphabeticp);
+    Scm_InitSubr1("char-numeric?"        , ScmOp_char_numericp);
+    Scm_InitSubr1("char-whitespace?"     , ScmOp_char_whitespacep);
+    Scm_InitSubr1("char-upper-case?"     , ScmOp_char_upper_casep);
+    Scm_InitSubr1("char-lower-case?"     , ScmOp_char_lower_casep);
+    Scm_InitSubr1("string?"              , ScmOp_stringp);
+    Scm_InitSubrL("make-string"          , ScmOp_make_string);
+    Scm_InitSubrL("string"               , ScmOp_string);
+    Scm_InitSubr2("string-ref"           , ScmOp_string_ref);
+    Scm_InitSubr3("string-set!"          , ScmOp_string_set);
+    Scm_InitSubr1("string-length"        , ScmOp_string_length);
+    Scm_InitSubr2("string=?"             , ScmOp_string_equal);
+    Scm_InitSubr3("substring"            , ScmOp_string_substring);
+    Scm_InitSubrL("string-append"        , ScmOp_string_append);
+    Scm_InitSubr1("string->list"         , ScmOp_string_to_list);
+    Scm_InitSubr1("list->string"         , ScmOp_list_to_string);
+    Scm_InitSubr1("string-copy"          , ScmOp_string_copy);
+    Scm_InitSubr2("string-fill!"         , ScmOp_string_fill);
+    Scm_InitSubr1("vector?"              , ScmOp_vectorp);
+    Scm_InitSubrL("make-vector"          , ScmOp_make_vector);
+    Scm_InitSubrL("vector"               , ScmOp_vector);
+    Scm_InitSubr1("vector-length"        , ScmOp_vector_length);
+    Scm_InitSubr2("vector-ref"           , ScmOp_vector_ref);
+    Scm_InitSubr3("vector-set!"          , ScmOp_vector_set);
+    Scm_InitSubr1("vector->list"         , ScmOp_vector_to_list);
+    Scm_InitSubr1("list->vector"         , ScmOp_list_to_vector);
+    Scm_InitSubr2("vector-fill!"         , ScmOp_vector_fill);
+    Scm_InitSubr1("procedure?"           , ScmOp_procedurep);
+    Scm_InitSubrL("map"                  , ScmOp_map);
+    Scm_InitSubrL("for-each"             , ScmOp_for_each);
+    Scm_InitSubrL("force"                , ScmOp_force);
+    /* io.c */
+    Scm_InitSubr2("call-with-input-file" , ScmOp_call_with_input_file);
+    Scm_InitSubr2("call-with-output-file", ScmOp_call_with_output_file);
+    Scm_InitSubr1("input-port?"          , ScmOp_input_portp);
+    Scm_InitSubr1("output-port?"         , ScmOp_output_portp);
+    Scm_InitSubr0("current-input-port"   , ScmOp_current_input_port);
+    Scm_InitSubr0("current-output-port"  , ScmOp_current_output_port);
+    Scm_InitSubr2("with-input-from-file" , ScmOp_with_input_from_file);
+    Scm_InitSubr2("with-output-to-file"  , ScmOp_with_output_to_file);
+    Scm_InitSubr1("open-input-file"      , ScmOp_open_input_file);
+    Scm_InitSubr1("open-output-file"     , ScmOp_open_output_file);
+    Scm_InitSubr1("close-input-port"     , ScmOp_close_input_port);
+    Scm_InitSubr1("close-output-port"    , ScmOp_close_output_port);
+    Scm_InitSubrL("read"                 , ScmOp_read);
+    Scm_InitSubrL("read-char"            , ScmOp_read_char);
+    Scm_InitSubr1("eof-object?"          , ScmOp_eof_objectp);
+    Scm_InitSubrL("write"                , ScmOp_write);
+    Scm_InitSubrL("display"              , ScmOp_display);
+    Scm_InitSubrL("print"                , ScmOp_display);
+    Scm_InitSubrL("newline"              , ScmOp_newline);
+    Scm_InitSubrL("write-char"           , ScmOp_write_char);
+    Scm_InitSubr1("load"                 , ScmOp_load);
+
+    /*=======================================================================
+      Current Input & Output Initialization
+    =======================================================================*/
+    current_input_port  = Scm_NewPort(stdin,  PORT_INPUT);
+    current_output_port = Scm_NewPort(stdout, PORT_OUTPUT);
+
+    stack_start_pointer = NULL;
+}
+
+void SigScm_Finalize()
+{
+    SigScm_FinalizeStorage();
+}
+
+/*===========================================================================
+  Scheme Function Export Related Functions
+===========================================================================*/
+static void Scm_InitSubr(char *name, enum ScmFuncArgNum argnum, ScmFuncType c_func)
+{
+    ScmObj sym  = Scm_Intern(name);
+    ScmObj func = Scm_NewFunc(argnum, c_func);
+
+    SCM_SYMBOL_VCELL(sym) = func;
+}
+
+void Scm_InitSubr0(char *name, ScmObj (*func) (void))
+{
+    Scm_InitSubr(name, ARGNUM_0, (ScmFuncType)func);
+}
+
+void Scm_InitSubr1(char *name, ScmObj (*func) (ScmObj))
+{
+    Scm_InitSubr(name, ARGNUM_1, (ScmFuncType)func);
+}
+
+void Scm_InitSubr2(char *name, ScmObj (*func) (ScmObj, ScmObj))
+{
+    Scm_InitSubr(name, ARGNUM_2, (ScmFuncType)func);
+}
+
+void Scm_InitSubr3(char *name, ScmObj (*func) (ScmObj, ScmObj, ScmObj))
+{
+    Scm_InitSubr(name, ARGNUM_3, (ScmFuncType)func);
+}
+
+void Scm_InitSubr4(char *name, ScmObj (*func) (ScmObj, ScmObj, ScmObj, ScmObj))
+{
+    Scm_InitSubr(name, ARGNUM_4, (ScmFuncType)func);
+}
+
+void Scm_InitSubr5(char *name, ScmObj (*func) (ScmObj, ScmObj, ScmObj, ScmObj, ScmObj))
+{
+    Scm_InitSubr(name, ARGNUM_5, (ScmFuncType)func);
+}
+
+void Scm_InitSubrL(char *name, ScmObj (*func) (ScmObj, ScmObj))
+{
+    Scm_InitSubr(name, ARGNUM_L, (ScmFuncType)func);
+}
+
+void Scm_InitSubrR(char *name, ScmObj (*func) (ScmObj, ScmObj))
+{
+    Scm_InitSubr(name, ARGNUM_R, (ScmFuncType)func);
+}
+
+void Scm_InitSubr2N(char *name, ScmObj (*func) (ScmObj, ScmObj))
+{
+    Scm_InitSubr(name, ARGNUM_2N, (ScmFuncType)func);
+}

Added: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/sigscheme.h	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,302 @@
+/*===========================================================================
+ *  FileName : sigscheme.h
+ *  About    : main header file
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+#ifndef __SIGSCHEME_H
+#define __SIGSCHEME_H
+
+/*=======================================
+   System Include
+=======================================*/
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+
+/*=======================================
+   Local Include
+=======================================*/
+
+/*=======================================
+   Struct Declarations
+=======================================*/
+#include "sigschemetype.h"
+
+/*=======================================
+   Variable Declarations
+=======================================*/
+extern ScmObj *stack_start_pointer;
+
+extern ScmObj current_input_port;
+extern ScmObj current_output_port;
+
+/*=======================================
+   Macro Declarations
+=======================================*/
+#define DEBUG_PARSER  0
+#define DEBUG_GC      0
+#define USE_EUCJP     1
+
+#define CHECK_1_ARG(arg) \
+    (SCM_NULLP(arg))
+
+#define CHECK_2_ARGS(arg) \
+    (SCM_NULLP(arg) || SCM_NULLP(SCM_CDR(arg)))
+
+#define CHECK_3_ARGS(arg) \
+    (SCM_NULLP(arg) || SCM_NULLP(SCM_CDR(arg)) || SCM_NULLP(SCM_CDR(SCM_CDR(arg))))
+
+#define CHECK_4_ARGS(arg) \
+    (SCM_NULLP(arg) || SCM_NULLP(SCM_CDR(arg)) || SCM_NULLP(SCM_CDR(SCM_CDR(arg))) \
+     || SCM_NULLP(SCM_CDR(SCM_CDR(SCM_CDR(arg)))))
+
+#define CHECK_5_ARGS(arg) \
+    (SCM_NULLP(arg) || SCM_NULLP(SCM_CDR(arg)) || SCM_NULLP(SCM_CDR(SCM_CDR(arg))) \
+     || SCM_NULLP(SCM_CDR(SCM_CDR(SCM_CDR(arg)))) || SCM_NULLP(SCM_CDR(SCM_CDR(SCM_CDR(SCM_CDR(arg))))))
+
+int SigScm_Die(const char *msg, const char *filename, int line); /* error.c */
+#define sigassert(cond) \
+    (cond ? 0 : SigScm_Die("assertion failed.", __FILE__, __LINE__))
+
+/*=======================================
+   Function Declarations
+=======================================*/
+/* sigscheme.c */
+void SigScm_Initialize(void);
+void SigScm_Finalize(void);
+void Scm_InitSubr0(char *name, ScmObj (*func) (void));
+void Scm_InitSubr1(char *name, ScmObj (*func) (ScmObj));
+void Scm_InitSubr2(char *name, ScmObj (*func) (ScmObj, ScmObj));
+void Scm_InitSubr3(char *name, ScmObj (*func) (ScmObj, ScmObj, ScmObj));
+void Scm_InitSubr4(char *name, ScmObj (*func) (ScmObj, ScmObj, ScmObj, ScmObj));
+void Scm_InitSubr5(char *name, ScmObj (*func) (ScmObj, ScmObj, ScmObj, ScmObj, ScmObj));
+void Scm_InitSubrL(char *name, ScmObj (*func) (ScmObj, ScmObj env));
+void Scm_InitSubrR(char *name, ScmObj (*func) (ScmObj, ScmObj env));
+void Scm_InitSubr2N(char *name, ScmObj (*func) (ScmObj, ScmObj));
+
+/* datas.c */
+void   SigScm_InitStorage(void);
+void   SigScm_FinalizeStorage(void);
+ScmObj Scm_NewCons(ScmObj a, ScmObj b);
+ScmObj Scm_NewInt(int val);
+ScmObj Scm_NewSymbol(char *name, ScmObj v_cell);
+ScmObj Scm_NewChar(char *ch);
+ScmObj Scm_NewString(char *str);
+ScmObj Scm_NewString_With_StrLen(char *str, int len);
+ScmObj Scm_NewFunc(enum ScmFuncArgNum num_arg, ScmFuncType func);
+ScmObj Scm_NewClosure(ScmObj exp, ScmObj env);
+ScmObj Scm_NewVector(ScmObj *vec, ScmObj len);
+ScmObj Scm_NewPort(FILE *file, enum ScmPortType ptype);
+ScmObj Scm_Intern(const char *name);
+
+/* eval.c */
+ScmObj ScmOp_eval(ScmObj obj, ScmObj env);
+ScmObj ScmOp_apply(ScmObj arg, ScmObj env);
+ScmObj ScmOp_quote(ScmObj obj);
+ScmObj ScmExp_lambda(ScmObj exp, ScmObj env);
+ScmObj ScmExp_if(ScmObj exp, ScmObj env);
+ScmObj ScmExp_set(ScmObj arg, ScmObj env);
+ScmObj ScmExp_cond(ScmObj arg, ScmObj env);
+ScmObj ScmExp_case(ScmObj arg, ScmObj env);
+ScmObj ScmExp_and(ScmObj arg, ScmObj env);
+ScmObj ScmExp_or(ScmObj arg, ScmObj env);
+ScmObj ScmExp_let(ScmObj arg, ScmObj env);
+ScmObj ScmExp_begin(ScmObj arg, ScmObj env);
+ScmObj ScmOp_delay(ScmObj arg, ScmObj env);
+ScmObj ScmOp_quasiquote(ScmObj temp);
+ScmObj ScmOp_unquote(ScmObj exp);
+ScmObj ScmOp_unquote_splicint(ScmObj exp);
+ScmObj ScmExp_define(ScmObj arg, ScmObj env);
+ScmObj ScmOp_scheme_report_environment(ScmObj version);
+ScmObj ScmOp_null_environment(ScmObj version);
+
+
+/* operations.c */
+ScmObj ScmOp_eqvp(ScmObj obj1, ScmObj obj2);
+ScmObj ScmOp_eqp(ScmObj Obj1, ScmObj obj2);
+ScmObj ScmOp_numberp(ScmObj obj);
+ScmObj ScmOp_equal(ScmObj list, ScmObj env);
+ScmObj ScmOp_bigger(ScmObj list, ScmObj env);
+ScmObj ScmOp_smaller(ScmObj list, ScmObj env);
+ScmObj ScmOp_biggerEq(ScmObj list, ScmObj env);
+ScmObj ScmOp_smallerEq(ScmObj list, ScmObj env);
+ScmObj ScmOp_zerop(ScmObj num);
+ScmObj ScmOp_positivep(ScmObj num);
+ScmObj ScmOp_negativep(ScmObj num);
+ScmObj ScmOp_oddp(ScmObj num);
+ScmObj ScmOp_evenp(ScmObj num);
+ScmObj ScmOp_max(ScmObj list, ScmObj env);
+ScmObj ScmOp_min(ScmObj list, ScmObj env);
+ScmObj ScmOp_plus2n(ScmObj obj1, ScmObj obj2);
+ScmObj ScmOp_minus2n(ScmObj obj1, ScmObj obj2);
+ScmObj ScmOp_multi2n(ScmObj obj1, ScmObj obj2);
+ScmObj ScmOp_divide2n(ScmObj obj1, ScmObj obj2);
+ScmObj ScmOp_abs(ScmObj num);
+ScmObj ScmOp_quotient(ScmObj n1, ScmObj n2);
+ScmObj ScmOp_modulo(ScmObj n1, ScmObj n2);
+ScmObj ScmOp_reminder(ScmObj n1, ScmObj n2);
+ScmObj ScmOp_not(ScmObj obj);
+ScmObj ScmOp_booleanp(ScmObj obj);
+ScmObj ScmOp_pairp(ScmObj obj);
+ScmObj ScmOp_cons(ScmObj car, ScmObj cdr);
+ScmObj ScmOp_car(ScmObj pair);
+ScmObj ScmOp_cdr(ScmObj pair);
+ScmObj ScmOp_setcar(ScmObj pair, ScmObj car);
+ScmObj ScmOp_setcdr(ScmObj pair, ScmObj cdr);
+ScmObj ScmOp_caar(ScmObj pair);
+ScmObj ScmOp_cadr(ScmObj pair);
+ScmObj ScmOp_cdar(ScmObj pair);
+ScmObj ScmOp_cddr(ScmObj pair);
+ScmObj ScmOp_caaar(ScmObj pair);
+ScmObj ScmOp_caadr(ScmObj pair);
+ScmObj ScmOp_cadar(ScmObj pair);
+ScmObj ScmOp_caddr(ScmObj pair);
+ScmObj ScmOp_cdaar(ScmObj pair);
+ScmObj ScmOp_cdadr(ScmObj pair);
+ScmObj ScmOp_cddar(ScmObj pair);
+ScmObj ScmOp_cdddr(ScmObj pair);
+ScmObj ScmOp_caaaar(ScmObj pair);
+ScmObj ScmOp_caaadr(ScmObj pair);
+ScmObj ScmOp_caadar(ScmObj pair);
+ScmObj ScmOp_caaddr(ScmObj pair);
+ScmObj ScmOp_cadaar(ScmObj pair);
+ScmObj ScmOp_cadadr(ScmObj pair);
+ScmObj ScmOp_caddar(ScmObj pair);
+ScmObj ScmOp_cadddr(ScmObj pair);
+ScmObj ScmOp_cdaaar(ScmObj pair);
+ScmObj ScmOp_cdaadr(ScmObj pair);
+ScmObj ScmOp_cdadar(ScmObj pair);
+ScmObj ScmOp_cdaddr(ScmObj pair);
+ScmObj ScmOp_cddaar(ScmObj pair);
+ScmObj ScmOp_cddadr(ScmObj pair);
+ScmObj ScmOp_cdddar(ScmObj pair);
+ScmObj ScmOp_cddddr(ScmObj pair);
+ScmObj ScmOp_nullp(ScmObj obj);
+ScmObj ScmOp_listp(ScmObj obj);
+ScmObj ScmOp_list(ScmObj obj, ScmObj env);
+ScmObj ScmOp_length(ScmObj obj);
+ScmObj ScmOp_append(ScmObj start, ScmObj item);
+ScmObj ScmOp_reverse(ScmObj obj);
+ScmObj ScmOp_listtail(ScmObj list, ScmObj k);
+ScmObj ScmOp_listref(ScmObj list, ScmObj k);
+ScmObj ScmOp_memq(ScmObj obj, ScmObj list);
+ScmObj ScmOp_memv(ScmObj obj, ScmObj list);
+ScmObj ScmOp_assq(ScmObj obj, ScmObj alist);
+ScmObj ScmOp_assv(ScmObj obj, ScmObj alist);
+ScmObj ScmOp_symbolp(ScmObj obj);
+ScmObj ScmOp_boundp(ScmObj obj);
+ScmObj ScmOp_symbol_to_string(ScmObj obj);
+ScmObj ScmOp_string_to_symbol(ScmObj str);
+
+ScmObj ScmOp_charp(ScmObj obj);
+ScmObj ScmOp_char_equal(ScmObj ch1, ScmObj ch2);
+/* TODO : many comparing functions around char is unimplemented */
+ScmObj ScmOp_char_alphabeticp(ScmObj obj);
+ScmObj ScmOp_char_numericp(ScmObj obj);
+ScmObj ScmOp_char_whitespacep(ScmObj obj);
+ScmObj ScmOp_char_upper_casep(ScmObj obj);
+ScmObj ScmOp_char_lower_casep(ScmObj obj);
+
+ScmObj ScmOp_stringp(ScmObj obj);
+ScmObj ScmOp_make_string(ScmObj arg, ScmObj env);
+ScmObj ScmOp_string(ScmObj arg, ScmObj env);
+ScmObj ScmOp_string_length(ScmObj str);
+ScmObj ScmOp_string_ref(ScmObj str, ScmObj k);
+ScmObj ScmOp_string_set(ScmObj str, ScmObj k, ScmObj ch);
+ScmObj ScmOp_string_equal(ScmObj str1, ScmObj str2);
+/* TODO : many comparing functions around string is unimplemented */
+ScmObj ScmOp_string_substring(ScmObj str, ScmObj start, ScmObj end);
+ScmObj ScmOp_string_append(ScmObj arg, ScmObj env);
+ScmObj ScmOp_string_to_list(ScmObj string);
+ScmObj ScmOp_list_to_string(ScmObj list);
+ScmObj ScmOp_string_copy(ScmObj string);
+ScmObj ScmOp_string_fill(ScmObj string, ScmObj ch);
+
+ScmObj ScmOp_vectorp(ScmObj vector);
+ScmObj ScmOp_make_vector(ScmObj obj, ScmObj env);
+ScmObj ScmOp_vector(ScmObj obj, ScmObj env);
+ScmObj ScmOp_vector_length(ScmObj vector);
+ScmObj ScmOp_vector_ref(ScmObj vec, ScmObj k);
+ScmObj ScmOp_vector_set(ScmObj vec, ScmObj k, ScmObj obj);
+ScmObj ScmOp_vector_to_list(ScmObj vec);
+ScmObj ScmOp_list_to_vector(ScmObj list);
+ScmObj ScmOp_vector_fill(ScmObj vec, ScmObj fill);
+ScmObj ScmOp_procedurep(ScmObj obj);
+ScmObj ScmOp_map(ScmObj arg, ScmObj env);
+ScmObj ScmOp_for_each(ScmObj arg, ScmObj env);
+ScmObj ScmOp_force(ScmObj arg, ScmObj env);
+
+/* io.c */
+ScmObj ScmOp_call_with_input_file(ScmObj filepath, ScmObj proc);
+ScmObj ScmOp_call_with_output_file(ScmObj filepath, ScmObj proc);
+ScmObj ScmOp_input_portp(ScmObj obj);
+ScmObj ScmOp_output_portp(ScmObj obj);
+ScmObj ScmOp_current_input_port(void);
+ScmObj ScmOp_current_output_port(void);
+ScmObj ScmOp_with_input_from_file(ScmObj filepath, ScmObj thunk);
+ScmObj ScmOp_with_output_to_file(ScmObj filepath, ScmObj thunk);
+ScmObj ScmOp_open_input_file(ScmObj filepath);
+ScmObj ScmOp_open_output_file(ScmObj filepath);
+ScmObj ScmOp_close_input_port(ScmObj port);
+ScmObj ScmOp_close_output_port(ScmObj port);
+
+ScmObj ScmOp_read(ScmObj arg, ScmObj env);
+ScmObj ScmOp_read_char(ScmObj arg, ScmObj env);
+ScmObj ScmOp_peek_char(ScmObj arg, ScmObj env);
+ScmObj ScmOp_eof_objectp(ScmObj obj);
+ScmObj ScmOp_char_readyp(ScmObj arg, ScmObj env);
+ScmObj ScmOp_write(ScmObj arg, ScmObj env);
+ScmObj ScmOp_display(ScmObj arg, ScmObj env);
+ScmObj ScmOp_newline(ScmObj arg, ScmObj env);
+ScmObj ScmOp_write_char(ScmObj arg, ScmObj env);
+
+ScmObj SigScm_load(char *c_filename);
+ScmObj ScmOp_load(ScmObj filename);
+
+/* encoding.c */
+int SigScm_default_encoding_strlen(const char *str);
+const char* SigScm_default_encoding_str_startpos(const char *str, int k);
+const char* SigScm_default_encoding_str_endpos(const char *str, int k);
+
+/* read.c */
+ScmObj SigScm_Read(ScmObj port);
+ScmObj SigScm_Read_Char(ScmObj port);
+
+/* error.c */
+void SigScm_Error(const char *msg);
+
+/* debug.c */
+void SigScm_Display(ScmObj obj);
+void SigScm_DisplayToPort(ScmObj port, ScmObj obj);
+
+
+#endif /* __SIGSCHEME_H */

Added: branches/r5rs/sigscheme/sigschemetype.h
===================================================================
--- branches/r5rs/sigscheme/sigschemetype.h	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/sigschemetype.h	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,318 @@
+/*===========================================================================
+ *  FileName : sigschemetype.h
+ *  About    : scheme object type definition
+ *
+ *  Copyright (C) 2005      by Kazuki Ohta (mover at hct.zaq.ne.jp)
+ *
+ *  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.
+===========================================================================*/
+#ifndef __SIGSCMTYPE_H
+#define __SIGSCMTYPE_H
+
+/*=======================================
+   System Include
+=======================================*/
+#include <stdio.h>
+
+/*=======================================
+   Local Include
+=======================================*/
+
+/*=======================================
+   Struct Declarations
+=======================================*/
+/* Scheme Object Type */
+enum ScmObjType {
+    ScmInt      = 0,
+    ScmCons     = 1,
+    ScmSymbol   = 2,
+    ScmChar     = 3,
+    ScmString   = 4,
+    ScmFunc     = 5,
+    ScmClosure  = 6,
+    ScmVector   = 7,
+    ScmPort     = 8,
+    ScmFreeCell = 9,
+    ScmEtc      = 10
+};
+
+/* Function Type by argnuments */
+enum ScmFuncArgNum {
+    ARGNUM_0  = 0,
+    ARGNUM_1  = 1,
+    ARGNUM_2  = 2,
+    ARGNUM_3  = 3,
+    ARGNUM_4  = 4,
+    ARGNUM_5  = 5,
+    ARGNUM_L  = 6, /* all args are already evaluated */
+    ARGNUM_R  = 7, /* all args are "not" evaluated yet */
+    ARGNUM_2N = 8  /* all args are evaluated each 2 objs */
+};
+
+/* GC Mark Flag */
+enum GCMark {
+    GC_Unmarked = 0,
+    GC_Marked = 1
+};
+
+/* ScmPort type */
+enum ScmPortType {
+    PORT_INPUT  = 0,
+    PORT_OUTPUT = 1
+};
+
+/* ScmPort Info */
+typedef struct _ScmPortInfo ScmPortInfo;
+struct _ScmPortInfo {
+    FILE *file;
+    char ungottenchar;
+};
+
+
+/* Scheme Object */
+typedef struct ScmObjInternal_ ScmObjInternal;
+typedef ScmObjInternal *ScmObj;
+struct ScmObjInternal_ {
+    enum ScmObjType type;
+    enum GCMark gcmark;
+
+    union {
+        struct {
+            int value;
+        } int_value;
+
+        struct {
+            ScmObj car;
+            ScmObj cdr;
+        } cons;
+
+        struct {
+            char *sym_name;
+            ScmObj v_cell;
+        } symbol;
+
+        struct {
+            char *ch;
+        } ch;
+
+        struct {
+            char *str;
+            int len;
+        } string;
+
+        struct {
+            union {
+                struct {
+                    ScmObj (*func) (void);
+                } subr0;
+
+                struct {
+                    ScmObj (*func) (ScmObj);
+                } subr1;
+
+                struct {
+                    ScmObj (*func) (ScmObj, ScmObj);
+                } subr2;
+
+                struct {
+                    ScmObj (*func) (ScmObj, ScmObj, ScmObj);
+                } subr3;
+
+                struct {
+                    ScmObj (*func) (ScmObj, ScmObj, ScmObj, ScmObj);
+                } subr4;
+
+                struct {
+                    ScmObj (*func) (ScmObj, ScmObj, ScmObj, ScmObj, ScmObj);
+                } subr5;
+            } subrs;
+
+            enum ScmFuncArgNum num_arg;
+        } func;
+
+        struct ScmClosure {
+            ScmObj exp;
+            ScmObj env;
+        } closure;
+
+        struct ScmVector {
+            ScmObj *vec;
+            ScmObj len;
+        } vector;
+
+        struct ScmPort {            
+            enum ScmPortType port_type;
+            ScmPortInfo     *port_info;
+        } port;
+
+        struct ScmEtc {
+            int type;
+        } etc;
+    } obj;
+};
+
+#define SCM_GETTYPE(a)       (a->type)
+#define SCM_SETTYPE(a, objtype) (a->type = objtype)
+#define SCM_MARK(a) ((a)->gcmark)
+#define SCM_DO_MARK(a) (SCM_MARK(a) = GC_Marked)
+#define SCM_DO_UNMARK(a) (SCM_MARK(a) = GC_Unmarked)
+#define SCM_IS_MARKED(a) (SCM_MARK(a) == GC_Marked)
+
+#define SCM_INTP(a)  (SCM_GETTYPE(a) == ScmInt)
+#define SCM_INT(a)   (sigassert(SCM_INTP(a)), a)
+#define SCM_INT_VALUE(a) (SCM_INT(a)->obj.int_value.value)
+#define SCM_SETINT(a)    (SCM_SETTYPE(a, ScmInt))
+#define SCM_SETINT_VALUE(a, val) (SCM_INT_VALUE(a) = val)
+
+#define SCM_CONSP(a) (SCM_GETTYPE(a) == ScmCons)
+#define SCM_CONS(a)  (sigassert(SCM_CONSP(a)), a)
+#define SCM_CAR(a)   (SCM_CONS(a)->obj.cons.car)
+#define SCM_CDR(a)   (SCM_CONS(a)->obj.cons.cdr)
+#define SCM_SETCONS(a) (SCM_SETTYPE(a, ScmCons))
+#define SCM_SETCAR(a,car)   (SCM_CAR(a) = car)
+#define SCM_SETCDR(a,cdr)   (SCM_CDR(a) = cdr)
+
+#define SCM_FREECELLP(a)     (SCM_GETTYPE(a) == ScmFreeCell)
+#define SCM_FREECELL(a)      (sigassert(SCM_FREECELLP(a)), a)
+#define SCM_FREECELL_CAR(a)  (SCM_FREECELL(a)->obj.cons.car)
+#define SCM_FREECELL_CDR(a)  (SCM_FREECELL(a)->obj.cons.cdr)
+#define SCM_SETFREECELL(a)    (SCM_SETTYPE(a, ScmFreeCell))
+#define SCM_SETFREECELL_CAR(a,car) (SCM_FREECELL_CAR(a) = car)
+#define SCM_SETFREECELL_CDR(a,cdr) (SCM_FREECELL_CDR(a) = cdr)
+
+#define SCM_SYMBOLP(a)      (SCM_GETTYPE(a) == ScmSymbol)
+#define SCM_SYMBOL(a)       (sigassert(SCM_SYMBOLP(a)), a)
+#define SCM_SYMBOL_NAME(a)  (SCM_SYMBOL(a)->obj.symbol.sym_name)
+#define SCM_SYMBOL_VCELL(a) (SCM_SYMBOL(a)->obj.symbol.v_cell)
+#define SCM_SETSYMBOL(a)    (SCM_SETTYPE(a, ScmSymbol))
+#define SCM_SETSYMBOL_NAME(a, name)   (SCM_SYMBOL_NAME(a) = name)
+#define SCM_SETSYMBOL_VCELL(a, vcell) (SCM_SYMBOL_VCELL(a) = vcell)
+
+#define SCM_CHARP(a) (SCM_GETTYPE(a) == ScmChar)
+#define SCM_CHAR(a)  (sigassert(SCM_CHARP(a)), a)
+#define SCM_CHAR_CH(a) (SCM_CHAR(a)->obj.ch.ch)
+#define SCM_SETCHAR(a) (SCM_SETTYPE(a, ScmChar))
+#define SCM_SETCHAR_CH(a, chr) (SCM_CHAR_CH(a) = chr)
+
+#define SCM_STRINGP(a) (SCM_GETTYPE(a) == ScmString)
+#define SCM_STRING(a)  (sigassert(SCM_STRINGP(a)), a)
+#define SCM_STRING_STR(a) (SCM_STRING(a)->obj.string.str)
+#define SCM_STRING_LEN(a) (SCM_STRING(a)->obj.string.len)
+#define SCM_SETSTRING(a)  (SCM_SETTYPE(a, ScmString))
+#define SCM_SETSTRING_STR(a, str) (SCM_STRING_STR(a) = str)
+#define SCM_SETSTRING_LEN(a, len) (SCM_STRING_LEN(a) = len)
+
+typedef ScmObj (*ScmFuncType) (void);
+#define SCM_FUNCP(a) (SCM_GETTYPE(a) == ScmFunc)
+#define SCM_FUNC(a) (sigassert(SCM_FUNCP(a)), a)
+#define SCM_FUNC_NUMARG(a) (SCM_FUNC(a)->obj.func.num_arg)
+#define SCM_FUNC_FUNC(a)   (SCM_FUNC(a)->obj.func.subrs.subr0.func)
+#define SCM_SETFUNC(a)     (SCM_SETTYPE(a, ScmFunc))
+#define SCM_SETFUNC_NUMARG(a, numarg) (SCM_FUNC_NUMARG(a) = numarg)
+#define SCM_SETFUNC_FUNC(a, func)     (SCM_FUNC_FUNC(a) = (ScmFuncType)func)
+
+#define SCM_FUNC_EXEC_SUBR0(a)                               ((*a->obj.func.subrs.subr0.func) ())
+#define SCM_FUNC_EXEC_SUBR1(a, arg1)                         ((*a->obj.func.subrs.subr1.func) (arg1))
+#define SCM_FUNC_EXEC_SUBR2(a, arg1, arg2)                   ((*a->obj.func.subrs.subr2.func) (arg1, arg2))
+#define SCM_FUNC_EXEC_SUBR3(a, arg1, arg2, arg3)             ((*a->obj.func.subrs.subr3.func) (arg1, arg2, arg3))
+#define SCM_FUNC_EXEC_SUBR4(a, arg1, arg2, arg3, arg4)       ((*a->obj.func.subrs.subr4.func) (arg1, arg2, arg3, arg4))
+#define SCM_FUNC_EXEC_SUBR5(a, arg1, arg2, arg3, arg4, arg5) ((*a->obj.func.subrs.subr5.func) (arg1, arg2, arg3, arg4, arg5))
+#define SCM_FUNC_EXEC_SUBRL(a, arg1, arg2)                   ((*a->obj.func.subrs.subr2.func) (arg1, arg2))
+#define SCM_FUNC_EXEC_SUBRR(a, arg1, arg2)                   ((*a->obj.func.subrs.subr2.func) (arg1, arg2))
+#define SCM_FUNC_EXEC_SUBR2N(a, arg1, arg2)                  ((*a->obj.func.subrs.subr2.func) (arg1, arg2))
+
+#define SCM_CLOSUREP(a) (SCM_GETTYPE(a) == ScmClosure)
+#define SCM_CLOSURE(a)  (sigassert(SCM_CLOSUREP(a)), a)
+#define SCM_CLOSURE_EXP(a) (SCM_CLOSURE(a)->obj.closure.exp)
+#define SCM_CLOSURE_ENV(a) (SCM_CLOSURE(a)->obj.closure.env)
+#define SCM_SETCLOSURE(a) (SCM_SETTYPE(a, ScmClosure))
+#define SCM_SETCLOSURE_EXP(a, formals) (SCM_CLOSURE_EXP(a) = exp)
+#define SCM_SETCLOSURE_ENV(a, body) (SCM_CLOSURE_ENV(a) = env)
+
+#define SCM_VECTORP(a) (SCM_GETTYPE(a) == ScmVector)
+#define SCM_VECTOR(a)  (sigassert(SCM_VECTORP(a)), a)
+#define SCM_VECTOR_VEC(a) (SCM_VECTOR(a)->obj.vector.vec)
+#define SCM_VECTOR_LEN(a) (SCM_VECTOR(a)->obj.vector.len)
+#define SCM_VECTOR_CHECK_IDX(a, idx) ()
+#define SCM_VECTOR_CREF(a, idx) (SCM_VECTOR_VEC(a)[idx])
+#define SCM_VECTOR_REF(a, idx)  (SCM_VECTOR_CREF(a, SCM_INT_VALUE(idx)))
+#define SCM_SETVECTOR(a) (SCM_SETTYPE(a, ScmVector))
+#define SCM_SETVECTOR_VEC(a, vec) (SCM_VECTOR_VEC(a) = vec)
+#define SCM_SETVECTOR_LEN(a, len) (SCM_VECTOR_LEN(a) = len)
+#define SCM_SETVECTOR_CREF(a, idx, b) (SCM_VECTOR_CREF(a, idx) = b)
+#define SCM_SETVECTOR_REF(a, idx, b)  (SCM_VECTOR_REF(a, idx) = b)
+
+#define SCM_PORTP(a) (SCM_GETTYPE(a) == ScmPort)
+#define SCM_PORT(a)  (sigassert(SCM_PORTP(a)), a)
+#define SCM_PORT_PORTTYPE(a) (SCM_PORT(a)->obj.port.port_type)
+#define SCM_PORT_PORTINFO(a) (SCM_PORT(a)->obj.port.port_info)
+#define SCM_SETPORT(a) (SCM_SETTYPE(a, ScmPort))
+#define SCM_SETPORT_PORTTYPE(a, ptype) (SCM_PORT_PORTTYPE(a) = ptype)
+#define SCM_SETPORT_PORTINFO(a, pinfo) (SCM_PORT_PORTINFO(a) = pinfo)
+#define SCM_PORTINFO_FILE(a) (SCM_PORT_PORTINFO(a)->file)
+#define SCM_PORTINFO_UNGOTTENCHAR(a) (SCM_PORT_PORTINFO(a)->ungottenchar)
+
+/*============================================================================
+  Etcetra variables (Special Symbols like NIL)
+============================================================================*/
+#define SCM_ETCP(a) (SCM_GETTYPE(a) == ScmEtc)
+#define SCM_ETC(a) (sigassert(SCM_ETCP(a)), a)
+#define SCM_ETC_TYPE(a) (SCM_ETC(a)->obj.etc.type)
+#define SCM_SETETC_TYPE(a, etctype) (SCM_ETC_TYPE(a) = etctype)
+#define SCM_NEW_ETC(a, impl, etctype) \
+    a = &impl;\
+    SCM_SETTYPE(a, ScmEtc);\
+    SCM_SETETC_TYPE(a, etctype);
+
+extern ScmObj SigScm_nil, SigScm_true, SigScm_false, SigScm_eof;
+extern ScmObj SigScm_quote, SigScm_quasiquote, SigScm_unquote, SigScm_unquote_splicing;
+extern ScmObj SigScm_unbound, SigScm_unspecified, SigScm_undef;
+
+#define SCM_NIL              SigScm_nil
+#define SCM_TRUE             SigScm_true
+#define SCM_FALSE            SigScm_false
+#define SCM_EOF              SigScm_eof
+#define SCM_QUOTE            SigScm_quote
+#define SCM_QUASIQUOTE       SigScm_quasiquote
+#define SCM_UNQUOTE          SigScm_unquote
+#define SCM_UNQUOTE_SPLICING SigScm_unquote_splicing
+#define SCM_UNBOUND          SigScm_unbound
+#define SCM_UNSPECIFIED      SigScm_unspecified
+#define SCM_UNDEF            SigScm_undef
+
+#define EQ(a, b) (a == b)
+#define NEQ(a, b) !(EQ(a, b))
+
+#define SCM_EQ(a, b)  (EQ(a, b))
+#define SCM_NEQ(a, b) (NEQ(a, b))
+#define SCM_NULLP(a)  (EQ(a, SCM_NIL))
+#define SCM_TRUEP(a)  (EQ(a, SCM_TRUE))
+#define SCM_FALSEP(a) (EQ(a, SCM_FALSE))
+#define SCM_EOFP(a)   (EQ(a, SCM_EOF))
+
+#endif /* __SIGSCMTYPE_H */

Added: branches/r5rs/sigscheme/test/define.scm
===================================================================
--- branches/r5rs/sigscheme/test/define.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/define.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,7 @@
+(define total
+  (lambda (n val)
+    (if (= n 0)
+	val
+	(total (- n 1) (+ val n)))))
+
+(print (total 10 0))

Added: branches/r5rs/sigscheme/test/for-each.scm
===================================================================
--- branches/r5rs/sigscheme/test/for-each.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/for-each.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,2 @@
+(for-each (lambda (x) (print x))
+	  '(1 2 3))

Added: branches/r5rs/sigscheme/test/io.scm
===================================================================
--- branches/r5rs/sigscheme/test/io.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/io.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1 @@
+(print (read-char))

Added: branches/r5rs/sigscheme/test/map.scm
===================================================================
--- branches/r5rs/sigscheme/test/map.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/map.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,8 @@
+(print (map cadr '((1 2) (1 2) (1 2))))
+(print (map + '(1 2 3) '(1 2 3)))
+(print (map (lambda (x y) (+ x y))
+	    '(1 2 3) '(1 2 3)))
+(print (map print '(1 2 3)))
+
+(print (map print '(1 2 3)))
+(print (map (lambda (x) (+ x x)) '(1 2 3)))

Added: branches/r5rs/sigscheme/test/quote.scm
===================================================================
--- branches/r5rs/sigscheme/test/quote.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/quote.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,9 @@
+(load "test/unittest.scm")
+
+(print '(1 2 3))
+(print `(1 2 3))
+
+;(assert-eq? "quasiquote check" '(1 2 3) `(1 2 3))
+;(assert-eq? "unquote check" `(1 2 3) `(1 ,(+ 1 1) ,(+ 1 2)))
+;(assert-eq? "unquote-splicing check" `(1 2 3) `(1 ,@(car '(1 2)) 3))
+;(assert-eq? "mixed check" '(a 3 c 7 8 9) `(a ,(+ 1 2) c ,@(cdr '(6 7 8 9))))

Added: branches/r5rs/sigscheme/test/test-apply.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-apply.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/test-apply.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,8 @@
+(load "test/unittest.scm")
+
+;; check apply
+(assert-eq? "apply check" #t (apply = '(1 1 1)))
+(assert-eq? "apply check" 6  (apply + '(1 2 (+ 1 2))))
+(assert-eq? "apply check" 4  (apply (lambda (x y) (+ x y)) '(1 3)))
+
+(total-report)

Added: branches/r5rs/sigscheme/test/test-case.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-case.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/test-case.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,17 @@
+(load "test/unittest.scm")
+
+(assert-eq? "basic case check1" 'case1 (case 1
+					 ((1) 'case1)
+					 ((2) 'case2)))
+
+(assert-eq? "basic case check2" 'case2 (case 2
+					 ((1) 'case1)
+					 ((2) 'case2)))
+
+(assert-eq? "basic else check"  'caseelse (case 3
+					((1) 'case1)
+					((2) 'case2)
+					(else
+					 'caseelse)))
+
+(total-report)

Added: branches/r5rs/sigscheme/test/test-char.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-char.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/test-char.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,9 @@
+(load "test/unittest.scm")
+
+;; check char?
+(assert "alphabet char" (char? #\a))
+(assert "space"         (char? #\space))
+(assert "newline"       (char? #\newline))
+(assert "hiragana char" (char? #\¤¢))
+
+(total-report)

Added: branches/r5rs/sigscheme/test/test-define.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-define.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/test-define.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,20 @@
+(load "test/unittest.scm")
+
+; basic define
+(define val1 3)
+(assert-eq? "basic define check" 3 val1)
+
+; redefine
+(define val1 5)
+(assert-eq? "redefine check" 5 val1)
+
+; define lambda
+(define (what? x)
+  x)
+(assert-eq? "func define" 10 (what? 10))
+
+(define (add x y)
+  (+ x y))
+(assert-eq? "func define" 10 (add 2 8))
+
+(total-report)

Added: branches/r5rs/sigscheme/test/test-delay-force.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-delay-force.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/test-delay-force.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,10 @@
+(load "test/unittest.scm")
+
+;; check delay and force
+(assert-eq? "delay-force check" 6 (begin
+				    (define foo (delay
+						  (+ 1 2 3)))
+
+				    (force foo)))
+
+(total-report)

Added: branches/r5rs/sigscheme/test/test-equation.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-equation.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/test-equation.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,25 @@
+(load "test/unittest.scm")
+
+
+;; check eqv?
+(assert "check both #t" (eqv? #t #t))
+(assert "check both #f" (eqv? #f #f))
+;(assert "check symbol"  (string=? (symbol->string 'obj)
+; (symbol->string 'obj)))
+(assert "check num"  (eqv? 10 10))
+(assert "check alphabet char" (eqv? #\a  #\a))
+(assert "check hiragana char" (eqv? #\¤¢ #\¤¢))
+
+(assert-eq? "check empty list" '() '())
+
+(define pair1 (cons 'a 'b))
+(define pair2 pair1)
+(assert-eq? "check cons" pair1 pair2)
+
+(define str1 (string #\a))
+(define str2 str1)
+(assert-eq? "check cons" str1 str2)
+
+(assert-eq? "check func" + +)
+
+(total-report)

Added: branches/r5rs/sigscheme/test/test-eval.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-eval.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/test-eval.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,8 @@
+(load "test/unittest.scm")
+
+;; check eval
+(assert-eq? "eval check" 3 (eval '(+ 1 2) '()))
+
+(assert-eq? "eval check" 3 (eval '((lambda (x y) (+ x y)) 1 2) '()))
+
+(total-report)

Added: branches/r5rs/sigscheme/test/test-exp.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-exp.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/test-exp.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,14 @@
+(load "test/unittest.scm")
+
+;; case
+(assert-eq? "case check" #t (case (* 2 3)
+			      ((2 3 4 7)   #f)
+			      ((1 4 6 8 9) #t)))
+
+(assert-eq? "case else check" 'elseworks (case 1
+					   ((3) 'a)
+					   ((4) 'b)
+					   (else
+					    'elseworks)))
+
+(total-report)

Added: branches/r5rs/sigscheme/test/test-let.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-let.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/test-let.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,17 @@
+(load "test/unittest.scm")
+
+(assert-eq? "basic let test1" 0 (let ((n 0))
+				 n))
+
+(assert-eq? "basic let test2" 1 (let ((n 0))
+				  (set! n 1)))
+
+(define count
+  (let ((n 0))
+    (lambda ()
+      (set! n (+ n 1)))))
+
+(assert-eq? "lexical scope test1" 1 (count))
+(assert-eq? "lexical scope test2" 2 (count))
+
+(total-report)

Added: branches/r5rs/sigscheme/test/test-num.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-num.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/test-num.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,10 @@
+(load "test/unittest.scm")
+
+(assert-eq? "= test" #t (= 1 1))
+(assert-eq? "+ test" 3  (+ 1 2))
+(assert-eq? "- test" -1 (- 1 2))
+(assert-eq? "* test" 2  (* 1 2))
+(assert-eq? "/ test" 0  (/ 1 2))
+(assert-eq? "/ test" -1 (/ -2 2))
+
+(total-report)

Added: branches/r5rs/sigscheme/test/test-string.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-string.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/test-string.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,88 @@
+(load "test/unittest.scm")
+
+;; check string?
+(assert "string? check" (string? "aiueo"))
+
+;; check make-string
+(assert "null make-string" (string? (make-string 6)))
+(assert "alphabet make-string check" (string=? "aaa" (make-string 3 #\a)))
+(assert "hiragana make-string check" (string=? "¤¢¤¢¤¢" (make-string 3 #\¤¢)))
+
+;; check string-ref
+(assert-eq? "alphabet string-ref check" #\o  (string-ref "aiueo" 4))
+(assert-eq? "hiragena string-ref check" #\¤ª (string-ref "¤¢¤¤¤¦¤¨¤ª" 4))
+(assert-eq? "mixed string-ref check"    #\¤ª (string-ref "¤¢iue¤ª" 4))
+(assert-eq? "alphabet string-ref 0 check" #\a  (string-ref "aiueo" 0))
+(assert-eq? "hiragena string-ref 0 check" #\¤¢ (string-ref "¤¢¤¤¤¦¤¨¤ª" 0))
+
+;; check string-set!
+(assert "alphabet string-set! check" (string=? "aikeo"
+					       (begin
+						 (define str "aiueo")
+						 (string-set! str 2 #\k)
+						 str)))
+(assert "hiragana string-set! check" (string=? "¤¢¤¤¤«¤¨¤ª"
+					       (begin
+						 (define str "¤¢¤¤¤¦¤¨¤ª")
+						 (string-set! str 2 #\¤«)
+						 str)))
+(assert "mixed string-set! check" (string=? "aiueo"
+					    (begin
+					      (define str "ai¤¦eo")
+					      (string-set! str 2 #\u)
+					      str)))
+
+;; check string-length
+(assert-eq? "alphabet string-length check" 5 (string-length "aiueo"))
+(assert-eq? "hiragana string-length check" 5 (string-length "¤¢¤¤¤¦¤¨¤ª"))
+
+;; string=? check
+(assert-eq? "alphabet string=? check" #t (string=? "aiueo" "aiueo"))
+(assert-eq? "hiragana string=? check" #t (string=? "¤¢¤¤¤¦¤¨¤ª" "¤¢¤¤¤¦¤¨¤ª"))
+(assert-eq? "mixed string=? check"    #t (string=? "a¤¤¤¦¤¨o" "a¤¤¤¦¤¨o"))
+
+
+;; substring check
+(assert "alphabet substring check" (string=? "iue"    (substring "aiueo" 1 3)))
+(assert "hiragana substring check" (string=? "¤¤¤¦¤¨" (substring "¤¢¤¤¤¦¤¨¤ª" 1 3)))
+(assert "mixed substring check"    (string=? "¤¤u¤¨"  (substring "a¤¤u¤¨o" 1 3)))
+
+
+;; string-append check
+(assert "alphabet 1 string-append check" (string=? "a"   (string-append "a")))
+(assert "alphabet 2 string-append check" (string=? "ai"  (string-append "a" "i")))
+(assert "alphabet 3 string-append check" (string=? "aiu" (string-append "a" "i" "u")))
+(assert "hiragana 1 string-append check" (string=? "¤¢"     (string-append "¤¢")))
+(assert "hiragana 2 string-append check" (string=? "¤¢¤¤"   (string-append "¤¢" "¤¤")))
+(assert "hiragana 3 string-append check" (string=? "¤¢¤¤¤¦" (string-append "¤¢" "¤¤" "¤¦")))
+(assert "mixed 2 string-append check" (string=? "¤¢i"   (string-append "¤¢" "i")))
+(assert "mixed 3 string-append check" (string=? "¤¢i¤¦" (string-append "¤¢" "i" "¤¦")))
+
+;; string->list
+; TODO : cannot write test now
+;(assert "string->list check" (string->list "¤¢i¤¦e¤ª"))
+
+
+;; list->string
+(assert "list->string check" (string=? "¤¢a¤¤" (list->string '(#\¤¢ #\a #\¤¤))))
+
+
+;; string-fill!
+(assert "alphabet string-fill! check" (string=? "jjjjj" (begin
+							  (define str "aiueo")
+							  (string-fill! str #\j)
+							  str)))
+(assert "hiragana string-fill! check" (string=? "¤¢¤¢¤¢¤¢¤¢" (begin
+							       (define str "aiueo")
+							       (string-fill! str #\¤¢)
+							       str)))
+(assert "mixed string-fill! by alphabet check" (string=? "aaaaa" (begin
+								   (define str "a¤¤¤¦¤¨o")
+								   (string-fill! str #\a)
+								   str)))
+(assert "mixed string-fill! by hiragana check" (string=? "¤¤¤¤¤¤¤¤¤¤" (begin
+									(define str "a¤¤¤¦¤¨o")
+									(string-fill! str #\¤¤)
+									str)))
+
+(total-report)

Added: branches/r5rs/sigscheme/test/unittest.scm
===================================================================
--- branches/r5rs/sigscheme/test/unittest.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/unittest.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,36 @@
+(define total-err-num  0)
+(define total-test-num 0)
+(define test-filename "unspecified")
+
+(define total-report
+  (lambda ()
+    (begin
+;      (print "total")
+;      (print total-test-num)
+      (if (= total-err-num 0)
+	  (print "OK\n")
+	  (begin
+	    (print "[ ERROR !! ]\n")
+	    (print total-err-num)
+	    (print "\n"))))))
+
+(define report-error
+  (lambda (errmsg)
+    (begin
+      (print "error")
+      (print errmsg))))
+
+(define assert
+  (lambda (msg exp)
+    (begin
+      (set! total-test-num (+ total-test-num 1))
+      (if (exp)
+	  #t
+	  (begin
+	    (set! total-err-num (+ total-err-num 1))
+	    (report-error msg)
+	    #f)))))
+
+(define assert-eq?
+  (lambda (msg a b)
+    (assert msg (eq? a b))))

Added: branches/r5rs/sigscheme/test/vector.scm
===================================================================
--- branches/r5rs/sigscheme/test/vector.scm	2005-07-17 19:28:50 UTC (rev 972)
+++ branches/r5rs/sigscheme/test/vector.scm	2005-07-17 21:10:29 UTC (rev 973)
@@ -0,0 +1,15 @@
+(define vec (vector 'a 'b 'c 'd))
+
+(print vec)
+(print (vector? vec))
+(print (vector-length vec))
+(print (vector-ref vec 3))
+(vector-set! vec 3 #t)
+(print vec)
+(print (vector->list vec))
+(print (list->vector (vector->list vec)))
+(vector-fill! vec #f)
+(print vec)
+
+(print (make-vector 3))
+(print (make-vector 3 #f))



More information about the uim-commit mailing list