/[guile]/guile/guile-core/srfi/srfi-1.scm
ViewVC logotype

Diff of /guile/guile-core/srfi/srfi-1.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.12 by ghouston, Wed Sep 12 19:15:33 2001 UTC revision 1.13 by ttn, Mon Jan 21 01:11:35 2002 UTC
# Line 1  Line 1 
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,
# Line 60  Line 60 
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
# Line 306  Line 306 
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)
# Line 315  Line 315 
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)
# Line 375  Line 375 
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)
# Line 390  Line 390 
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))))))
# Line 468  Line 468 
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))
# Line 484  Line 484 
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))
# Line 603  Line 603 
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
# Line 901  Line 906 
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    

Legend:
Removed from v.1.12  
changed lines
  Added in v.1.13

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26