1 |
;;;; srfi-1.scm --- SRFI-1 procedures for Guile |
;;;; srfi-1.scm --- SRFI-1 procedures for Guile |
2 |
;;;; |
;;;; |
3 |
;;;; Copyright (C) 2001 Free Software Foundation, Inc. |
;;;; Copyright (C) 2001 Free Software Foundation, Inc. |
4 |
;;;; |
;;;; |
5 |
;;;; This program is free software; you can redistribute it and/or |
;;;; This program is free software; you can redistribute it and/or |
6 |
;;;; modify it under the terms of the GNU General Public License as |
;;;; modify it under the terms of the GNU General Public License as |
7 |
;;;; published by the Free Software Foundation; either version 2, or |
;;;; published by the Free Software Foundation; either version 2, or |
8 |
;;;; (at your option) any later version. |
;;;; (at your option) any later version. |
9 |
;;;; |
;;;; |
10 |
;;;; This program is distributed in the hope that it will be useful, |
;;;; This program is distributed in the hope that it will be useful, |
11 |
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
12 |
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
13 |
;;;; General Public License for more details. |
;;;; General Public License for more details. |
14 |
;;;; |
;;;; |
15 |
;;;; You should have received a copy of the GNU General Public License |
;;;; You should have received a copy of the GNU General Public License |
16 |
;;;; along with this software; see the file COPYING. If not, write to |
;;;; along with this software; see the file COPYING. If not, write to |
17 |
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
60 |
:use-module (ice-9 session) |
:use-module (ice-9 session) |
61 |
:use-module (ice-9 receive)) |
:use-module (ice-9 receive)) |
62 |
|
|
63 |
(export |
(export |
64 |
;;; Constructors |
;;; Constructors |
65 |
;; cons <= in the core |
;; cons <= in the core |
66 |
;; list <= in the core |
;; list <= in the core |
306 |
((not-pair? hare) #t) |
((not-pair? hare) #t) |
307 |
(else |
(else |
308 |
(let ((hare (cdr hare))) |
(let ((hare (cdr hare))) |
309 |
(cond |
(cond |
310 |
((null? hare) #f) |
((null? hare) #f) |
311 |
((not-pair? hare) #t) |
((not-pair? hare) #t) |
312 |
((eq? hare tortoise) #f) |
((eq? hare tortoise) #f) |
315 |
|
|
316 |
(define (null-list? x) |
(define (null-list? x) |
317 |
(cond |
(cond |
318 |
((proper-list? x) |
((proper-list? x) |
319 |
(null? x)) |
(null? x)) |
320 |
((circular-list? x) |
((circular-list? x) |
321 |
#f) |
#f) |
375 |
s |
s |
376 |
(lp0 (cdr s) (cdr l)))) |
(lp0 (cdr s) (cdr l)))) |
377 |
(lp (- n 1) (cdr l))))) |
(lp (- n 1) (cdr l))))) |
378 |
|
|
379 |
(define (drop-right flist i) |
(define (drop-right flist i) |
380 |
(let lp ((n i) (l flist)) |
(let lp ((n i) (l flist)) |
381 |
(if (<= n 0) |
(if (<= n 0) |
390 |
'() |
'() |
391 |
(let lp ((n (- i 1)) (l x)) |
(let lp ((n (- i 1)) (l x)) |
392 |
(if (<= n 0) |
(if (<= n 0) |
393 |
(begin |
(begin |
394 |
(set-cdr! l '()) |
(set-cdr! l '()) |
395 |
x) |
x) |
396 |
(lp (- n 1) (cdr l)))))) |
(lp (- n 1) (cdr l)))))) |
468 |
(begin |
(begin |
469 |
(set-cdr! ntail (car l)) |
(set-cdr! ntail (car l)) |
470 |
(lp (cdr l) (last-pair ntail)))))))))) |
(lp (cdr l) (last-pair ntail)))))))))) |
471 |
|
|
472 |
|
|
473 |
(define (append-reverse rev-head tail) |
(define (append-reverse rev-head tail) |
474 |
(let lp ((l rev-head) (acc tail)) |
(let lp ((l rev-head) (acc tail)) |
484 |
(if (any null? l) |
(if (any null? l) |
485 |
(reverse! acc) |
(reverse! acc) |
486 |
(lp (map1 cdr l) (cons (map1 car l) acc))))) |
(lp (map1 cdr l) (cons (map1 car l) acc))))) |
487 |
|
|
488 |
|
|
489 |
(define (unzip1 l) |
(define (unzip1 l) |
490 |
(map1 first l)) |
(map1 first l)) |
603 |
;; Internal helper procedure. Map `f' over the single list `ls'. |
;; Internal helper procedure. Map `f' over the single list `ls'. |
604 |
;; |
;; |
605 |
(define (map1 f ls) |
(define (map1 f ls) |
606 |
(let lp ((l ls)) |
(if (null? ls) |
607 |
(if (null? l) |
ls |
608 |
'() |
(let ((ret (list (f (car ls))))) |
609 |
(cons (f (car l)) (lp (cdr l)))))) |
(let lp ((ls (cdr ls)) (p ret)) ; tail pointer |
610 |
|
(if (null? ls) |
611 |
|
ret |
612 |
|
(begin |
613 |
|
(set-cdr! p (list (f (car ls)))) |
614 |
|
(lp (cdr ls) (cdr p)))))))) |
615 |
|
|
616 |
;; This `map' is extended from the standard `map'. It allows argument |
;; This `map' is extended from the standard `map'. It allows argument |
617 |
;; lists of different length, so that the shortest list determines the |
;; lists of different length, so that the shortest list determines the |
906 |
(define (delete-duplicates list . rest) |
(define (delete-duplicates list . rest) |
907 |
(let ((l= (if (pair? rest) (car rest) equal?))) |
(let ((l= (if (pair? rest) (car rest) equal?))) |
908 |
(let lp ((list list)) |
(let lp ((list list)) |
909 |
(if (null? list) |
(if (null? list) |
910 |
'() |
'() |
911 |
(cons (car list) (lp (delete (car list) (cdr list) l=))))))) |
(cons (car list) (lp (delete (car list) (cdr list) l=))))))) |
912 |
|
|