[uim-commit] r1009 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Sat Jul 23 11:11:17 EST 2005
Author: kzk
Date: 2005-07-22 18:11:14 -0700 (Fri, 22 Jul 2005)
New Revision: 1009
Added:
branches/r5rs/sigscheme/operations-srfi1.c
branches/r5rs/sigscheme/test/test-srfi1.scm
Modified:
branches/r5rs/sigscheme/datas.c
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
Log:
* Add srfi-1 procedures. now we get "Constructors" procedure.
Reference : http://srfi.schemers.org/srfi-1/srfi-1.html
* sigscheme/sigscheme.h
- (USE_SRFI1)
: new compilation flag
- (ScmOp_SRFI_1_xcons,
ScmOp_SRFI_1_cons_star,
ScmOp_SRFI_1_make_list,
ScmOp_SRFI_1_list_tabulate,
ScmOp_SRFI_1_list_copy,
ScmOp_SRFI_1_circular_list,
ScmOp_SRFI_1_iota)
: new func;
- (ScmNewStringCopying)
: add "const" quolifier
* sigscheme/operations-srfi1.c
- new file
* sigscheme/test/test-srfi1.scm
- new testcases for "Constructors" procedure.
* sigscheme/operations.c
- include "operations-srfi1.c" when USE_SRFI1 flag is avtivated
* sigscheme/datas.c
- (ScmNewStringCopying)
: add "const" quolifier
Modified: branches/r5rs/sigscheme/datas.c
===================================================================
--- branches/r5rs/sigscheme/datas.c 2005-07-22 04:16:17 UTC (rev 1008)
+++ branches/r5rs/sigscheme/datas.c 2005-07-23 01:11:14 UTC (rev 1009)
@@ -606,7 +606,7 @@
return obj;
}
-ScmObj Scm_NewStringCopying(char *str)
+ScmObj Scm_NewStringCopying(const char *str)
{
ScmObj obj = SCM_NIL;
Added: branches/r5rs/sigscheme/operations-srfi1.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi1.c 2005-07-22 04:16:17 UTC (rev 1008)
+++ branches/r5rs/sigscheme/operations-srfi1.c 2005-07-23 01:11:14 UTC (rev 1009)
@@ -0,0 +1,259 @@
+/*===========================================================================
+ * FileName : operations-srfi1.c
+ * About : srfi1 procedures
+ *
+ * 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
+=======================================*/
+static ScmObj list_gettailcons(ScmObj head)
+{
+ if (SCM_NULLP(head))
+ return SCM_NIL;
+ if (SCM_NULLP(SCM_CDR(head)))
+ return head;
+
+ for (; !SCM_NULLP(head); head = SCM_CDR(head)) {
+ if (SCM_NULLP(SCM_CDR(head)))
+ return head;
+ }
+
+ SigScm_Error("list_gettailcons : cannot get tailcons?\n");
+ return SCM_NIL;
+}
+
+/*=======================================
+ Function Implementations
+=======================================*/
+/*==============================================================================
+ SRFI1 : The procedures : Constructors
+==============================================================================*/
+ScmObj ScmOp_SRFI_1_xcons(ScmObj a, ScmObj b)
+{
+ return Scm_NewCons(b, a);
+}
+
+ScmObj ScmOp_SRFI_1_cons_star(ScmObj obj, ScmObj env)
+{
+ ScmObj tail_cons = SCM_NIL;
+ ScmObj prev_tail = obj;
+
+ if (SCM_NULLP(SCM_CDR(obj)))
+ return SCM_CAR(obj);
+
+ for (tail_cons = SCM_CDR(obj); !SCM_NULLP(tail_cons); tail_cons = SCM_CDR(tail_cons)) {
+ /* check tail cons cell */
+ if (SCM_NULLP(SCM_CDR(tail_cons))) {
+ SCM_SETCDR(prev_tail, SCM_CAR(tail_cons));
+ }
+
+ prev_tail = tail_cons;
+ }
+
+ return obj;
+}
+
+ScmObj ScmOp_SRFI_1_make_list(ScmObj args, ScmObj env)
+{
+ ScmObj fill = SCM_NIL;
+ ScmObj head = SCM_NIL;
+ int n = 0;
+ int i = 0;
+
+ /* sanity check */
+ if CHECK_1_ARG(args)
+ SigScm_Error("make-llist : require at least 1 arg\n");
+ if (EQ(ScmOp_numberp(SCM_CAR(args)), SCM_FALSE))
+ SigScm_ErrorObj("make-list : number required but got ", SCM_CAR(args));
+
+ /* get n */
+ n = SCM_INT_VALUE(SCM_CAR(args));
+
+ /* get filler if available */
+ if (!SCM_NULLP(SCM_CDR(args)))
+ fill = SCM_CAR(SCM_CDR(args));
+
+ /* then create list */
+ for (i = n; 0 < i; i--) {
+ if (!SCM_NULLP(fill))
+ head = Scm_NewCons(fill, head);
+ else
+ head = Scm_NewCons(Scm_NewInt(i), head);
+ }
+
+ return head;
+}
+
+ScmObj ScmOp_SRFI_1_list_tabulate(ScmObj args, ScmObj env)
+{
+ ScmObj scm_n = SCM_CAR(args);
+ ScmObj proc = SCM_NIL;
+ ScmObj head = SCM_NIL;
+ ScmObj num = SCM_NIL;
+ int n = 0;
+ int i = 0;
+
+ /* sanity check */
+ if (EQ(ScmOp_numberp(scm_n), SCM_FALSE))
+ SigScm_ErrorObj("list-tabulate : number required but got ", scm_n);
+
+ /* get n */
+ n = SCM_INT_VALUE(scm_n);
+
+ /* get init_proc if available */
+ if (!SCM_NULLP(SCM_CDR(args)))
+ proc = SCM_CAR(SCM_CDR(args));
+
+ /* then create list */
+ for (i = n; 0 < i; i--) {
+ num = Scm_NewInt(i - 1);
+
+ if (!SCM_NULLP(proc)) {
+ /* evaluate (proc num) */
+ num = ScmOp_eval(Scm_NewCons(proc,
+ Scm_NewCons(num, SCM_NIL)),
+ env);
+ }
+
+ head = Scm_NewCons(num, head);
+ }
+
+ return head;
+}
+
+ScmObj ScmOp_SRFI_1_list_copy(ScmObj list)
+{
+ ScmObj head = SCM_NIL;
+ ScmObj tail = SCM_NIL;
+ ScmObj obj = SCM_NIL;
+
+ if (EQ(ScmOp_listp(list), SCM_FALSE))
+ SigScm_ErrorObj("list-copy : list required but got ", list);
+
+ for (; !SCM_NULLP(list); list = SCM_CDR(list)) {
+ obj = SCM_CAR(list);
+
+ /* further copy */
+ if (SCM_CONSP(obj))
+ obj = ScmOp_SRFI_1_list_copy(obj);
+
+ /* then create new cons */
+ obj = Scm_NewCons(obj, SCM_NIL);
+ if (!SCM_NULLP(tail)) {
+ SCM_SETCDR(tail, obj);
+ tail = obj;
+ } else {
+ head = obj;
+ tail = head;
+ }
+ }
+
+ return head;
+}
+
+ScmObj ScmOp_SRFI_1_circular_list(ScmObj list, ScmObj env)
+{
+ ScmObj tailcons = SCM_NIL;
+
+ if (EQ(ScmOp_listp(list), SCM_FALSE))
+ SigScm_ErrorObj("circular-list : list required but got ", list);
+
+ tailcons = list_gettailcons(list);
+ SCM_SETCDR(tailcons, list);
+
+ return list;
+}
+
+ScmObj ScmOp_SRFI_1_iota(ScmObj args, ScmObj env)
+{
+ ScmObj scm_count = SCM_NIL;
+ ScmObj scm_start = SCM_NIL;
+ ScmObj scm_step = SCM_NIL;
+ ScmObj head = SCM_NIL;
+ int count = 0;
+ int start = 0;
+ int step = 0;
+ int i = 0;
+
+ /* sanity check */
+ if CHECK_1_ARG(args)
+ SigScm_Error("iota : required at least 1 arg\n");
+
+ /* get params */
+ scm_count = SCM_CAR(args);
+
+ if (!SCM_NULLP(SCM_CDR(args)))
+ scm_start = SCM_CAR(SCM_CDR(args));
+
+ if (!SCM_NULLP(scm_start) && !SCM_NULLP(SCM_CDR(SCM_CDR(args))))
+ scm_step = SCM_CAR(SCM_CDR(SCM_CDR(args)));
+
+ /* param type check */
+ if (EQ(ScmOp_numberp(scm_count), SCM_FALSE))
+ SigScm_ErrorObj("iota : number required but got ", scm_count);
+
+ if (!SCM_NULLP(scm_start) && EQ(ScmOp_numberp(scm_start), SCM_FALSE))
+ SigScm_ErrorObj("iota : number required but got ", scm_start);
+
+ if (!SCM_NULLP(scm_step) && EQ(ScmOp_numberp(scm_step), SCM_FALSE))
+ SigScm_ErrorObj("iota : number required but got ", scm_step);
+
+ /* now create list */
+ count = SCM_INT_VALUE(scm_count);
+ start = SCM_NULLP(scm_start) ? 0 : SCM_INT_VALUE(scm_start);
+ step = SCM_NULLP(scm_step) ? 1 : SCM_INT_VALUE(scm_step);
+ for (i = count - 1; 0 <= i; i--) {
+ head = Scm_NewCons(Scm_NewInt(start + i*step), head);
+ }
+
+ return head;
+}
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-07-22 04:16:17 UTC (rev 1008)
+++ branches/r5rs/sigscheme/operations.c 2005-07-23 01:11:14 UTC (rev 1009)
@@ -893,7 +893,7 @@
return ScmOp_cdr( ScmOp_cdr( ScmOp_cdr( ScmOp_cdr(pair) )));
}
-ScmObj ScmOp_list(ScmObj obj, ScmObj env )
+ScmObj ScmOp_list(ScmObj obj, ScmObj env)
{
return obj;
}
@@ -1757,7 +1757,6 @@
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 */
@@ -1855,3 +1854,7 @@
return ScmOp_eval(arg, env);
}
+
+#if USE_SRFI1
+#include "operations-srfi1.c"
+#endif
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-07-22 04:16:17 UTC (rev 1008)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-07-23 01:11:14 UTC (rev 1009)
@@ -256,7 +256,6 @@
Scm_InitSubrL("newline" , ScmOp_newline);
Scm_InitSubrL("write-char" , ScmOp_write_char);
Scm_InitSubr1("load" , ScmOp_load);
-
/*=======================================================================
Current Input & Output Initialization
=======================================================================*/
@@ -265,6 +264,19 @@
current_output_port = Scm_NewFilePort(stdout, PORT_OUTPUT);
SigScm_gc_protect(current_output_port);
+#if USE_SRFI1
+ /*=======================================================================
+ SRFI-1 Procedures
+ =======================================================================*/
+ Scm_InitSubr2("xcons" , ScmOp_SRFI_1_xcons);
+ Scm_InitSubrL("cons*" , ScmOp_SRFI_1_cons_star);
+ Scm_InitSubrL("make-list" , ScmOp_SRFI_1_make_list);
+ Scm_InitSubrL("list-tabulate" , ScmOp_SRFI_1_list_tabulate);
+ Scm_InitSubr1("list-copy" , ScmOp_SRFI_1_list_copy);
+ Scm_InitSubrL("circular-list" , ScmOp_SRFI_1_circular_list);
+ Scm_InitSubrL("iota" , ScmOp_SRFI_1_iota);
+#endif
+
stack_start_pointer = NULL;
}
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-07-22 04:16:17 UTC (rev 1008)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-07-23 01:11:14 UTC (rev 1009)
@@ -71,6 +71,7 @@
#define DEBUG_PARSER 0
#define DEBUG_GC 0
#define USE_EUCJP 1
+#define USE_SRFI1 1
#define CHECK_1_ARG(arg) \
(SCM_NULLP(arg))
@@ -120,7 +121,7 @@
ScmObj Scm_NewSymbol(char *name, ScmObj v_cell);
ScmObj Scm_NewChar(char *ch);
ScmObj Scm_NewString(char *str);
-ScmObj Scm_NewStringCopying(char *str);
+ScmObj Scm_NewStringCopying(const 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);
@@ -137,7 +138,6 @@
C_FUNC Scm_GetCFuncPointer(ScmObj c_funcptr);
ScmObj Scm_eval_c_string(const char *exp);
-
/* eval.c */
ScmObj ScmOp_eval(ScmObj obj, ScmObj env);
ScmObj ScmOp_apply(ScmObj arg, ScmObj env);
@@ -327,6 +327,16 @@
void SigScm_Display(ScmObj obj);
void SigScm_DisplayToPort(ScmObj port, ScmObj obj);
+#if USE_SRFI1
+ScmObj ScmOp_SRFI_1_xcons(ScmObj a, ScmObj b);
+ScmObj ScmOp_SRFI_1_cons_star(ScmObj obj, ScmObj env);
+ScmObj ScmOp_SRFI_1_make_list(ScmObj obj, ScmObj env);
+ScmObj ScmOp_SRFI_1_list_tabulate(ScmObj arg, ScmObj env);
+ScmObj ScmOp_SRFI_1_list_copy(ScmObj list);
+ScmObj ScmOp_SRFI_1_circular_list(ScmObj list, ScmObj env);
+ScmObj ScmOp_SRFI_1_iota(ScmObj args, ScmObj env);
+#endif
+
#ifdef __cplusplus
}
#endif
Added: branches/r5rs/sigscheme/test/test-srfi1.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi1.scm 2005-07-22 04:16:17 UTC (rev 1008)
+++ branches/r5rs/sigscheme/test/test-srfi1.scm 2005-07-23 01:11:14 UTC (rev 1009)
@@ -0,0 +1,37 @@
+(load "test/unittest.scm")
+
+; xcons
+(assert-equal? "xcons test1" '(a b c) (xcons '(b c) 'a))
+
+; cons*
+(assert-equal? "cons* test1" '(1 2 3 . 4) (cons* 1 2 3 4))
+(assert-equal? "cons* test2" 1 (cons* 1))
+
+; make-list
+(assert-equal? "make-list test1" '(c c c c) (make-list 4 'c))
+(assert-equal? "make-list test2" '(1 2 3 4) (make-list 4))
+(assert-equal? "make-list test2" '() (make-list 0 'c))
+(assert-equal? "make-list test2" '() (make-list 0))
+
+; list-tabulate
+(assert-equal? "list-tabulate test1" '(0 1 2 3) (list-tabulate 4 (lambda (x) x)))
+(assert-equal? "list-tabulate test2" '(1 2 3 4) (list-tabulate 4 (lambda (x) (+ x 1))))
+(assert-equal? "list-tabulate test2" '() (list-tabulate 0 (lambda (x) (+ x 1))))
+
+; list-copy
+(assert-equal? "list-copy test1" '(1 2 3 4) (list-copy (list 1 2 3 4)))
+(assert-equal? "list-copy test2" '(1 2 (3 4)) (list-copy (list 1 2 (list 3 4))))
+(assert-equal? "list-copy test3" '() (list-copy '()))
+
+;(display (circular-list '1 '2 '3 '4))
+
+; iota
+(assert-equal? "iota test1" '(0 1 2 3 4) (iota 5))
+(assert-equal? "iota test2" '(1 2 3 4 5) (iota 5 1))
+(assert-equal? "iota test3" '(1 2 3 4 5) (iota 5 1 1))
+(assert-equal? "iota test4" '(1 3 5 7 9) (iota 5 1 2))
+(assert-equal? "iota test5" '() (iota 0))
+(assert-equal? "iota test6" '(-1 0 1) (iota 3 -1 1))
+(assert-equal? "iota test7" '(-3 -1 1 3) (iota 4 -3 2))
+
+(total-report)
More information about the uim-commit
mailing list