mes: Add take-while.
[mes.git] / mes / module / srfi / srfi-1.mes
index 84bf44b6dcc50bec2287056e870b3a2912f99c71..8a69b7bce403793e179c832da8fdb306bdd93ef7 100644 (file)
       (let loop ((lst lst1))
         (if (null? lst) init
             (proc (car lst) (loop (cdr lst)))))
       (let loop ((lst lst1))
         (if (null? lst) init
             (proc (car lst) (loop (cdr lst)))))
-      (error "FOLD-RIGHT-2-NOT-SUPPORTED")))
+      (if (null? (cdr rest))
+          (let loop ((lst1 lst1) (lst2 (car rest)))
+            (if (or (null? lst1)
+                    (null? lst2)) init
+                    (proc (car lst1) (car lst2) (loop (cdr lst1) (cdr lst2)))))
+          (let loop ((lst1 lst1) (lst2 (car rest)) (lst3 (cadr rest)))
+            (if (or (null? lst1)
+                    (null? lst2)
+                    (null? lst3)) init
+                    (proc (car lst1) (car lst2) (car lst3) (loop (cdr lst1) (cdr lst2) (cdr lst3)))))
+          (error "FOLD-RIGHT-4-NOT-SUPPORTED"))))
 
 (define (unfold p f g seed . rest)
   (let ((tail-gen (if (null? rest) (const '())
 
 (define (unfold p f g seed . rest)
   (let ((tail-gen (if (null? rest) (const '())
                 (cons (car lst) (loop (cdr lst))))))))
 
 (include-from-path "srfi/srfi-1.scm")
                 (cons (car lst) (loop (cdr lst))))))))
 
 (include-from-path "srfi/srfi-1.scm")
+
+(define (take-while pred lst)
+  (if (or (null? lst) (not (pred (car lst)))) '()
+          (cons (car lst) (take-while pred (cdr lst)))))