[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