[uim-commit] r1281 - in branches/r5rs: scm sigscheme test uim
kzk at freedesktop.org
kzk at freedesktop.org
Mon Aug 22 09:56:48 PDT 2005
Author: kzk
Date: 2005-08-22 09:56:46 -0700 (Mon, 22 Aug 2005)
New Revision: 1281
Modified:
branches/r5rs/scm/util.scm
branches/r5rs/sigscheme/eval.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/test/test-uim-util.scm
branches/r5rs/uim/uim-scm.c
branches/r5rs/uim/uim-util.c
Log:
* uim/uim-util.c
* test/test-uim-util.scm
- apply r1274
* uim/uim-scm.c
- (uim_scm_c_symbol): optimize
- (uim_scm_eq, uim_scm_string_equal): use SCM_EQ instead of EQ
* scm/util.scm
- restore SRFI procedures and disable SLIB procedures
* sigscheme/sigscheme.c
- (SigScm_Initialize): #f == () when SCM_COMPAT_SIOD_BUGS is enabled
* sigscheme/sigscheme.h
- (SCM_STRICT_ARGCHECK): new macro
* sigscheme/eval.c
- (ScmExp_let, ScmExp_let_star, ScmExp_letrec): not strict binding
check is introduced for SIOD compatibility
Modified: branches/r5rs/scm/util.scm
===================================================================
--- branches/r5rs/scm/util.scm 2005-08-22 12:39:24 UTC (rev 1280)
+++ branches/r5rs/scm/util.scm 2005-08-22 16:56:46 UTC (rev 1281)
@@ -28,8 +28,8 @@
;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;; SUCH DAMAGE.
;;;;
-(require "slib-mulapply.scm")
-(require "slib-srfi-1.scm")
+;(require "slib-mulapply.scm")
+;(require "slib-srfi-1.scm")
;; Current uim implementation treats char as integer
@@ -325,6 +325,64 @@
;;
;; SRFI procedures (don't expect 100% compatibility)
;;
+(define list-tabulate
+ (lambda (n init-proc)
+ (if (< n 0)
+ (error "bad length for list-tabulate")
+ (let self ((i (- n 1))
+ (res ()))
+ (if (< i 0)
+ res
+ (self (- i 1)
+ (cons (init-proc i) res)))))))
+
+;; This procedure does not conform to the SRFI-1 specification. The
+;; argument 'fill' is required.
+(define make-list
+ (lambda (n fill)
+ (list-tabulate n
+ (lambda (i)
+ fill))))
+
+;; This procedure does not conform to the SRFI-1 specification. The
+;; optional argument 'step' is not supported.
+(define iota
+ (lambda args
+ (let ((count (car args))
+ (start (if (not (null? (cdr args)))
+ (cadr args)
+ 0)))
+ (list-tabulate (- count start)
+ (lambda (i)
+ (+ start i))))))
+
+;; TODO: write test
+(define last
+ (lambda (lst)
+ (car (last-pair lst))))
+
+;; only accepts 2 lists
+;; TODO: write test
+(define append! nconc)
+
+(define concatenate
+ (lambda (lists)
+ (apply append lists)))
+
+(define concatenate!
+ (lambda (lists)
+ ;;(fold-right append! () lists)
+ (fold append! () (reverse lists))))
+
+(define zip
+ (lambda lists
+ (let ((runs-out? (apply proc-or (map null? lists))))
+ (if runs-out?
+ ()
+ (let* ((elms (map car lists))
+ (rests (map cdr lists)))
+ (cons elms (apply zip rests)))))))
+
(define last-pair
(lambda (lst)
(if (pair? (cdr lst))
@@ -335,6 +393,137 @@
(lambda args
(concatenate! (apply map args))))
+(define append-reverse
+ (lambda (rev-head tail)
+ (fold cons tail rev-head)))
+
+(define find
+ (lambda (f lst)
+ (cond
+ ((null? lst)
+ #f)
+ ((f (car lst))
+ (car lst))
+ (else
+ (find f (cdr lst))))))
+
+;; TODO: write test
+;; replaced with faster C version
+;;(define find-tail
+;; (lambda (pred lst)
+;; (cond
+;; ((null? lst)
+;; #f)
+;; ((pred (car lst))
+;; lst)
+;; (else
+;; (find-tail pred (cdr lst))))))
+
+(define any
+ (lambda args
+ (let* ((pred (car args))
+ (lists (cdr args)))
+ (iterate-lists (lambda (state elms)
+ (if (null? elms)
+ '(#t . #f)
+ (let ((res (apply pred elms)))
+ (cons res res))))
+ #f lists))))
+
+(define every
+ (lambda args
+ (let* ((pred (car args))
+ (lists (cdr args)))
+ (iterate-lists (lambda (state elms)
+ (if (null? elms)
+ '(#t . #t)
+ (let ((res (apply pred elms)))
+ (cons (not res) res))))
+ #f lists))))
+
+(define fold
+ (lambda args
+ (let* ((kons (car args))
+ (knil (cadr args))
+ (lists (cddr args)))
+ (iterate-lists (lambda (state elms)
+ (if (null? elms)
+ (cons #t state)
+ (cons #f (apply kons (append elms (list state))))))
+ knil lists))))
+
+(define unfold
+ (lambda args
+ (let ((term? (nth 0 args))
+ (kar (nth 1 args))
+ (kdr (nth 2 args))
+ (seed (nth 3 args))
+ (tail-gen (if (= (length args)
+ 5)
+ (nth 4 args)
+ (lambda (x) ()))))
+ (if (term? seed)
+ (tail-gen seed)
+ (cons (kar seed)
+ (unfold term? kar kdr (kdr seed) tail-gen))))))
+
+(define filter
+ (lambda args
+ (let ((pred (car args))
+ (lst (cadr args)))
+ (iterate-lists (lambda (state elms)
+ (if (null? elms)
+ (cons #t (reverse state))
+ (let ((elm (car elms)))
+ (cons #f (if (pred elm)
+ (cons elm state)
+ state)))))
+ () (list lst)))))
+
+(define filter-map
+ (lambda args
+ (let ((f (car args))
+ (lists (cdr args)))
+ (iterate-lists (lambda (state elms)
+ (if (null? elms)
+ (cons #t (reverse state))
+ (let ((mapped (apply f elms)))
+ (cons #f (if mapped
+ (cons mapped state)
+ state)))))
+ () lists))))
+
+(define remove
+ (lambda (pred lst)
+ (filter (lambda (elm)
+ (not (pred elm)))
+ lst)))
+
+;; TODO: write test
+(define delete
+ (lambda args
+ (let ((x (car args))
+ (lst (cadr args))
+ (val=? (if (null? (cddr args))
+ equal?
+ (car (cddr args)))))
+ (filter (lambda (elm)
+ (not (val=? elm x)))
+ lst))))
+
+(define alist-delete
+ (lambda args
+ (let ((key (car args))
+ (alist (cadr args))
+ (key=? (if (null? (cddr args))
+ equal?
+ (car (cddr args)))))
+ (remove (lambda (elm)
+ (key=? (car elm)
+ key))
+ alist))))
+
+
;; SRFI-60 procedures
;; Siod's bit operation procedures take only two arguments
;; TODO: write tests
Modified: branches/r5rs/sigscheme/eval.c
===================================================================
--- branches/r5rs/sigscheme/eval.c 2005-08-22 12:39:24 UTC (rev 1280)
+++ branches/r5rs/sigscheme/eval.c 2005-08-22 16:56:46 UTC (rev 1281)
@@ -1255,8 +1255,14 @@
if (CONSP(bindings) || NULLP(bindings)) {
for (; !NULLP(bindings); bindings = CDR(bindings)) {
binding = CAR(bindings);
+
+#if SCM_STRICT_ARGCHECK
if (NULLP(binding) || NULLP(CDR(binding)))
SigScm_ErrorObj("let : invalid binding form : ", binding);
+#else
+ if (NULLP(CDR(binding)))
+ SET_CDR(binding, Scm_NewCons(SCM_NIL, SCM_NIL));
+#endif
vars = Scm_NewCons(CAR(binding), vars);
vals = Scm_NewCons(ScmOp_eval(CAR(CDR(binding)), env), vals);
@@ -1328,8 +1334,14 @@
if (CONSP(bindings)) {
for (; !NULLP(bindings); bindings = CDR(bindings)) {
binding = CAR(bindings);
+
+#if SCM_STRICT_ARGCHECK
if (NULLP(binding) || NULLP(CDR(binding)))
SigScm_ErrorObj("let* : invalid binding form : ", binding);
+#else
+ if (NULLP(CDR(binding)))
+ SET_CDR(binding, Scm_NewCons(SCM_NIL, SCM_NIL));
+#endif
vars = Scm_NewCons(CAR(binding), SCM_NIL);
vals = Scm_NewCons(ScmOp_eval(CAR(CDR(binding)), env), SCM_NIL);
@@ -1388,8 +1400,14 @@
if (CONSP(bindings) || NULLP(bindings)) {
for (; !NULLP(bindings); bindings = CDR(bindings)) {
binding = CAR(bindings);
+
+#if SCM_STRICT_ARGCHECK
if (NULLP(binding) || NULLP(CDR(binding)))
SigScm_ErrorObj("letrec : invalid binding form : ", binding);
+#else
+ if (NULLP(CDR(binding)))
+ SET_CDR(binding, Scm_NewCons(SCM_NIL, SCM_NIL));
+#endif
var = CAR(binding);
val = CAR(CDR(binding));
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-08-22 12:39:24 UTC (rev 1280)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-08-22 16:56:46 UTC (rev 1281)
@@ -88,6 +88,11 @@
SCM_NEW_ETC(SigScm_eof, SigScm_eof_impl, 4);
SCM_NEW_ETC(SigScm_unbound, SigScm_unbound_impl, 9);
SCM_NEW_ETC(SigScm_undef, SigScm_undef_impl, 10);
+
+#if SCM_COMPAT_SIOD_BUGS
+ SigScm_false = SigScm_nil;
+#endif
+
/*=======================================================================
Externed Variable Initialization
=======================================================================*/
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-08-22 12:39:24 UTC (rev 1280)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-08-22 16:56:46 UTC (rev 1281)
@@ -72,6 +72,7 @@
#define SCM_COMPAT_SIOD 1 /* use SIOD compatible features */
#define SCM_COMPAT_SIOD_BUGS 1 /* enable SIOD buggy features */
#define SCM_STRICT_R5RS 0 /* use strict R5RS check */
+#define SCM_STRICT_ARGCHECK 0 /* enable strict argument check */
int SigScm_Die(const char *msg, const char *filename, int line); /* error.c */
#define sigassert(cond) \
Modified: branches/r5rs/test/test-uim-util.scm
===================================================================
--- branches/r5rs/test/test-uim-util.scm 2005-08-22 12:39:24 UTC (rev 1280)
+++ branches/r5rs/test/test-uim-util.scm 2005-08-22 16:56:46 UTC (rev 1281)
@@ -29,7 +29,7 @@
;;; SUCH DAMAGE.
;;;;
-;; This file is tested with revision 816 of new repository
+;; This file is tested with revision 1274 of new repository
(use test.unit)
@@ -269,6 +269,32 @@
(assert-equal "2147483647" (uim '(digit->string 2147483647))))
("test iterate-lists"
+ ;; single list cases (fast path)
+ (assert-equal '(4 3 2 1 0)
+ (uim '(iterate-lists (lambda (state elms)
+ (if (null? elms)
+ (cons #t state)
+ (cons #f (cons (car elms)
+ state))))
+ ()
+ '((0 1 2 3 4)))))
+ (assert-equal '()
+ (uim '(iterate-lists (lambda (state elms)
+ (if (null? elms)
+ (cons #t state)
+ (cons #f (cons (car elms)
+ state))))
+ ()
+ '(()))))
+ (assert-equal 'empty
+ (uim '(iterate-lists (lambda (state elms)
+ (if (null? elms)
+ (cons #t state)
+ (cons #f (cons (car elms)
+ state))))
+ 'empty
+ '(()))))
+ ;; multiple lists cases (normal path)
(assert-equal '(("o" . "O") ("l" . "L") ("l" . "L") ("e" . "E") ("h" . "H"))
(uim '(iterate-lists (lambda (state elms)
(if (null? elms)
@@ -277,7 +303,34 @@
state))))
()
'(("h" "e" "l" "l" "o")
- ("H" "E" "L" "L" "O" "!"))))))
+ ("H" "E" "L" "L" "O" "!")))))
+ (assert-equal '(("o" "O" 4) ("l" "L" 3) ("l" "L" 2) ("e" "E" 1) ("h" "H" 0))
+ (uim '(iterate-lists (lambda (state elms)
+ (if (null? elms)
+ (cons #t state)
+ (cons #f (cons elms state))))
+ ()
+ '(("h" "e" "l" "l" "o")
+ ("H" "E" "L" "L" "O" "!")
+ (0 1 2 3 4)))))
+ (assert-equal ()
+ (uim '(iterate-lists (lambda (state elms)
+ (if (null? elms)
+ (cons #t state)
+ (cons #f (cons elms state))))
+ ()
+ '(("h" "e" "l" "l" "o")
+ ()
+ (0 1 2 3 4)))))
+ (assert-equal 'empty
+ (uim '(iterate-lists (lambda (state elms)
+ (if (null? elms)
+ (cons #t state)
+ (cons #f (cons elms state))))
+ 'empty
+ '(("h" "e" "l" "l" "o")
+ ()
+ (0 1 2 3 4))))))
;; compare string sequence
("test str-seq-equal?"
Modified: branches/r5rs/uim/uim-scm.c
===================================================================
--- branches/r5rs/uim/uim-scm.c 2005-08-22 12:39:24 UTC (rev 1280)
+++ branches/r5rs/uim/uim-scm.c 2005-08-22 16:56:46 UTC (rev 1281)
@@ -134,7 +134,7 @@
char *
uim_scm_c_symbol(uim_lisp symbol)
{
- return Scm_GetString(ScmOp_symbol_to_string((ScmObj)symbol));
+ return strdup((char*)SCM_SYMBOL_NAME((ScmObj)symbol));
}
uim_lisp
@@ -283,7 +283,7 @@
uim_bool
uim_scm_eq(uim_lisp a, uim_lisp b)
{
- if (EQ(ScmOp_eqp((ScmObj) a, (ScmObj) b), SigScm_true))
+ if (SCM_EQ(ScmOp_eqp((ScmObj) a, (ScmObj) b), SigScm_true))
return UIM_TRUE;
return UIM_FALSE;
@@ -292,7 +292,7 @@
uim_bool
uim_scm_string_equal(uim_lisp a, uim_lisp b)
{
- if(EQ(ScmOp_string_equal((ScmObj)a, (ScmObj)b), SigScm_true))
+ if(SCM_EQ(ScmOp_string_equal((ScmObj)a, (ScmObj)b), SigScm_true))
return UIM_TRUE;
return UIM_FALSE;
Modified: branches/r5rs/uim/uim-util.c
===================================================================
--- branches/r5rs/uim/uim-util.c 2005-08-22 12:39:24 UTC (rev 1280)
+++ branches/r5rs/uim/uim-util.c 2005-08-22 16:56:46 UTC (rev 1281)
@@ -508,7 +508,7 @@
uim_lisp elms, rest, rests, mapped, res, termp, pair, form;
uim_bool single_listp;
- single_listp = (uim_scm_c_int(uim_scm_length(lists)) == 1) ? UIM_TRUE : UIM_FALSE;
+ single_listp = uim_scm_nullp(uim_scm_cdr(lists));
res = seed;
if (single_listp) {
rest = uim_scm_car(lists);
@@ -518,8 +518,12 @@
do {
if (single_listp) {
/* fast path */
- elms = uim_scm_list1(uim_scm_car(rest));
- rest = uim_scm_cdr(rest);
+ if (uim_scm_nullp(rest)) {
+ elms = uim_scm_null_list();
+ } else {
+ elms = uim_scm_list1(uim_scm_car(rest));
+ rest = uim_scm_cdr(rest);
+ }
} else {
pair = shift_elems(rests);
if (FALSEP(pair)) {
More information about the uim-commit
mailing list