;;;; srfi-1.scm --- SRFI-1 procedures for Guile
;;;;
;;;; Copyright (C) 2001 Free Software Foundation, Inc.
-;;;;
+;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License as
;;;; published by the Free Software Foundation; either version 2, or
;;;; (at your option) any later version.
-;;;;
+;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; General Public License for more details.
-;;;;
+;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this software; see the file COPYING. If not, write to
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
:use-module (ice-9 session)
:use-module (ice-9 receive))
-(export
+(export
;;; Constructors
;; cons <= in the core
;; list <= in the core
((not-pair? hare) #t)
(else
(let ((hare (cdr hare)))
- (cond
+ (cond
((null? hare) #f)
((not-pair? hare) #t)
((eq? hare tortoise) #f)
(define (null-list? x)
(cond
- ((proper-list? x)
+ ((proper-list? x)
(null? x))
((circular-list? x)
#f)
s
(lp0 (cdr s) (cdr l))))
(lp (- n 1) (cdr l)))))
-
+
(define (drop-right flist i)
(let lp ((n i) (l flist))
(if (<= n 0)
'()
(let lp ((n (- i 1)) (l x))
(if (<= n 0)
- (begin
+ (begin
(set-cdr! l '())
x)
(lp (- n 1) (cdr l))))))
(begin
(set-cdr! ntail (car l))
(lp (cdr l) (last-pair ntail))))))))))
-
+
(define (append-reverse rev-head tail)
(let lp ((l rev-head) (acc tail))
(if (any null? l)
(reverse! acc)
(lp (map1 cdr l) (cons (map1 car l) acc)))))
-
+
(define (unzip1 l)
(map1 first l))
(lp (map1 cdr lists))))))))
(define (count1 pred clist)
- (if (null? clist)
- 0
- (if (pred (car clist))
- (+ 1 (count1 pred (cdr clist)))
- (count1 pred (cdr clist)))))
+ (let lp ((result 0) (rest clist))
+ (if (null? rest)
+ result
+ (if (pred (car rest))
+ (lp (+ 1 result) (cdr rest))
+ (lp result (cdr rest))))))
;;; Fold, unfold & map
;; Internal helper procedure. Map `f' over the single list `ls'.
;;
(define (map1 f ls)
- (let lp ((l ls))
- (if (null? l)
- '()
- (cons (f (car l)) (lp (cdr l))))))
+ (if (null? ls)
+ ls
+ (let ((ret (list (f (car ls)))))
+ (let lp ((ls (cdr ls)) (p ret)) ; tail pointer
+ (if (null? ls)
+ ret
+ (begin
+ (set-cdr! p (list (f (car ls))))
+ (lp (cdr ls) (cdr p))))))))
;; This `map' is extended from the standard `map'. It allows argument
;; lists of different length, so that the shortest list determines the
clist
(find-tail pred (cdr clist)))))
-(define (take-while pred clist)
- (if (null? clist)
- '()
- (if (pred (car clist))
- (cons (car clist) (take-while pred (cdr clist)))
- '())))
+(define (take-while pred ls)
+ (cond ((null? ls) '())
+ ((not (pred (car ls))) '())
+ (else
+ (let ((result (list (car ls))))
+ (let lp ((ls (cdr ls)) (p result))
+ (cond ((null? ls) result)
+ ((not (pred (car ls))) result)
+ (else
+ (set-cdr! p (list (car ls)))
+ (lp (cdr ls) (cdr p)))))))))
(define (take-while! pred clist)
(take-while pred clist)) ; XXX:optimize
(define (delete-duplicates list . rest)
(let ((l= (if (pair? rest) (car rest) equal?)))
(let lp ((list list))
- (if (null? list)
+ (if (null? list)
'()
(cons (car list) (lp (delete (car list) (cdr list) l=)))))))