diff options
Diffstat (limited to 'srfi')
| -rw-r--r-- | srfi/Makefile.am | 43 | ||||
| -rw-r--r-- | srfi/srfi-1.c | 13 | ||||
| -rw-r--r-- | srfi/srfi-1.h | 13 | ||||
| -rw-r--r-- | srfi/srfi-1.scm | 588 | ||||
| -rw-r--r-- | srfi/srfi-10.scm | 89 | ||||
| -rw-r--r-- | srfi/srfi-11.scm | 254 | ||||
| -rw-r--r-- | srfi/srfi-13.c | 13 | ||||
| -rw-r--r-- | srfi/srfi-13.h | 13 | ||||
| -rw-r--r-- | srfi/srfi-13.scm | 132 | ||||
| -rw-r--r-- | srfi/srfi-14.c | 13 | ||||
| -rw-r--r-- | srfi/srfi-14.h | 13 | ||||
| -rw-r--r-- | srfi/srfi-14.scm | 99 | ||||
| -rw-r--r-- | srfi/srfi-16.scm | 126 | ||||
| -rw-r--r-- | srfi/srfi-17.scm | 174 | ||||
| -rw-r--r-- | srfi/srfi-18.scm | 382 | ||||
| -rw-r--r-- | srfi/srfi-19.scm | 1491 | ||||
| -rw-r--r-- | srfi/srfi-2.scm | 31 | ||||
| -rw-r--r-- | srfi/srfi-26.scm | 49 | ||||
| -rw-r--r-- | srfi/srfi-31.scm | 35 | ||||
| -rw-r--r-- | srfi/srfi-34.scm | 80 | ||||
| -rw-r--r-- | srfi/srfi-35.scm | 337 | ||||
| -rw-r--r-- | srfi/srfi-37.scm | 230 | ||||
| -rw-r--r-- | srfi/srfi-39.scm | 137 | ||||
| -rw-r--r-- | srfi/srfi-4.c | 13 | ||||
| -rw-r--r-- | srfi/srfi-4.h | 13 | ||||
| -rw-r--r-- | srfi/srfi-4.scm | 71 | ||||
| -rw-r--r-- | srfi/srfi-6.scm | 33 | ||||
| -rw-r--r-- | srfi/srfi-60.c | 13 | ||||
| -rw-r--r-- | srfi/srfi-60.h | 13 | ||||
| -rw-r--r-- | srfi/srfi-60.scm | 72 | ||||
| -rw-r--r-- | srfi/srfi-69.scm | 329 | ||||
| -rw-r--r-- | srfi/srfi-8.scm | 31 | ||||
| -rw-r--r-- | srfi/srfi-88.scm | 50 | ||||
| -rw-r--r-- | srfi/srfi-9.scm | 91 |
34 files changed, 79 insertions, 5005 deletions
diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 048898dce..648603007 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -4,20 +4,20 @@ ## ## This file is part of GUILE. ## -## GUILE 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 +## GUILE is free software; you can redistribute it and/or modify it +## under the terms of the GNU Lesser General Public License as +## published by the Free Software Foundation; either version 3, or ## (at your option) any later version. ## ## GUILE 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. +## GNU Lesser General Public License for more details. ## -## You should have received a copy of the GNU General Public -## License along with GUILE; see the file COPYING. If not, write -## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth -## Floor, Boston, MA 02110-1301 USA +## You should have received a copy of the GNU Lesser General Public +## License along with GUILE; see the file COPYING.LESSER. If not, +## write to the Free Software Foundation, Inc., 51 Franklin Street, +## Fifth Floor, Boston, MA 02110-1301 USA AUTOMAKE_OPTIONS = gnu @@ -64,32 +64,7 @@ libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_LIBADD = \ $(top_builddir)/libguile/libguile.la $(top_builddir)/lib/libgnu.la libguile_srfi_srfi_60_v_@LIBGUILE_SRFI_SRFI_60_MAJOR@_la_LDFLAGS = -no-undefined -export-dynamic -version-info @LIBGUILE_SRFI_SRFI_60_INTERFACE@ -srfidir = $(datadir)/guile/$(GUILE_EFFECTIVE_VERSION)/srfi -srfi_DATA = srfi-1.scm \ - srfi-2.scm \ - srfi-4.scm \ - srfi-6.scm \ - srfi-8.scm \ - srfi-9.scm \ - srfi-10.scm \ - srfi-11.scm \ - srfi-13.scm \ - srfi-14.scm \ - srfi-16.scm \ - srfi-17.scm \ - srfi-19.scm \ - srfi-26.scm \ - srfi-31.scm \ - srfi-34.scm \ - srfi-35.scm \ - srfi-37.scm \ - srfi-39.scm \ - srfi-60.scm \ - srfi-69.scm \ - srfi-88.scm - -EXTRA_DIST = $(srfi_DATA) ChangeLog-2008 -TAGS_FILES = $(srfi_DATA) +EXTRA_DIST = ChangeLog-2008 GUILE_SNARF = ../libguile/guile-snarf diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index dc218ab04..02f46fca0 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -4,18 +4,19 @@ * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h index 936586697..5797579cc 100644 --- a/srfi/srfi-1.h +++ b/srfi/srfi-1.h @@ -5,18 +5,19 @@ * Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm deleted file mode 100644 index 7c55d9923..000000000 --- a/srfi/srfi-1.scm +++ /dev/null @@ -1,588 +0,0 @@ -;;; srfi-1.scm --- List Library - -;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de> -;;; Date: 2001-06-06 - -;;; Commentary: - -;; This is an implementation of SRFI-1 (List Library). -;; -;; All procedures defined in SRFI-1, which are not already defined in -;; the Guile core library, are exported. The procedures in this -;; implementation work, but they have not been tuned for speed or -;; memory usage. -;; -;; This module is fully documented in the Guile Reference Manual. - -;;; Code: - -(define-module (srfi srfi-1) - :export ( -;;; Constructors - ;; cons <= in the core - ;; list <= in the core - xcons - ;; cons* <= in the core - ;; make-list <= in the core - list-tabulate - list-copy - circular-list - ;; iota ; Extended. - -;;; Predicates - proper-list? - circular-list? - dotted-list? - ;; pair? <= in the core - ;; null? <= in the core - null-list? - not-pair? - list= - -;;; Selectors - ;; car <= in the core - ;; cdr <= in the core - ;; caar <= in the core - ;; cadr <= in the core - ;; cdar <= in the core - ;; cddr <= in the core - ;; caaar <= in the core - ;; caadr <= in the core - ;; cadar <= in the core - ;; caddr <= in the core - ;; cdaar <= in the core - ;; cdadr <= in the core - ;; cddar <= in the core - ;; cdddr <= in the core - ;; caaaar <= in the core - ;; caaadr <= in the core - ;; caadar <= in the core - ;; caaddr <= in the core - ;; cadaar <= in the core - ;; cadadr <= in the core - ;; caddar <= in the core - ;; cadddr <= in the core - ;; cdaaar <= in the core - ;; cdaadr <= in the core - ;; cdadar <= in the core - ;; cdaddr <= in the core - ;; cddaar <= in the core - ;; cddadr <= in the core - ;; cdddar <= in the core - ;; cddddr <= in the core - ;; list-ref <= in the core - first - second - third - fourth - fifth - sixth - seventh - eighth - ninth - tenth - car+cdr - take - drop - take-right - drop-right - take! - drop-right! - split-at - split-at! - last - ;; last-pair <= in the core - -;;; Miscelleneous: length, append, concatenate, reverse, zip & count - ;; length <= in the core - length+ - ;; append <= in the core - ;; append! <= in the core - concatenate - concatenate! - ;; reverse <= in the core - ;; reverse! <= in the core - append-reverse - append-reverse! - zip - unzip1 - unzip2 - unzip3 - unzip4 - unzip5 - count - -;;; Fold, unfold & map - fold - fold-right - pair-fold - pair-fold-right - reduce - reduce-right - unfold - unfold-right - ;; map ; Extended. - ;; for-each ; Extended. - append-map - append-map! - map! - ;; map-in-order ; Extended. - pair-for-each - filter-map - -;;; Filtering & partitioning - ;; filter <= in the core - partition - remove - ;; filter! <= in the core - partition! - remove! - -;;; Searching - find - find-tail - take-while - take-while! - drop-while - span - span! - break - break! - any - every - ;; list-index ; Extended. - ;; member ; Extended. - ;; memq <= in the core - ;; memv <= in the core - -;;; Deletion - ;; delete ; Extended. - ;; delete! ; Extended. - delete-duplicates - delete-duplicates! - -;;; Association lists - ;; assoc ; Extended. - ;; assq <= in the core - ;; assv <= in the core - alist-cons - alist-copy - alist-delete - alist-delete! - -;;; Set operations on lists - lset<= - lset= - lset-adjoin - lset-union - lset-intersection - lset-difference - lset-xor - lset-diff+intersection - lset-union! - lset-intersection! - lset-difference! - lset-xor! - lset-diff+intersection! - -;;; Primitive side-effects - ;; set-car! <= in the core - ;; set-cdr! <= in the core - ) - :re-export (cons list cons* make-list pair? null? - car cdr caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr - list-ref last-pair length append append! reverse reverse! - filter filter! memq memv assq assv set-car! set-cdr!) - :replace (iota map for-each map-in-order list-copy list-index member - delete delete! assoc) - ) - -(cond-expand-provide (current-module) '(srfi-1)) - -;; Load the compiled primitives from the shared library. -;; -(load-extension "libguile-srfi-srfi-1-v-4" "scm_init_srfi_1") - - -;;; Constructors - -;; internal helper, similar to (scsh utilities) check-arg. -(define (check-arg-type pred arg caller) - (if (pred arg) - arg - (scm-error 'wrong-type-arg caller - "Wrong type argument: ~S" (list arg) '()))) - -;; the srfi spec doesn't seem to forbid inexact integers. -(define (non-negative-integer? x) (and (integer? x) (>= x 0))) - - - -(define (circular-list elt1 . elts) - (set! elts (cons elt1 elts)) - (set-cdr! (last-pair elts) elts) - elts) - -(define (iota count . rest) - (check-arg-type non-negative-integer? count "iota") - (let ((start (if (pair? rest) (car rest) 0)) - (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1))) - (let lp ((n 0) (acc '())) - (if (= n count) - (reverse! acc) - (lp (+ n 1) (cons (+ start (* n step)) acc)))))) - -;;; Predicates - -(define (proper-list? x) - (list? x)) - -(define (circular-list? x) - (if (not-pair? x) - #f - (let lp ((hare (cdr x)) (tortoise x)) - (if (not-pair? hare) - #f - (let ((hare (cdr hare))) - (if (not-pair? hare) - #f - (if (eq? hare tortoise) - #t - (lp (cdr hare) (cdr tortoise))))))))) - -(define (dotted-list? x) - (cond - ((null? x) #f) - ((not-pair? x) #t) - (else - (let lp ((hare (cdr x)) (tortoise x)) - (cond - ((null? hare) #f) - ((not-pair? hare) #t) - (else - (let ((hare (cdr hare))) - (cond - ((null? hare) #f) - ((not-pair? hare) #t) - ((eq? hare tortoise) #f) - (else - (lp (cdr hare) (cdr tortoise))))))))))) - -(define (null-list? x) - (cond - ((proper-list? x) - (null? x)) - ((circular-list? x) - #f) - (else - (error "not a proper list in null-list?")))) - -(define (list= elt= . rest) - (define (lists-equal a b) - (let lp ((a a) (b b)) - (cond ((null? a) - (null? b)) - ((null? b) - #f) - (else - (and (elt= (car a) (car b)) - (lp (cdr a) (cdr b))))))) - (or (null? rest) - (let lp ((lists rest)) - (or (null? (cdr lists)) - (and (lists-equal (car lists) (cadr lists)) - (lp (cdr lists))))))) - -;;; Selectors - -(define first car) -(define second cadr) -(define third caddr) -(define fourth cadddr) - -(define take list-head) -(define drop list-tail) - -;;; Miscelleneous: length, append, concatenate, reverse, zip & count - -(define (zip clist1 . rest) - (let lp ((l (cons clist1 rest)) (acc '())) - (if (any null? l) - (reverse! acc) - (lp (map1 cdr l) (cons (map1 car l) acc))))) - - -(define (unzip1 l) - (map1 first l)) -(define (unzip2 l) - (values (map1 first l) (map1 second l))) -(define (unzip3 l) - (values (map1 first l) (map1 second l) (map1 third l))) -(define (unzip4 l) - (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l))) -(define (unzip5 l) - (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l) - (map1 fifth l))) - -;;; Fold, unfold & map - -(define (fold-right kons knil clist1 . rest) - (if (null? rest) - (let f ((list1 clist1)) - (if (null? list1) - knil - (kons (car list1) (f (cdr list1))))) - (let f ((lists (cons clist1 rest))) - (if (any null? lists) - knil - (apply kons (append! (map1 car lists) (list (f (map1 cdr lists))))))))) - -(define (pair-fold kons knil clist1 . rest) - (if (null? rest) - (let f ((knil knil) (list1 clist1)) - (if (null? list1) - knil - (let ((tail (cdr list1))) - (f (kons list1 knil) tail)))) - (let f ((knil knil) (lists (cons clist1 rest))) - (if (any null? lists) - knil - (let ((tails (map1 cdr lists))) - (f (apply kons (append! lists (list knil))) tails)))))) - - -(define (pair-fold-right kons knil clist1 . rest) - (if (null? rest) - (let f ((list1 clist1)) - (if (null? list1) - knil - (kons list1 (f (cdr list1))))) - (let f ((lists (cons clist1 rest))) - (if (any null? lists) - knil - (apply kons (append! lists (list (f (map1 cdr lists))))))))) - -(define (unfold p f g seed . rest) - (let ((tail-gen (if (pair? rest) - (if (pair? (cdr rest)) - (scm-error 'wrong-number-of-args - "unfold" "too many arguments" '() '()) - (car rest)) - (lambda (x) '())))) - (let uf ((seed seed)) - (if (p seed) - (tail-gen seed) - (cons (f seed) - (uf (g seed))))))) - -(define (unfold-right p f g seed . rest) - (let ((tail (if (pair? rest) - (if (pair? (cdr rest)) - (scm-error 'wrong-number-of-args - "unfold-right" "too many arguments" '() - '()) - (car rest)) - '()))) - (let uf ((seed seed) (lis tail)) - (if (p seed) - lis - (uf (g seed) (cons (f seed) lis)))))) - - -;; Internal helper procedure. Map `f' over the single list `ls'. -;; -(define map1 map) - -(define (append-map f clist1 . rest) - (concatenate (apply map f clist1 rest))) - -(define (append-map! f clist1 . rest) - (concatenate! (apply map f clist1 rest))) - -;; OPTIMIZE-ME: Re-use cons cells of list1 -(define map! map) - -(define (pair-for-each f clist1 . rest) - (if (null? rest) - (let lp ((l clist1)) - (if (null? l) - (if #f #f) - (begin - (f l) - (lp (cdr l))))) - (let lp ((l (cons clist1 rest))) - (if (any1 null? l) - (if #f #f) - (begin - (apply f l) - (lp (map1 cdr l))))))) - -;;; Searching - -(define (any pred ls . lists) - (if (null? lists) - (any1 pred ls) - (let lp ((lists (cons ls lists))) - (cond ((any1 null? lists) - #f) - ((any1 null? (map1 cdr lists)) - (apply pred (map1 car lists))) - (else - (or (apply pred (map1 car lists)) (lp (map1 cdr lists)))))))) - -(define (any1 pred ls) - (let lp ((ls ls)) - (cond ((null? ls) - #f) - ((null? (cdr ls)) - (pred (car ls))) - (else - (or (pred (car ls)) (lp (cdr ls))))))) - -(define (every pred ls . lists) - (if (null? lists) - (every1 pred ls) - (let lp ((lists (cons ls lists))) - (cond ((any1 null? lists) - #t) - ((any1 null? (map1 cdr lists)) - (apply pred (map1 car lists))) - (else - (and (apply pred (map1 car lists)) (lp (map1 cdr lists)))))))) - -(define (every1 pred ls) - (let lp ((ls ls)) - (cond ((null? ls) - #t) - ((null? (cdr ls)) - (pred (car ls))) - (else - (and (pred (car ls)) (lp (cdr ls))))))) - -;;; Association lists - -(define alist-cons acons) - -(define (alist-delete key alist . rest) - (let ((k= (if (pair? rest) (car rest) equal?))) - (let lp ((a alist) (rl '())) - (if (null? a) - (reverse! rl) - (if (k= key (caar a)) - (lp (cdr a) rl) - (lp (cdr a) (cons (car a) rl))))))) - -(define (alist-delete! key alist . rest) - (let ((k= (if (pair? rest) (car rest) equal?))) - (alist-delete key alist k=))) ; XXX:optimize - -;;; Set operations on lists - -(define (lset<= = . rest) - (if (null? rest) - #t - (let lp ((f (car rest)) (r (cdr rest))) - (or (null? r) - (and (every (lambda (el) (member el (car r) =)) f) - (lp (car r) (cdr r))))))) - -(define (lset= = . rest) - (if (null? rest) - #t - (let lp ((f (car rest)) (r (cdr rest))) - (or (null? r) - (and (every (lambda (el) (member el (car r) =)) f) - (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r)) - (lp (car r) (cdr r))))))) - -(define (lset-union = . rest) - (let ((acc '())) - (for-each (lambda (lst) - (if (null? acc) - (set! acc lst) - (for-each (lambda (elem) - (if (not (member elem acc - (lambda (x y) (= y x)))) - (set! acc (cons elem acc)))) - lst))) - rest) - acc)) - -(define (lset-intersection = list1 . rest) - (let lp ((l list1) (acc '())) - (if (null? l) - (reverse! acc) - (if (every (lambda (ll) (member (car l) ll =)) rest) - (lp (cdr l) (cons (car l) acc)) - (lp (cdr l) acc))))) - -(define (lset-difference = list1 . rest) - (if (null? rest) - list1 - (let lp ((l list1) (acc '())) - (if (null? l) - (reverse! acc) - (if (any (lambda (ll) (member (car l) ll =)) rest) - (lp (cdr l) acc) - (lp (cdr l) (cons (car l) acc))))))) - -;(define (fold kons knil list1 . rest) - -(define (lset-xor = . rest) - (fold (lambda (lst res) - (let lp ((l lst) (acc '())) - (if (null? l) - (let lp0 ((r res) (acc acc)) - (if (null? r) - (reverse! acc) - (if (member (car r) lst =) - (lp0 (cdr r) acc) - (lp0 (cdr r) (cons (car r) acc))))) - (if (member (car l) res =) - (lp (cdr l) acc) - (lp (cdr l) (cons (car l) acc)))))) - '() - rest)) - -(define (lset-diff+intersection = list1 . rest) - (let lp ((l list1) (accd '()) (acci '())) - (if (null? l) - (values (reverse! accd) (reverse! acci)) - (let ((appears (every (lambda (ll) (member (car l) ll =)) rest))) - (if appears - (lp (cdr l) accd (cons (car l) acci)) - (lp (cdr l) (cons (car l) accd) acci)))))) - - -(define (lset-union! = . rest) - (apply lset-union = rest)) ; XXX:optimize - -(define (lset-intersection! = list1 . rest) - (apply lset-intersection = list1 rest)) ; XXX:optimize - -(define (lset-xor! = . rest) - (apply lset-xor = rest)) ; XXX:optimize - -(define (lset-diff+intersection! = list1 . rest) - (apply lset-diff+intersection = list1 rest)) ; XXX:optimize - -;;; srfi-1.scm ends here diff --git a/srfi/srfi-10.scm b/srfi/srfi-10.scm deleted file mode 100644 index 8e7181a3b..000000000 --- a/srfi/srfi-10.scm +++ /dev/null @@ -1,89 +0,0 @@ -;;; srfi-10.scm --- Hash-Comma Reader Extension - -;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: - -;; This module implements the syntax extension #,(), also called -;; hash-comma, which is defined in SRFI-10. -;; -;; The support for SRFI-10 consists of the procedure -;; `define-reader-ctor' for defining new reader constructors and the -;; read syntax form -;; -;; #,(<ctor> <datum> ...) -;; -;; where <ctor> must be a symbol for which a read constructor was -;; defined previously. -;; -;; Example: -;; -;; (define-reader-ctor 'file open-input-file) -;; (define f '#,(file "/etc/passwd")) -;; (read-line f) -;; => -;; "root:x:0:0:root:/root:/bin/bash" -;; -;; Please note the quote before the #,(file ...) expression. This is -;; necessary because ports are not self-evaluating in Guile. -;; -;; This module is fully documented in the Guile Reference Manual. - -;;; Code: - -(define-module (srfi srfi-10) - :use-module (ice-9 rdelim) - :export (define-reader-ctor)) - -(cond-expand-provide (current-module) '(srfi-10)) - -;; This hash table stores the association between comma-hash tags and -;; the corresponding constructor procedures. -;; -(define reader-ctors (make-hash-table 31)) - -;; This procedure installs the procedure @var{proc} as the constructor -;; for the comma-hash tag @var{symbol}. -;; -(define (define-reader-ctor symbol proc) - (hashq-set! reader-ctors symbol proc) - (if #f #f)) ; Return unspecified value. - -;; Retrieve the constructor procedure for the tag @var{symbol} or -;; throw an error if no such tag is defined. -;; -(define (lookup symbol) - (let ((p (hashq-ref reader-ctors symbol #f))) - (if (procedure? p) - p - (error "unknown hash-comma tag " symbol)))) - -;; This is the actual reader extension. -;; -(define (hash-comma char port) - (let* ((obj (read port))) - (if (and (list? obj) (positive? (length obj)) (symbol? (car obj))) - (let ((p (lookup (car obj)))) - (let ((res (apply p (cdr obj)))) - res)) - (error "syntax error in hash-comma expression")))) - -;; Install the hash extension. -;; -(read-hash-extend #\, hash-comma) - -;;; srfi-10.scm ends here diff --git a/srfi/srfi-11.scm b/srfi/srfi-11.scm deleted file mode 100644 index 9e17d6632..000000000 --- a/srfi/srfi-11.scm +++ /dev/null @@ -1,254 +0,0 @@ -;;; srfi-11.scm --- let-values and let*-values - -;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: - -;; This module exports two syntax forms: let-values and let*-values. -;; -;; Sample usage: -;; -;; (let-values (((x y . z) (foo a b)) -;; ((p q) (bar c))) -;; (baz x y z p q)) -;; -;; This binds `x' and `y' to the first to values returned by `foo', -;; `z' to the rest of the values from `foo', and `p' and `q' to the -;; values returned by `bar'. All of these are available to `baz'. -;; -;; let*-values : let-values :: let* : let -;; -;; This module is fully documented in the Guile Reference Manual. - -;;; Code: - -(define-module (srfi srfi-11) - :use-module (ice-9 syncase) - :export-syntax (let-values let*-values)) - -(cond-expand-provide (current-module) '(srfi-11)) - -;;;;;;;;;;;;;; -;; let-values -;; -;; Current approach is to translate -;; -;; (let-values (((x y . z) (foo a b)) -;; ((p q) (bar c))) -;; (baz x y z p q)) -;; -;; into -;; -;; (call-with-values (lambda () (foo a b)) -;; (lambda (<tmp-x> <tmp-y> . <tmp-z>) -;; (call-with-values (lambda () (bar c)) -;; (lambda (<tmp-p> <tmp-q>) -;; (let ((x <tmp-x>) -;; (y <tmp-y>) -;; (z <tmp-z>) -;; (p <tmp-p>) -;; (q <tmp-q>)) -;; (baz x y z p q)))))) - -;; I originally wrote this as a define-macro, but then I found out -;; that guile's gensym/gentemp was broken, so I tried rewriting it as -;; a syntax-rules statement. -;; [make-symbol now fixes gensym/gentemp problems.] -;; -;; Since syntax-rules didn't seem powerful enough to implement -;; let-values in one definition without exposing illegal syntax (or -;; perhaps my brain's just not powerful enough :>). I tried writing -;; it using a private helper, but that didn't work because the -;; let-values expands outside the scope of this module. I wonder why -;; syntax-rules wasn't designed to allow "private" patterns or -;; similar... -;; -;; So in the end, I dumped the syntax-rules implementation, reproduced -;; here for posterity, and went with the define-macro one below -- -;; gensym/gentemp's got to be fixed anyhow... -; -; (define-syntax let-values-helper -; (syntax-rules () -; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y -; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda -; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the -; ;; temps you create so you can use them later... -; ;; -; ;; I really don't fully understand why the (var-1 var-1) trick -; ;; works below, but basically, when all those (x x) bindings show -; ;; up in the final "let", syntax-rules forces a renaming. - -; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings -; body ...) -; (lambda lambda-tmps -; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) - -; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings -; body ...) -; (let-values-helper "consumer" -; (var-2 ...) -; (lambda-tmp ... var-1) -; ((var-1 var-1) . final-let-bindings) -; lv-bindings -; body ...)) - -; ((_ "cwv" () final-let-bindings body ...) -; (let final-let-bindings -; body ...)) - -; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings -; body ...) -; (call-with-values (lambda () binding-1) -; (let-values-helper "consumer" -; vars-1 -; () -; final-let-bindings -; (other-bindings ...) -; body ...))))) -; -; (define-syntax let-values -; (syntax-rules () -; ((let-values () body ...) -; (begin body ...)) -; ((let-values (binding ...) body ...) -; (let-values-helper "cwv" (binding ...) () body ...)))) -; -; -; (define-syntax let-values -; (letrec-syntax ((build-consumer -; ;; Take the vars from one let binding (i.e. the (x -; ;; y z) from ((x y z) (values 1 2 3)) and turn it -; ;; in to the corresponding (lambda (<tmp-x> <tmp-y> -; ;; <tmp-z>) ...) from above. -; (syntax-rules () -; ((_ () new-tmps tmp-vars () body ...) -; (lambda new-tmps -; body ...)) -; ((_ () new-tmps tmp-vars vars body ...) -; (lambda new-tmps -; (lv-builder vars tmp-vars body ...))) -; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...) -; (build-consumer (var-2 ...) -; (tmp-1 . new-tmps) -; ((var-1 tmp-1) . tmp-vars) -; bindings -; body ...)))) -; (lv-builder -; (syntax-rules () -; ((_ () tmp-vars body ...) -; (let tmp-vars -; body ...)) -; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...) -; tmp-vars -; body ...) -; (call-with-values (lambda () binding-1) -; (build-consumer vars-1 -; () -; tmp-vars -; ((vars-2 binding-2) ...) -; body ...)))))) -; -; (syntax-rules () -; ((_ () body ...) -; (begin body ...)) -; ((_ ((vars binding) ...) body ...) -; (lv-builder ((vars binding) ...) () body ...))))) - -(define-macro (let-values vars . body) - - (define (map-1-dot proc elts) - ;; map over one optionally dotted (a b c . d) list, producing an - ;; optionally dotted result. - (cond - ((null? elts) '()) - ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts)))) - (else (proc elts)))) - - (define (undot-list lst) - ;; produce a non-dotted list from a possibly dotted list. - (cond - ((null? lst) '()) - ((pair? lst) (cons (car lst) (undot-list (cdr lst)))) - (else (list lst)))) - - (define (let-values-helper vars body prev-let-vars) - (let* ((var-binding (car vars)) - (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var")) - (car var-binding))) - (let-vars (map (lambda (sym tmp) (list sym tmp)) - (undot-list (car var-binding)) - (undot-list new-tmps)))) - - (if (null? (cdr vars)) - `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,new-tmps - (let ,(apply append let-vars prev-let-vars) - ,@body))) - `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,new-tmps - ,(let-values-helper (cdr vars) body - (cons let-vars prev-let-vars))))))) - - (if (null? vars) - `(begin ,@body) - (let-values-helper vars body '()))) - -;;;;;;;;;;;;;; -;; let*-values -;; -;; Current approach is to translate -;; -;; (let*-values (((x y z) (foo a b)) -;; ((p q) (bar c))) -;; (baz x y z p q)) -;; -;; into -;; -;; (call-with-values (lambda () (foo a b)) -;; (lambda (x y z) -;; (call-with-values (lambda (bar c)) -;; (lambda (p q) -;; (baz x y z p q))))) - -(define-syntax let*-values - (syntax-rules () - ((let*-values () body ...) - (begin body ...)) - ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) - (call-with-values (lambda () binding-1) - (lambda vars-1 - (let*-values ((vars-2 binding-2) ...) - body ...)))))) - -; Alternate define-macro implementation... -; -; (define-macro (let*-values vars . body) -; (define (let-values-helper vars body) -; (let ((var-binding (car vars))) -; (if (null? (cdr vars)) -; `(call-with-values (lambda () ,(cadr var-binding)) -; (lambda ,(car var-binding) -; ,@body)) -; `(call-with-values (lambda () ,(cadr var-binding)) -; (lambda ,(car var-binding) -; ,(let-values-helper (cdr vars) body)))))) - -; (if (null? vars) -; `(begin ,@body) -; (let-values-helper vars body))) - -;;; srfi-11.scm ends here diff --git a/srfi/srfi-13.c b/srfi/srfi-13.c index dd5ce9b15..61a960e5d 100644 --- a/srfi/srfi-13.c +++ b/srfi/srfi-13.c @@ -3,18 +3,19 @@ * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/srfi/srfi-13.h b/srfi/srfi-13.h index 8007d565b..a110ffd6d 100644 --- a/srfi/srfi-13.h +++ b/srfi/srfi-13.h @@ -6,18 +6,19 @@ * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/srfi/srfi-13.scm b/srfi/srfi-13.scm deleted file mode 100644 index 1036a0f47..000000000 --- a/srfi/srfi-13.scm +++ /dev/null @@ -1,132 +0,0 @@ -;;; srfi-13.scm --- String Library - -;; Copyright (C) 2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: - -;; This module is fully documented in the Guile Reference Manual. -;; -;; All procedures are in the core and are simply reexported here. - -;;; Code: - -(define-module (srfi srfi-13)) - -(re-export -;;; Predicates - string? - string-null? - string-any - string-every - -;;; Constructors - make-string - string - string-tabulate - -;;; List/string conversion - string->list - list->string - reverse-list->string - string-join - -;;; Selection - string-length - string-ref - string-copy - substring/shared - string-copy! - string-take string-take-right - string-drop string-drop-right - string-pad string-pad-right - string-trim string-trim-right - string-trim-both - -;;; Modification - string-set! - string-fill! - -;;; Comparison - string-compare - string-compare-ci - string= string<> - string< string> - string<= string>= - string-ci= string-ci<> - string-ci< string-ci> - string-ci<= string-ci>= - string-hash string-hash-ci - -;;; Prefixes/Suffixes - string-prefix-length - string-prefix-length-ci - string-suffix-length - string-suffix-length-ci - string-prefix? - string-prefix-ci? - string-suffix? - string-suffix-ci? - -;;; Searching - string-index - string-index-right - string-skip string-skip-right - string-count - string-contains string-contains-ci - -;;; Alphabetic case mapping - string-upcase - string-upcase! - string-downcase - string-downcase! - string-titlecase - string-titlecase! - -;;; Reverse/Append - string-reverse - string-reverse! - string-append - string-append/shared - string-concatenate - string-concatenate-reverse - string-concatenate/shared - string-concatenate-reverse/shared - -;;; Fold/Unfold/Map - string-map string-map! - string-fold - string-fold-right - string-unfold - string-unfold-right - string-for-each - string-for-each-index - -;;; Replicate/Rotate - xsubstring - string-xcopy! - -;;; Miscellaneous - string-replace - string-tokenize - -;;; Filtering/Deleting - string-filter - string-delete) - -(cond-expand-provide (current-module) '(srfi-13)) - -;;; srfi-13.scm ends here diff --git a/srfi/srfi-14.c b/srfi/srfi-14.c index 1a7297b82..9f6ad8bc0 100644 --- a/srfi/srfi-14.c +++ b/srfi/srfi-14.c @@ -3,18 +3,19 @@ * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/srfi/srfi-14.h b/srfi/srfi-14.h index b1f4ae726..a793159c5 100644 --- a/srfi/srfi-14.h +++ b/srfi/srfi-14.h @@ -5,18 +5,19 @@ * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/srfi/srfi-14.scm b/srfi/srfi-14.scm deleted file mode 100644 index 100b43b8e..000000000 --- a/srfi/srfi-14.scm +++ /dev/null @@ -1,99 +0,0 @@ -;;; srfi-14.scm --- Character-set Library - -;; Copyright (C) 2001, 2002, 2004, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: - -;; This module is fully documented in the Guile Reference Manual. - -;;; Code: - -(define-module (srfi srfi-14)) - -(re-export -;;; General procedures - char-set? - char-set= - char-set<= - char-set-hash - -;;; Iterating over character sets - char-set-cursor - char-set-ref - char-set-cursor-next - end-of-char-set? - char-set-fold - char-set-unfold char-set-unfold! - char-set-for-each - char-set-map - -;;; Creating character sets - char-set-copy - char-set - list->char-set list->char-set! - string->char-set string->char-set! - char-set-filter char-set-filter! - ucs-range->char-set ucs-range->char-set! - ->char-set - -;;; Querying character sets - char-set-size - char-set-count - char-set->list - char-set->string - char-set-contains? - char-set-every - char-set-any - -;;; Character set algebra - char-set-adjoin char-set-adjoin! - char-set-delete char-set-delete! - char-set-complement - char-set-union - char-set-intersection - char-set-difference - char-set-xor - char-set-diff+intersection - char-set-complement! - char-set-union! - char-set-intersection! - char-set-difference! - char-set-xor! - char-set-diff+intersection! - -;;; Standard character sets - char-set:lower-case - char-set:upper-case - char-set:title-case - char-set:letter - char-set:digit - char-set:letter+digit - char-set:graphic - char-set:printing - char-set:whitespace - char-set:iso-control - char-set:punctuation - char-set:symbol - char-set:hex-digit - char-set:blank - char-set:ascii - char-set:empty - char-set:full) - -(cond-expand-provide (current-module) '(srfi-14)) - -;;; srfi-14.scm ends here diff --git a/srfi/srfi-16.scm b/srfi/srfi-16.scm deleted file mode 100644 index 0b213fde7..000000000 --- a/srfi/srfi-16.scm +++ /dev/null @@ -1,126 +0,0 @@ -;;; srfi-16.scm --- case-lambda - -;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: Martin Grabmueller - -;;; Commentary: - -;; Implementation of SRFI-16. `case-lambda' is a syntactic form -;; which permits writing functions acting different according to the -;; number of arguments passed. -;; -;; The syntax of the `case-lambda' form is defined in the following -;; EBNF grammar. -;; -;; <case-lambda> -;; --> (case-lambda <case-lambda-clause>) -;; <case-lambda-clause> -;; --> (<signature> <definition-or-command>*) -;; <signature> -;; --> (<identifier>*) -;; | (<identifier>* . <identifier>) -;; | <identifier> -;; -;; The value returned by a `case-lambda' form is a procedure which -;; matches the number of actual arguments against the signatures in -;; the various clauses, in order. The first matching clause is -;; selected, the corresponding values from the actual parameter list -;; are bound to the variable names in the clauses and the body of the -;; clause is evaluated. - -;;; Code: - -(define-module (srfi srfi-16) - :export-syntax (case-lambda)) - -(cond-expand-provide (current-module) '(srfi-16)) - -(define-macro (case-lambda . clauses) - - ;; Return the length of the list @var{l}, but allow dotted list. - ;; - (define (alength l) - (cond ((null? l) 0) - ((pair? l) (+ 1 (alength (cdr l)))) - (else 0))) - - ;; Return @code{#t} if @var{l} is a dotted list, @code{#f} if it is - ;; a normal list. - ;; - (define (dotted? l) - (cond ((null? l) #f) - ((pair? l) (dotted? (cdr l))) - (else #t))) - - ;; Return the expression for accessing the @var{index}th element of - ;; the list called @var{args-name}. If @var{tail?} is true, code - ;; for accessing the list-tail is generated, otherwise for accessing - ;; the list element itself. - ;; - (define (accessor args-name index tail?) - (if tail? - (case index - ((0) `,args-name) - ((1) `(cdr ,args-name)) - ((2) `(cddr ,args-name)) - ((3) `(cdddr ,args-name)) - ((4) `(cddddr ,args-name)) - (else `(list-tail ,args-name ,index))) - (case index - ((0) `(car ,args-name)) - ((1) `(cadr ,args-name)) - ((2) `(caddr ,args-name)) - ((3) `(cadddr ,args-name)) - (else `(list-ref ,args-name ,index))))) - - ;; Generate the binding lists of the variables of one case-lambda - ;; clause. @var{vars} is the (possibly dotted) list of variables - ;; and @var{args-name} is the generated name used for the argument - ;; list. - ;; - (define (gen-temps vars args-name) - (let lp ((v vars) (i 0)) - (cond ((null? v) '()) - ((pair? v) - (cons `(,(car v) ,(accessor args-name i #f)) - (lp (cdr v) (+ i 1)))) - (else `((,v ,(accessor args-name i #t))))))) - - ;; Generate the cond clauses for each of the clauses of case-lambda, - ;; including the parameter count check, binding of the parameters - ;; and the code of the corresponding body. - ;; - (define (gen-clauses l length-name args-name) - (cond ((null? l) (list '(else (error "too few arguments")))) - (else - (cons - `((,(if (dotted? (caar l)) '>= '=) - ,length-name ,(alength (caar l))) - (let ,(gen-temps (caar l) args-name) - ,@(cdar l))) - (gen-clauses (cdr l) length-name args-name))))) - - (let ((args-name (gensym)) - (length-name (gensym))) - (let ((proc - `(lambda ,args-name - (let ((,length-name (length ,args-name))) - (cond ,@(gen-clauses clauses length-name args-name)))))) - proc))) - -;;; srfi-16.scm ends here diff --git a/srfi/srfi-17.scm b/srfi/srfi-17.scm deleted file mode 100644 index c9cb2abfe..000000000 --- a/srfi/srfi-17.scm +++ /dev/null @@ -1,174 +0,0 @@ -;;; srfi-17.scm --- Generalized set! - -;; Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de> - -;;; Commentary: - -;; This is an implementation of SRFI-17: Generalized set! -;; -;; It exports the Guile procedure `make-procedure-with-setter' under -;; the SRFI name `getter-with-setter' and exports the standard -;; procedures `car', `cdr', ..., `cdddr', `string-ref' and -;; `vector-ref' as procedures with setters, as required by the SRFI. -;; -;; SRFI-17 was heavily criticized during its discussion period but it -;; was finalized anyway. One issue was its concept of globally -;; associating setter "properties" with (procedure) values, which is -;; non-Schemy. For this reason, this implementation chooses not to -;; provide a way to set the setter of a procedure. In fact, (set! -;; (setter PROC) SETTER) signals an error. The only way to attach a -;; setter to a procedure is to create a new object (a "procedure with -;; setter") via the `getter-with-setter' procedure. This procedure is -;; also specified in the SRFI. Using it avoids the described -;; problems. -;; -;; This module is fully documented in the Guile Reference Manual. - -;;; Code: - -(define-module (srfi srfi-17) - :export (getter-with-setter) - :replace (;; redefined standard procedures - setter - car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar - cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr - caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr - cdddar cddddr string-ref vector-ref)) - -(cond-expand-provide (current-module) '(srfi-17)) - -;;; Procedures - -(define getter-with-setter make-procedure-with-setter) - -(define setter - (getter-with-setter - (@ (guile) setter) - (lambda args - (error "Setting setters is not supported for a good reason.")))) - -;;; Redefine R5RS procedures to appropriate procedures with setters - -(define (compose-setter setter location) - (lambda (obj value) - (setter (location obj) value))) - -(define car - (getter-with-setter (@ (guile) car) - set-car!)) -(define cdr - (getter-with-setter (@ (guile) cdr) - set-cdr!)) - -(define caar - (getter-with-setter (@ (guile) caar) - (compose-setter set-car! (@ (guile) car)))) -(define cadr - (getter-with-setter (@ (guile) cadr) - (compose-setter set-car! (@ (guile) cdr)))) -(define cdar - (getter-with-setter (@ (guile) cdar) - (compose-setter set-cdr! (@ (guile) car)))) -(define cddr - (getter-with-setter (@ (guile) cddr) - (compose-setter set-cdr! (@ (guile) cdr)))) - -(define caaar - (getter-with-setter (@ (guile) caaar) - (compose-setter set-car! (@ (guile) caar)))) -(define caadr - (getter-with-setter (@ (guile) caadr) - (compose-setter set-car! (@ (guile) cadr)))) -(define cadar - (getter-with-setter (@ (guile) cadar) - (compose-setter set-car! (@ (guile) cdar)))) -(define caddr - (getter-with-setter (@ (guile) caddr) - (compose-setter set-car! (@ (guile) cddr)))) -(define cdaar - (getter-with-setter (@ (guile) cdaar) - (compose-setter set-cdr! (@ (guile) caar)))) -(define cdadr - (getter-with-setter (@ (guile) cdadr) - (compose-setter set-cdr! (@ (guile) cadr)))) -(define cddar - (getter-with-setter (@ (guile) cddar) - (compose-setter set-cdr! (@ (guile) cdar)))) -(define cdddr - (getter-with-setter (@ (guile) cdddr) - (compose-setter set-cdr! (@ (guile) cddr)))) - -(define caaaar - (getter-with-setter (@ (guile) caaaar) - (compose-setter set-car! (@ (guile) caaar)))) -(define caaadr - (getter-with-setter (@ (guile) caaadr) - (compose-setter set-car! (@ (guile) caadr)))) -(define caadar - (getter-with-setter (@ (guile) caadar) - (compose-setter set-car! (@ (guile) cadar)))) -(define caaddr - (getter-with-setter (@ (guile) caaddr) - (compose-setter set-car! (@ (guile) caddr)))) -(define cadaar - (getter-with-setter (@ (guile) cadaar) - (compose-setter set-car! (@ (guile) cdaar)))) -(define cadadr - (getter-with-setter (@ (guile) cadadr) - (compose-setter set-car! (@ (guile) cdadr)))) -(define caddar - (getter-with-setter (@ (guile) caddar) - (compose-setter set-car! (@ (guile) cddar)))) -(define cadddr - (getter-with-setter (@ (guile) cadddr) - (compose-setter set-car! (@ (guile) cdddr)))) -(define cdaaar - (getter-with-setter (@ (guile) cdaaar) - (compose-setter set-cdr! (@ (guile) caaar)))) -(define cdaadr - (getter-with-setter (@ (guile) cdaadr) - (compose-setter set-cdr! (@ (guile) caadr)))) -(define cdadar - (getter-with-setter (@ (guile) cdadar) - (compose-setter set-cdr! (@ (guile) cadar)))) -(define cdaddr - (getter-with-setter (@ (guile) cdaddr) - (compose-setter set-cdr! (@ (guile) caddr)))) -(define cddaar - (getter-with-setter (@ (guile) cddaar) - (compose-setter set-cdr! (@ (guile) cdaar)))) -(define cddadr - (getter-with-setter (@ (guile) cddadr) - (compose-setter set-cdr! (@ (guile) cdadr)))) -(define cdddar - (getter-with-setter (@ (guile) cdddar) - (compose-setter set-cdr! (@ (guile) cddar)))) -(define cddddr - (getter-with-setter (@ (guile) cddddr) - (compose-setter set-cdr! (@ (guile) cdddr)))) - -(define string-ref - (getter-with-setter (@ (guile) string-ref) - string-set!)) - -(define vector-ref - (getter-with-setter (@ (guile) vector-ref) - vector-set!)) - -;;; srfi-17.scm ends here diff --git a/srfi/srfi-18.scm b/srfi/srfi-18.scm deleted file mode 100644 index 925ecb304..000000000 --- a/srfi/srfi-18.scm +++ /dev/null @@ -1,382 +0,0 @@ -;;; srfi-18.scm --- Multithreading support - -;; Copyright (C) 2008 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: Julian Graham <julian.graham@aya.yale.edu> -;;; Date: 2008-04-11 - -;;; Commentary: - -;; This is an implementation of SRFI-18 (Multithreading support). -;; -;; All procedures defined in SRFI-18, which are not already defined in -;; the Guile core library, are exported. -;; -;; This module is fully documented in the Guile Reference Manual. - -;;; Code: - -(define-module (srfi srfi-18) - :use-module (srfi srfi-34) - :export ( - -;;; Threads - ;; current-thread <= in the core - ;; thread? <= in the core - make-thread - thread-name - thread-specific - thread-specific-set! - thread-start! - thread-yield! - thread-sleep! - thread-terminate! - thread-join! - -;;; Mutexes - ;; mutex? <= in the core - make-mutex - mutex-name - mutex-specific - mutex-specific-set! - mutex-state - mutex-lock! - mutex-unlock! - -;;; Condition variables - ;; condition-variable? <= in the core - make-condition-variable - condition-variable-name - condition-variable-specific - condition-variable-specific-set! - condition-variable-signal! - condition-variable-broadcast! - condition-variable-wait! - -;;; Time - current-time - time? - time->seconds - seconds->time - - current-exception-handler - with-exception-handler - raise - join-timeout-exception? - abandoned-mutex-exception? - terminated-thread-exception? - uncaught-exception? - uncaught-exception-reason - ) - :re-export (thread? mutex? condition-variable?) - :replace (current-time - make-thread - make-mutex - make-condition-variable - raise)) - -(if (not (provided? 'threads)) - (error "SRFI-18 requires Guile with threads support")) - -(cond-expand-provide (current-module) '(srfi-18)) - -(define (check-arg-type pred arg caller) - (if (pred arg) - arg - (scm-error 'wrong-type-arg caller - "Wrong type argument: ~S" (list arg) '()))) - -(define abandoned-mutex-exception (list 'abandoned-mutex-exception)) -(define join-timeout-exception (list 'join-timeout-exception)) -(define terminated-thread-exception (list 'terminated-thread-exception)) -(define uncaught-exception (list 'uncaught-exception)) - -(define mutex-owners (make-weak-key-hash-table)) -(define object-names (make-weak-key-hash-table)) -(define object-specifics (make-weak-key-hash-table)) -(define thread-start-conds (make-weak-key-hash-table)) -(define thread-exception-handlers (make-weak-key-hash-table)) - -;; EXCEPTIONS - -(define raise (@ (srfi srfi-34) raise)) -(define (initial-handler obj) - (srfi-18-exception-preserver (cons uncaught-exception obj))) - -(define thread->exception (make-object-property)) - -(define (srfi-18-exception-preserver obj) - (if (or (terminated-thread-exception? obj) - (uncaught-exception? obj)) - (set! (thread->exception (current-thread)) obj))) - -(define (srfi-18-exception-handler key . args) - - ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so - ;; if one is caught at this level, it has already been taken care of by - ;; `initial-handler'. - - (and (not (eq? key 'srfi-34)) - (srfi-18-exception-preserver (if (null? args) - (cons uncaught-exception key) - (cons* uncaught-exception key args))))) - -(define (current-handler-stack) - (let ((ct (current-thread))) - (or (hashq-ref thread-exception-handlers ct) - (hashq-set! thread-exception-handlers ct (list initial-handler))))) - -(define (with-exception-handler handler thunk) - (let ((ct (current-thread)) - (hl (current-handler-stack))) - (check-arg-type procedure? handler "with-exception-handler") - (check-arg-type thunk? thunk "with-exception-handler") - (hashq-set! thread-exception-handlers ct (cons handler hl)) - (apply (@ (srfi srfi-34) with-exception-handler) - (list (lambda (obj) - (hashq-set! thread-exception-handlers ct hl) - (handler obj)) - (lambda () - (let ((r (thunk))) - (hashq-set! thread-exception-handlers ct hl) r)))))) - -(define (current-exception-handler) - (car (current-handler-stack))) - -(define (join-timeout-exception? obj) (eq? obj join-timeout-exception)) -(define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception)) -(define (uncaught-exception? obj) - (and (pair? obj) (eq? (car obj) uncaught-exception))) -(define (uncaught-exception-reason exc) - (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason"))) -(define (terminated-thread-exception? obj) - (eq? obj terminated-thread-exception)) - -;; THREADS - -;; Create a new thread and prevent it from starting using a condition variable. -;; Once started, install a top-level exception handler that rethrows any -;; exceptions wrapped in an uncaught-exception wrapper. - -(define make-thread - (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex) - (lambda () - (lock-mutex lmutex) - (signal-condition-variable lcond) - (lock-mutex smutex) - (unlock-mutex lmutex) - (wait-condition-variable scond smutex) - (unlock-mutex smutex) - (with-exception-handler initial-handler - thunk))))) - (lambda (thunk . name) - (let ((n (and (pair? name) (car name))) - - (lm (make-mutex 'launch-mutex)) - (lc (make-condition-variable 'launch-condition-variable)) - (sm (make-mutex 'start-mutex)) - (sc (make-condition-variable 'start-condition-variable))) - - (lock-mutex lm) - (let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm) - srfi-18-exception-handler))) - (hashq-set! thread-start-conds t (cons sm sc)) - (and n (hashq-set! object-names t n)) - (wait-condition-variable lc lm) - (unlock-mutex lm) - t))))) - -(define (thread-name thread) - (hashq-ref object-names (check-arg-type thread? thread "thread-name"))) - -(define (thread-specific thread) - (hashq-ref object-specifics - (check-arg-type thread? thread "thread-specific"))) - -(define (thread-specific-set! thread obj) - (hashq-set! object-specifics - (check-arg-type thread? thread "thread-specific-set!") - obj) - *unspecified*) - -(define (thread-start! thread) - (let ((x (hashq-ref thread-start-conds - (check-arg-type thread? thread "thread-start!")))) - (and x (let ((smutex (car x)) - (scond (cdr x))) - (hashq-remove! thread-start-conds thread) - (lock-mutex smutex) - (signal-condition-variable scond) - (unlock-mutex smutex))) - thread)) - -(define (thread-yield!) (yield) *unspecified*) - -(define (thread-sleep! timeout) - (let* ((ct (time->seconds (current-time))) - (t (cond ((time? timeout) (- (time->seconds timeout) ct)) - ((number? timeout) (- timeout ct)) - (else (scm-error 'wrong-type-arg caller - "Wrong type argument: ~S" - (list timeout) - '())))) - (secs (inexact->exact (truncate t))) - (usecs (inexact->exact (truncate (* (- t secs) 1000))))) - (and (> secs 0) (sleep secs)) - (and (> usecs 0) (usleep usecs)) - *unspecified*)) - -;; A convenience function for installing exception handlers on SRFI-18 -;; primitives that resume the calling continuation after the handler is -;; invoked -- this resolves a behavioral incompatibility with Guile's -;; implementation of SRFI-34, which uses lazy-catch and rethrows handled -;; exceptions. (SRFI-18, "Primitives and exceptions") - -(define (wrap thunk) - (lambda (continuation) - (with-exception-handler (lambda (obj) - (apply (current-exception-handler) (list obj)) - (apply continuation (list))) - thunk))) - -;; A pass-thru to cancel-thread that first installs a handler that throws -;; terminated-thread exception, as per SRFI-18, - -(define (thread-terminate! thread) - (define (thread-terminate-inner!) - (let ((current-handler (thread-cleanup thread))) - (if (thunk? current-handler) - (set-thread-cleanup! thread - (lambda () - (with-exception-handler initial-handler - current-handler) - (srfi-18-exception-preserver - terminated-thread-exception))) - (set-thread-cleanup! thread - (lambda () (srfi-18-exception-preserver - terminated-thread-exception)))) - (cancel-thread thread) - *unspecified*)) - (thread-terminate-inner!)) - -(define (thread-join! thread . args) - (define thread-join-inner! - (wrap (lambda () - (let ((v (apply join-thread (cons thread args))) - (e (thread->exception thread))) - (if (and (= (length args) 1) (not v)) - (raise join-timeout-exception)) - (if e (raise e)) - v)))) - (call/cc thread-join-inner!)) - -;; MUTEXES -;; These functions are all pass-thrus to the existing Guile implementations. - -(define make-mutex - (lambda name - (let ((n (and (pair? name) (car name))) - (m ((@ (guile) make-mutex) - 'unchecked-unlock - 'allow-external-unlock - 'recursive))) - (and n (hashq-set! object-names m n)) m))) - -(define (mutex-name mutex) - (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name"))) - -(define (mutex-specific mutex) - (hashq-ref object-specifics - (check-arg-type mutex? mutex "mutex-specific"))) - -(define (mutex-specific-set! mutex obj) - (hashq-set! object-specifics - (check-arg-type mutex? mutex "mutex-specific-set!") - obj) - *unspecified*) - -(define (mutex-state mutex) - (let ((owner (mutex-owner mutex))) - (if owner - (if (thread-exited? owner) 'abandoned owner) - (if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned)))) - -(define (mutex-lock! mutex . args) - (define mutex-lock-inner! - (wrap (lambda () - (catch 'abandoned-mutex-error - (lambda () (apply lock-mutex (cons mutex args))) - (lambda (key . args) (raise abandoned-mutex-exception)))))) - (call/cc mutex-lock-inner!)) - -(define (mutex-unlock! mutex . args) - (apply unlock-mutex (cons mutex args))) - -;; CONDITION VARIABLES -;; These functions are all pass-thrus to the existing Guile implementations. - -(define make-condition-variable - (lambda name - (let ((n (and (pair? name) (car name))) - (m ((@ (guile) make-condition-variable)))) - (and n (hashq-set! object-names m n)) m))) - -(define (condition-variable-name condition-variable) - (hashq-ref object-names (check-arg-type condition-variable? - condition-variable - "condition-variable-name"))) - -(define (condition-variable-specific condition-variable) - (hashq-ref object-specifics (check-arg-type condition-variable? - condition-variable - "condition-variable-specific"))) - -(define (condition-variable-specific-set! condition-variable obj) - (hashq-set! object-specifics - (check-arg-type condition-variable? - condition-variable - "condition-variable-specific-set!") - obj) - *unspecified*) - -(define (condition-variable-signal! cond) - (signal-condition-variable cond) - *unspecified*) - -(define (condition-variable-broadcast! cond) - (broadcast-condition-variable cond) - *unspecified*) - -;; TIME - -(define current-time gettimeofday) -(define (time? obj) - (and (pair? obj) - (let ((co (car obj))) (and (integer? co) (>= co 0))) - (let ((co (cdr obj))) (and (integer? co) (>= co 0))))) - -(define (time->seconds time) - (and (check-arg-type time? time "time->seconds") - (+ (car time) (/ (cdr time) 1000000)))) - -(define (seconds->time x) - (and (check-arg-type number? x "seconds->time") - (let ((fx (truncate x))) - (cons (inexact->exact fx) - (inexact->exact (truncate (* (- x fx) 1000000))))))) - -;; srfi-18.scm ends here
\ No newline at end of file diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm deleted file mode 100644 index 5b78cad70..000000000 --- a/srfi/srfi-19.scm +++ /dev/null @@ -1,1491 +0,0 @@ -;;; srfi-19.scm --- Time/Date Library - -;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: Rob Browning <rlb@cs.utexas.edu> -;;; Originally from SRFI reference implementation by Will Fitzgerald. - -;;; Commentary: - -;; This module is fully documented in the Guile Reference Manual. - -;;; Code: - -;; FIXME: I haven't checked a decent amount of this code for potential -;; performance improvements, but I suspect that there may be some -;; substantial ones to be realized, esp. in the later "parsing" half -;; of the file, by rewriting the code with use of more Guile native -;; functions that do more work in a "chunk". -;; -;; FIXME: mkoeppe: Time zones are treated a little simplistic in -;; SRFI-19; they are only a numeric offset. Thus, printing time zones -;; (PRIV:LOCALE-PRINT-TIME-ZONE) can't be implemented sensibly. The -;; functions taking an optional TZ-OFFSET should be extended to take a -;; symbolic time-zone (like "CET"); this string should be stored in -;; the DATE structure. - -(define-module (srfi srfi-19) - :use-module (srfi srfi-6) - :use-module (srfi srfi-8) - :use-module (srfi srfi-9) - :use-module (ice-9 i18n)) - -(begin-deprecated - ;; Prevent `export' from re-exporting core bindings. This behaviour - ;; of `export' is deprecated and will disappear in one of the next - ;; releases. - (define current-time #f)) - -(export ;; Constants - time-duration - time-monotonic - time-process - time-tai - time-thread - time-utc - ;; Current time and clock resolution - current-date - current-julian-day - current-modified-julian-day - current-time - time-resolution - ;; Time object and accessors - make-time - time? - time-type - time-nanosecond - time-second - set-time-type! - set-time-nanosecond! - set-time-second! - copy-time - ;; Time comparison procedures - time<=? - time<? - time=? - time>=? - time>? - ;; Time arithmetic procedures - time-difference - time-difference! - add-duration - add-duration! - subtract-duration - subtract-duration! - ;; Date object and accessors - make-date - date? - date-nanosecond - date-second - date-minute - date-hour - date-day - date-month - date-year - date-zone-offset - date-year-day - date-week-day - date-week-number - ;; Time/Date/Julian Day/Modified Julian Day converters - date->julian-day - date->modified-julian-day - date->time-monotonic - date->time-tai - date->time-utc - julian-day->date - julian-day->time-monotonic - julian-day->time-tai - julian-day->time-utc - modified-julian-day->date - modified-julian-day->time-monotonic - modified-julian-day->time-tai - modified-julian-day->time-utc - time-monotonic->date - time-monotonic->time-tai - time-monotonic->time-tai! - time-monotonic->time-utc - time-monotonic->time-utc! - time-tai->date - time-tai->julian-day - time-tai->modified-julian-day - time-tai->time-monotonic - time-tai->time-monotonic! - time-tai->time-utc - time-tai->time-utc! - time-utc->date - time-utc->julian-day - time-utc->modified-julian-day - time-utc->time-monotonic - time-utc->time-monotonic! - time-utc->time-tai - time-utc->time-tai! - ;; Date to string/string to date converters. - date->string - string->date) - -(cond-expand-provide (current-module) '(srfi-19)) - -(define time-tai 'time-tai) -(define time-utc 'time-utc) -(define time-monotonic 'time-monotonic) -(define time-thread 'time-thread) -(define time-process 'time-process) -(define time-duration 'time-duration) - -;; FIXME: do we want to add gc time? -;; (define time-gc 'time-gc) - -;;-- LOCALE dependent constants - -(define priv:locale-number-separator locale-decimal-point) -(define priv:locale-pm locale-pm-string) -(define priv:locale-am locale-am-string) - -;; See date->string -(define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y") -(define priv:locale-short-date-format "~m/~d/~y") -(define priv:locale-time-format "~H:~M:~S") -(define priv:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z") - -;;-- Miscellaneous Constants. -;;-- only the priv:tai-epoch-in-jd might need changing if -;; a different epoch is used. - -(define priv:nano 1000000000) ; nanoseconds in a second -(define priv:sid 86400) ; seconds in a day -(define priv:sihd 43200) ; seconds in a half day -(define priv:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch' - -;; FIXME: should this be something other than misc-error? -(define (priv:time-error caller type value) - (if value - (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f) - (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f))) - -;; A table of leap seconds -;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat -;; and update as necessary. -;; this procedures reads the file in the abover -;; format and creates the leap second table -;; it also calls the almost standard, but not R5 procedures read-line -;; & open-input-string -;; ie (set! priv:leap-second-table (priv:read-tai-utc-date "tai-utc.dat")) - -(define (priv:read-tai-utc-data filename) - (define (convert-jd jd) - (* (- (inexact->exact jd) priv:tai-epoch-in-jd) priv:sid)) - (define (convert-sec sec) - (inexact->exact sec)) - (let ((port (open-input-file filename)) - (table '())) - (let loop ((line (read-line port))) - (if (not (eof-object? line)) - (begin - (let* ((data (read (open-input-string - (string-append "(" line ")")))) - (year (car data)) - (jd (cadddr (cdr data))) - (secs (cadddr (cdddr data)))) - (if (>= year 1972) - (set! table (cons - (cons (convert-jd jd) (convert-sec secs)) - table))) - (loop (read-line port)))))) - table)) - -;; each entry is (tai seconds since epoch . # seconds to subtract for utc) -;; note they go higher to lower, and end in 1972. -(define priv:leap-second-table - '((1136073600 . 33) - (915148800 . 32) - (867715200 . 31) - (820454400 . 30) - (773020800 . 29) - (741484800 . 28) - (709948800 . 27) - (662688000 . 26) - (631152000 . 25) - (567993600 . 24) - (489024000 . 23) - (425865600 . 22) - (394329600 . 21) - (362793600 . 20) - (315532800 . 19) - (283996800 . 18) - (252460800 . 17) - (220924800 . 16) - (189302400 . 15) - (157766400 . 14) - (126230400 . 13) - (94694400 . 12) - (78796800 . 11) - (63072000 . 10))) - -(define (read-leap-second-table filename) - (set! priv:leap-second-table (priv:read-tai-utc-data filename)) - (values)) - - -(define (priv:leap-second-delta utc-seconds) - (letrec ((lsd (lambda (table) - (cond ((>= utc-seconds (caar table)) - (cdar table)) - (else (lsd (cdr table))))))) - (if (< utc-seconds (* (- 1972 1970) 365 priv:sid)) 0 - (lsd priv:leap-second-table)))) - - -;;; the TIME structure; creates the accessors, too. - -(define-record-type time - (make-time-unnormalized type nanosecond second) - time? - (type time-type set-time-type!) - (nanosecond time-nanosecond set-time-nanosecond!) - (second time-second set-time-second!)) - -(define (copy-time time) - (make-time (time-type time) (time-nanosecond time) (time-second time))) - -(define (priv:split-real r) - (if (integer? r) - (values (inexact->exact r) 0) - (let ((l (truncate r))) - (values (inexact->exact l) (- r l))))) - -(define (priv:time-normalize! t) - (if (>= (abs (time-nanosecond t)) 1000000000) - (receive (int frac) - (priv:split-real (time-nanosecond t)) - (set-time-second! t (+ (time-second t) - (quotient int 1000000000))) - (set-time-nanosecond! t (+ (remainder int 1000000000) - frac)))) - (if (and (positive? (time-second t)) - (negative? (time-nanosecond t))) - (begin - (set-time-second! t (- (time-second t) 1)) - (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))) - (if (and (negative? (time-second t)) - (positive? (time-nanosecond t))) - (begin - (set-time-second! t (+ (time-second t) 1)) - (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))))) - t) - -(define (make-time type nanosecond second) - (priv:time-normalize! (make-time-unnormalized type nanosecond second))) - -;; Helpers -;; FIXME: finish this and publish it? -(define (date->broken-down-time date) - (let ((result (mktime 0))) - ;; FIXME: What should we do about leap-seconds which may overflow - ;; set-tm:sec? - (set-tm:sec result (date-second date)) - (set-tm:min result (date-minute date)) - (set-tm:hour result (date-hour date)) - ;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday). - (set-tm:mday result (date-day date)) - (set-tm:month result (- (date-month date) 1)) - ;; FIXME: need to signal error on range violation. - (set-tm:year result (+ 1900 (date-year date))) - (set-tm:isdst result -1) - (set-tm:gmtoff result (- (date-zone-offset date))) - result)) - -;;; current-time - -;;; specific time getters. - -(define (priv:current-time-utc) - ;; Resolution is microseconds. - (let ((tod (gettimeofday))) - (make-time time-utc (* (cdr tod) 1000) (car tod)))) - -(define (priv:current-time-tai) - ;; Resolution is microseconds. - (let* ((tod (gettimeofday)) - (sec (car tod)) - (usec (cdr tod))) - (make-time time-tai - (* usec 1000) - (+ (car tod) (priv:leap-second-delta sec))))) - -;;(define (priv:current-time-ms-time time-type proc) -;; (let ((current-ms (proc))) -;; (make-time time-type -;; (quotient current-ms 10000) -;; (* (remainder current-ms 1000) 10000)))) - -;; -- we define it to be the same as TAI. -;; A different implemation of current-time-montonic -;; will require rewriting all of the time-monotonic converters, -;; of course. - -(define (priv:current-time-monotonic) - ;; Resolution is microseconds. - (priv:current-time-tai)) - -(define (priv:current-time-thread) - (priv:time-error 'current-time 'unsupported-clock-type 'time-thread)) - -(define priv:ns-per-guile-tick (/ 1000000000 internal-time-units-per-second)) - -(define (priv:current-time-process) - (let ((run-time (get-internal-run-time))) - (make-time - time-process - (* (remainder run-time internal-time-units-per-second) - priv:ns-per-guile-tick) - (quotient run-time internal-time-units-per-second)))) - -;;(define (priv:current-time-gc) -;; (priv:current-time-ms-time time-gc current-gc-milliseconds)) - -(define (current-time . clock-type) - (let ((clock-type (if (null? clock-type) time-utc (car clock-type)))) - (cond - ((eq? clock-type time-tai) (priv:current-time-tai)) - ((eq? clock-type time-utc) (priv:current-time-utc)) - ((eq? clock-type time-monotonic) (priv:current-time-monotonic)) - ((eq? clock-type time-thread) (priv:current-time-thread)) - ((eq? clock-type time-process) (priv:current-time-process)) - ;; ((eq? clock-type time-gc) (priv:current-time-gc)) - (else (priv:time-error 'current-time 'invalid-clock-type clock-type))))) - -;; -- Time Resolution -;; This is the resolution of the clock in nanoseconds. -;; This will be implementation specific. - -(define (time-resolution . clock-type) - (let ((clock-type (if (null? clock-type) time-utc (car clock-type)))) - (case clock-type - ((time-tai) 1000) - ((time-utc) 1000) - ((time-monotonic) 1000) - ((time-process) priv:ns-per-guile-tick) - ;; ((eq? clock-type time-thread) 1000) - ;; ((eq? clock-type time-gc) 10000) - (else (priv:time-error 'time-resolution 'invalid-clock-type clock-type))))) - -;; -- Time comparisons - -(define (time=? t1 t2) - ;; Arrange tests for speed and presume that t1 and t2 are actually times. - ;; also presume it will be rare to check two times of different types. - (and (= (time-second t1) (time-second t2)) - (= (time-nanosecond t1) (time-nanosecond t2)) - (eq? (time-type t1) (time-type t2)))) - -(define (time>? t1 t2) - (or (> (time-second t1) (time-second t2)) - (and (= (time-second t1) (time-second t2)) - (> (time-nanosecond t1) (time-nanosecond t2))))) - -(define (time<? t1 t2) - (or (< (time-second t1) (time-second t2)) - (and (= (time-second t1) (time-second t2)) - (< (time-nanosecond t1) (time-nanosecond t2))))) - -(define (time>=? t1 t2) - (or (> (time-second t1) (time-second t2)) - (and (= (time-second t1) (time-second t2)) - (>= (time-nanosecond t1) (time-nanosecond t2))))) - -(define (time<=? t1 t2) - (or (< (time-second t1) (time-second t2)) - (and (= (time-second t1) (time-second t2)) - (<= (time-nanosecond t1) (time-nanosecond t2))))) - -;; -- Time arithmetic - -(define (time-difference! time1 time2) - (let ((sec-diff (- (time-second time1) (time-second time2))) - (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2)))) - (set-time-type! time1 time-duration) - (set-time-second! time1 sec-diff) - (set-time-nanosecond! time1 nsec-diff) - (priv:time-normalize! time1))) - -(define (time-difference time1 time2) - (let ((result (copy-time time1))) - (time-difference! result time2))) - -(define (add-duration! t duration) - (if (not (eq? (time-type duration) time-duration)) - (priv:time-error 'add-duration 'not-duration duration) - (let ((sec-plus (+ (time-second t) (time-second duration))) - (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration)))) - (set-time-second! t sec-plus) - (set-time-nanosecond! t nsec-plus) - (priv:time-normalize! t)))) - -(define (add-duration t duration) - (let ((result (copy-time t))) - (add-duration! result duration))) - -(define (subtract-duration! t duration) - (if (not (eq? (time-type duration) time-duration)) - (priv:time-error 'add-duration 'not-duration duration) - (let ((sec-minus (- (time-second t) (time-second duration))) - (nsec-minus (- (time-nanosecond t) (time-nanosecond duration)))) - (set-time-second! t sec-minus) - (set-time-nanosecond! t nsec-minus) - (priv:time-normalize! t)))) - -(define (subtract-duration time1 duration) - (let ((result (copy-time time1))) - (subtract-duration! result duration))) - -;; -- Converters between types. - -(define (priv:time-tai->time-utc! time-in time-out caller) - (if (not (eq? (time-type time-in) time-tai)) - (priv:time-error caller 'incompatible-time-types time-in)) - (set-time-type! time-out time-utc) - (set-time-nanosecond! time-out (time-nanosecond time-in)) - (set-time-second! time-out (- (time-second time-in) - (priv:leap-second-delta - (time-second time-in)))) - time-out) - -(define (time-tai->time-utc time-in) - (priv:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc)) - - -(define (time-tai->time-utc! time-in) - (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!)) - -(define (priv:time-utc->time-tai! time-in time-out caller) - (if (not (eq? (time-type time-in) time-utc)) - (priv:time-error caller 'incompatible-time-types time-in)) - (set-time-type! time-out time-tai) - (set-time-nanosecond! time-out (time-nanosecond time-in)) - (set-time-second! time-out (+ (time-second time-in) - (priv:leap-second-delta - (time-second time-in)))) - time-out) - -(define (time-utc->time-tai time-in) - (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai)) - -(define (time-utc->time-tai! time-in) - (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!)) - -;; -- these depend on time-monotonic having the same definition as time-tai! -(define (time-monotonic->time-utc time-in) - (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) - (let ((ntime (copy-time time-in))) - (set-time-type! ntime time-tai) - (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))) - -(define (time-monotonic->time-utc! time-in) - (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) - (set-time-type! time-in time-tai) - (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)) - -(define (time-monotonic->time-tai time-in) - (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) - (let ((ntime (copy-time time-in))) - (set-time-type! ntime time-tai) - ntime)) - -(define (time-monotonic->time-tai! time-in) - (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) - (set-time-type! time-in time-tai) - time-in) - -(define (time-utc->time-monotonic time-in) - (if (not (eq? (time-type time-in) time-utc)) - (priv:time-error caller 'incompatible-time-types time-in)) - (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) - 'time-utc->time-monotonic))) - (set-time-type! ntime time-monotonic) - ntime)) - -(define (time-utc->time-monotonic! time-in) - (if (not (eq? (time-type time-in) time-utc)) - (priv:time-error caller 'incompatible-time-types time-in)) - (let ((ntime (priv:time-utc->time-tai! time-in time-in - 'time-utc->time-monotonic!))) - (set-time-type! ntime time-monotonic) - ntime)) - -(define (time-tai->time-monotonic time-in) - (if (not (eq? (time-type time-in) time-tai)) - (priv:time-error caller 'incompatible-time-types time-in)) - (let ((ntime (copy-time time-in))) - (set-time-type! ntime time-monotonic) - ntime)) - -(define (time-tai->time-monotonic! time-in) - (if (not (eq? (time-type time-in) time-tai)) - (priv:time-error caller 'incompatible-time-types time-in)) - (set-time-type! time-in time-monotonic) - time-in) - -;; -- Date Structures - -;; FIXME: to be really safe, perhaps we should normalize the -;; seconds/nanoseconds/minutes coming in to make-date... - -(define-record-type date - (make-date nanosecond second minute - hour day month - year - zone-offset) - date? - (nanosecond date-nanosecond set-date-nanosecond!) - (second date-second set-date-second!) - (minute date-minute set-date-minute!) - (hour date-hour set-date-hour!) - (day date-day set-date-day!) - (month date-month set-date-month!) - (year date-year set-date-year!) - (zone-offset date-zone-offset set-date-zone-offset!)) - -;; gives the julian day which starts at noon. -(define (priv:encode-julian-day-number day month year) - (let* ((a (quotient (- 14 month) 12)) - (y (- (+ year 4800) a (if (negative? year) -1 0))) - (m (- (+ month (* 12 a)) 3))) - (+ day - (quotient (+ (* 153 m) 2) 5) - (* 365 y) - (quotient y 4) - (- (quotient y 100)) - (quotient y 400) - -32045))) - -;; gives the seconds/date/month/year -(define (priv:decode-julian-day-number jdn) - (let* ((days (inexact->exact (truncate jdn))) - (a (+ days 32044)) - (b (quotient (+ (* 4 a) 3) 146097)) - (c (- a (quotient (* 146097 b) 4))) - (d (quotient (+ (* 4 c) 3) 1461)) - (e (- c (quotient (* 1461 d) 4))) - (m (quotient (+ (* 5 e) 2) 153)) - (y (+ (* 100 b) d -4800 (quotient m 10)))) - (values ; seconds date month year - (* (- jdn days) priv:sid) - (+ e (- (quotient (+ (* 153 m) 2) 5)) 1) - (+ m 3 (* -12 (quotient m 10))) - (if (>= 0 y) (- y 1) y)))) - -;; relies on the fact that we named our time zone accessor -;; differently from MzScheme's.... -;; This should be written to be OS specific. - -(define (priv:local-tz-offset utc-time) - ;; SRFI uses seconds West, but guile (and libc) use seconds East. - (- (tm:gmtoff (localtime (time-second utc-time))))) - -;; special thing -- ignores nanos -(define (priv:time->julian-day-number seconds tz-offset) - (+ (/ (+ seconds tz-offset priv:sihd) - priv:sid) - priv:tai-epoch-in-jd)) - -(define (priv:leap-second? second) - (and (assoc second priv:leap-second-table) #t)) - -(define (time-utc->date time . tz-offset) - (if (not (eq? (time-type time) time-utc)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) - (priv:local-tz-offset time) - (car tz-offset))) - (leap-second? (priv:leap-second? (+ offset (time-second time)))) - (jdn (priv:time->julian-day-number (if leap-second? - (- (time-second time) 1) - (time-second time)) - offset))) - - (call-with-values (lambda () (priv:decode-julian-day-number jdn)) - (lambda (secs date month year) - ;; secs is a real because jdn is a real in Guile; - ;; but it is conceptionally an integer. - (let* ((int-secs (inexact->exact (round secs))) - (hours (quotient int-secs (* 60 60))) - (rem (remainder int-secs (* 60 60))) - (minutes (quotient rem 60)) - (seconds (remainder rem 60))) - (make-date (time-nanosecond time) - (if leap-second? (+ seconds 1) seconds) - minutes - hours - date - month - year - offset)))))) - -(define (time-tai->date time . tz-offset) - (if (not (eq? (time-type time) time-tai)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) - (priv:local-tz-offset (time-tai->time-utc time)) - (car tz-offset))) - (seconds (- (time-second time) - (priv:leap-second-delta (time-second time)))) - (leap-second? (priv:leap-second? (+ offset seconds))) - (jdn (priv:time->julian-day-number (if leap-second? - (- seconds 1) - seconds) - offset))) - (call-with-values (lambda () (priv:decode-julian-day-number jdn)) - (lambda (secs date month year) - ;; secs is a real because jdn is a real in Guile; - ;; but it is conceptionally an integer. - ;; adjust for leap seconds if necessary ... - (let* ((int-secs (inexact->exact (round secs))) - (hours (quotient int-secs (* 60 60))) - (rem (remainder int-secs (* 60 60))) - (minutes (quotient rem 60)) - (seconds (remainder rem 60))) - (make-date (time-nanosecond time) - (if leap-second? (+ seconds 1) seconds) - minutes - hours - date - month - year - offset)))))) - -;; this is the same as time-tai->date. -(define (time-monotonic->date time . tz-offset) - (if (not (eq? (time-type time) time-monotonic)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) - (priv:local-tz-offset (time-monotonic->time-utc time)) - (car tz-offset))) - (seconds (- (time-second time) - (priv:leap-second-delta (time-second time)))) - (leap-second? (priv:leap-second? (+ offset seconds))) - (jdn (priv:time->julian-day-number (if leap-second? - (- seconds 1) - seconds) - offset))) - (call-with-values (lambda () (priv:decode-julian-day-number jdn)) - (lambda (secs date month year) - ;; secs is a real because jdn is a real in Guile; - ;; but it is conceptionally an integer. - ;; adjust for leap seconds if necessary ... - (let* ((int-secs (inexact->exact (round secs))) - (hours (quotient int-secs (* 60 60))) - (rem (remainder int-secs (* 60 60))) - (minutes (quotient rem 60)) - (seconds (remainder rem 60))) - (make-date (time-nanosecond time) - (if leap-second? (+ seconds 1) seconds) - minutes - hours - date - month - year - offset)))))) - -(define (date->time-utc date) - (let* ((jdays (- (priv:encode-julian-day-number (date-day date) - (date-month date) - (date-year date)) - priv:tai-epoch-in-jd)) - ;; jdays is an integer plus 1/2, - (jdays-1/2 (inexact->exact (- jdays 1/2)))) - (make-time - time-utc - (date-nanosecond date) - (+ (* jdays-1/2 24 60 60) - (* (date-hour date) 60 60) - (* (date-minute date) 60) - (date-second date) - (- (date-zone-offset date)))))) - -(define (date->time-tai date) - (time-utc->time-tai! (date->time-utc date))) - -(define (date->time-monotonic date) - (time-utc->time-monotonic! (date->time-utc date))) - -(define (priv:leap-year? year) - (or (= (modulo year 400) 0) - (and (= (modulo year 4) 0) (not (= (modulo year 100) 0))))) - -(define (leap-year? date) - (priv:leap-year? (date-year date))) - -;; Map 1-based month number M to number of days in the year before the -;; start of month M (in a non-leap year). -(define priv:month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90) - (5 . 120) (6 . 151) (7 . 181) (8 . 212) - (9 . 243) (10 . 273) (11 . 304) (12 . 334))) - -(define (priv:year-day day month year) - (let ((days-pr (assoc month priv:month-assoc))) - (if (not days-pr) - (priv:error 'date-year-day 'invalid-month-specification month)) - (if (and (priv:leap-year? year) (> month 2)) - (+ day (cdr days-pr) 1) - (+ day (cdr days-pr))))) - -(define (date-year-day date) - (priv:year-day (date-day date) (date-month date) (date-year date))) - -;; from calendar faq -(define (priv:week-day day month year) - (let* ((a (quotient (- 14 month) 12)) - (y (- year a)) - (m (+ month (* 12 a) -2))) - (modulo (+ day - y - (quotient y 4) - (- (quotient y 100)) - (quotient y 400) - (quotient (* 31 m) 12)) - 7))) - -(define (date-week-day date) - (priv:week-day (date-day date) (date-month date) (date-year date))) - -(define (priv:days-before-first-week date day-of-week-starting-week) - (let* ((first-day (make-date 0 0 0 0 - 1 - 1 - (date-year date) - #f)) - (fdweek-day (date-week-day first-day))) - (modulo (- day-of-week-starting-week fdweek-day) - 7))) - -;; The "-1" here is a fix for the reference implementation, to make a new -;; week start on the given day-of-week-starting-week. date-year-day returns -;; a day starting from 1 for 1st Jan. -;; -(define (date-week-number date day-of-week-starting-week) - (quotient (- (date-year-day date) - 1 - (priv:days-before-first-week date day-of-week-starting-week)) - 7)) - -(define (current-date . tz-offset) - (let ((time (current-time time-utc))) - (time-utc->date - time - (if (null? tz-offset) - (priv:local-tz-offset time) - (car tz-offset))))) - -;; given a 'two digit' number, find the year within 50 years +/- -(define (priv:natural-year n) - (let* ((current-year (date-year (current-date))) - (current-century (* (quotient current-year 100) 100))) - (cond - ((>= n 100) n) - ((< n 0) n) - ((<= (- (+ current-century n) current-year) 50) (+ current-century n)) - (else (+ (- current-century 100) n))))) - -(define (date->julian-day date) - (let ((nanosecond (date-nanosecond date)) - (second (date-second date)) - (minute (date-minute date)) - (hour (date-hour date)) - (day (date-day date)) - (month (date-month date)) - (year (date-year date)) - (offset (date-zone-offset date))) - (+ (priv:encode-julian-day-number day month year) - (- 1/2) - (+ (/ (+ (- offset) - (* hour 60 60) - (* minute 60) - second - (/ nanosecond priv:nano)) - priv:sid))))) - -(define (date->modified-julian-day date) - (- (date->julian-day date) - 4800001/2)) - -(define (time-utc->julian-day time) - (if (not (eq? (time-type time) time-utc)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (+ (/ (+ (time-second time) (/ (time-nanosecond time) priv:nano)) - priv:sid) - priv:tai-epoch-in-jd)) - -(define (time-utc->modified-julian-day time) - (- (time-utc->julian-day time) - 4800001/2)) - -(define (time-tai->julian-day time) - (if (not (eq? (time-type time) time-tai)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (+ (/ (+ (- (time-second time) - (priv:leap-second-delta (time-second time))) - (/ (time-nanosecond time) priv:nano)) - priv:sid) - priv:tai-epoch-in-jd)) - -(define (time-tai->modified-julian-day time) - (- (time-tai->julian-day time) - 4800001/2)) - -;; this is the same as time-tai->julian-day -(define (time-monotonic->julian-day time) - (if (not (eq? (time-type time) time-monotonic)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (+ (/ (+ (- (time-second time) - (priv:leap-second-delta (time-second time))) - (/ (time-nanosecond time) priv:nano)) - priv:sid) - priv:tai-epoch-in-jd)) - -(define (time-monotonic->modified-julian-day time) - (- (time-monotonic->julian-day time) - 4800001/2)) - -(define (julian-day->time-utc jdn) - (let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd)))) - (receive (seconds parts) - (priv:split-real secs) - (make-time time-utc - (* parts priv:nano) - seconds)))) - -(define (julian-day->time-tai jdn) - (time-utc->time-tai! (julian-day->time-utc jdn))) - -(define (julian-day->time-monotonic jdn) - (time-utc->time-monotonic! (julian-day->time-utc jdn))) - -(define (julian-day->date jdn . tz-offset) - (let* ((time (julian-day->time-utc jdn)) - (offset (if (null? tz-offset) - (priv:local-tz-offset time) - (car tz-offset)))) - (time-utc->date time offset))) - -(define (modified-julian-day->date jdn . tz-offset) - (apply julian-day->date (+ jdn 4800001/2) - tz-offset)) - -(define (modified-julian-day->time-utc jdn) - (julian-day->time-utc (+ jdn 4800001/2))) - -(define (modified-julian-day->time-tai jdn) - (julian-day->time-tai (+ jdn 4800001/2))) - -(define (modified-julian-day->time-monotonic jdn) - (julian-day->time-monotonic (+ jdn 4800001/2))) - -(define (current-julian-day) - (time-utc->julian-day (current-time time-utc))) - -(define (current-modified-julian-day) - (time-utc->modified-julian-day (current-time time-utc))) - -;; returns a string rep. of number N, of minimum LENGTH, padded with -;; character PAD-WITH. If PAD-WITH is #f, no padding is done, and it's -;; as if number->string was used. if string is longer than or equal -;; in length to LENGTH, it's as if number->string was used. - -(define (priv:padding n pad-with length) - (let* ((str (number->string n)) - (str-len (string-length str))) - (if (or (>= str-len length) - (not pad-with)) - str - (string-append (make-string (- length str-len) pad-with) str)))) - -(define (priv:last-n-digits i n) - (abs (remainder i (expt 10 n)))) - -(define (priv:locale-abbr-weekday n) (locale-day-short (+ 1 n))) -(define (priv:locale-long-weekday n) (locale-day (+ 1 n))) -(define priv:locale-abbr-month locale-month-short) -(define priv:locale-long-month locale-month) - -(define (priv:date-reverse-lookup needle haystack-ref haystack-len - same?) - ;; Lookup NEEDLE (a string) using HAYSTACK-REF (a one argument procedure - ;; that returns a string corresponding to the given index) by passing it - ;; indices lower than HAYSTACK-LEN. - (let loop ((index 1)) - (cond ((> index haystack-len) #f) - ((same? needle (haystack-ref index)) - index) - (else (loop (+ index 1)))))) - -(define (priv:locale-abbr-weekday->index string) - (priv:date-reverse-lookup string locale-day-short 7 string=?)) - -(define (priv:locale-long-weekday->index string) - (priv:date-reverse-lookup string locale-day 7 string=?)) - -(define (priv:locale-abbr-month->index string) - (priv:date-reverse-lookup string priv:locale-abbr-month 12 string=?)) - -(define (priv:locale-long-month->index string) - (priv:date-reverse-lookup string priv:locale-long-month 12 string=?)) - - -;; FIXME: mkoeppe: Put a symbolic time zone in the date structs. -;; Print it here instead of the numerical offset if available. -(define (priv:locale-print-time-zone date port) - (priv:tz-printer (date-zone-offset date) port)) - -(define (priv:locale-am/pm hr) - (if (> hr 11) (priv:locale-pm) (priv:locale-am))) - -(define (priv:tz-printer offset port) - (cond - ((= offset 0) (display "Z" port)) - ((negative? offset) (display "-" port)) - (else (display "+" port))) - (if (not (= offset 0)) - (let ((hours (abs (quotient offset (* 60 60)))) - (minutes (abs (quotient (remainder offset (* 60 60)) 60)))) - (display (priv:padding hours #\0 2) port) - (display (priv:padding minutes #\0 2) port)))) - -;; A table of output formatting directives. -;; the first time is the format char. -;; the second is a procedure that takes the date, a padding character -;; (which might be #f), and the output port. -;; -(define priv:directives - (list - (cons #\~ (lambda (date pad-with port) - (display #\~ port))) - (cons #\a (lambda (date pad-with port) - (display (priv:locale-abbr-weekday (date-week-day date)) - port))) - (cons #\A (lambda (date pad-with port) - (display (priv:locale-long-weekday (date-week-day date)) - port))) - (cons #\b (lambda (date pad-with port) - (display (priv:locale-abbr-month (date-month date)) - port))) - (cons #\B (lambda (date pad-with port) - (display (priv:locale-long-month (date-month date)) - port))) - (cons #\c (lambda (date pad-with port) - (display (date->string date priv:locale-date-time-format) port))) - (cons #\d (lambda (date pad-with port) - (display (priv:padding (date-day date) - #\0 2) - port))) - (cons #\D (lambda (date pad-with port) - (display (date->string date "~m/~d/~y") port))) - (cons #\e (lambda (date pad-with port) - (display (priv:padding (date-day date) - #\Space 2) - port))) - (cons #\f (lambda (date pad-with port) - (if (> (date-nanosecond date) - priv:nano) - (display (priv:padding (+ (date-second date) 1) - pad-with 2) - port) - (display (priv:padding (date-second date) - pad-with 2) - port)) - (receive (i f) - (priv:split-real (/ - (date-nanosecond date) - priv:nano 1.0)) - (let* ((ns (number->string f)) - (le (string-length ns))) - (if (> le 2) - (begin - (display (priv:locale-number-separator) port) - (display (substring ns 2 le) port))))))) - (cons #\h (lambda (date pad-with port) - (display (date->string date "~b") port))) - (cons #\H (lambda (date pad-with port) - (display (priv:padding (date-hour date) - pad-with 2) - port))) - (cons #\I (lambda (date pad-with port) - (let ((hr (date-hour date))) - (if (> hr 12) - (display (priv:padding (- hr 12) - pad-with 2) - port) - (display (priv:padding hr - pad-with 2) - port))))) - (cons #\j (lambda (date pad-with port) - (display (priv:padding (date-year-day date) - pad-with 3) - port))) - (cons #\k (lambda (date pad-with port) - (display (priv:padding (date-hour date) - #\Space 2) - port))) - (cons #\l (lambda (date pad-with port) - (let ((hr (if (> (date-hour date) 12) - (- (date-hour date) 12) (date-hour date)))) - (display (priv:padding hr #\Space 2) - port)))) - (cons #\m (lambda (date pad-with port) - (display (priv:padding (date-month date) - pad-with 2) - port))) - (cons #\M (lambda (date pad-with port) - (display (priv:padding (date-minute date) - pad-with 2) - port))) - (cons #\n (lambda (date pad-with port) - (newline port))) - (cons #\N (lambda (date pad-with port) - (display (priv:padding (date-nanosecond date) - pad-with 7) - port))) - (cons #\p (lambda (date pad-with port) - (display (priv:locale-am/pm (date-hour date)) port))) - (cons #\r (lambda (date pad-with port) - (display (date->string date "~I:~M:~S ~p") port))) - (cons #\s (lambda (date pad-with port) - (display (time-second (date->time-utc date)) port))) - (cons #\S (lambda (date pad-with port) - (if (> (date-nanosecond date) - priv:nano) - (display (priv:padding (+ (date-second date) 1) - pad-with 2) - port) - (display (priv:padding (date-second date) - pad-with 2) - port)))) - (cons #\t (lambda (date pad-with port) - (display #\Tab port))) - (cons #\T (lambda (date pad-with port) - (display (date->string date "~H:~M:~S") port))) - (cons #\U (lambda (date pad-with port) - (if (> (priv:days-before-first-week date 0) 0) - (display (priv:padding (+ (date-week-number date 0) 1) - #\0 2) port) - (display (priv:padding (date-week-number date 0) - #\0 2) port)))) - (cons #\V (lambda (date pad-with port) - (display (priv:padding (date-week-number date 1) - #\0 2) port))) - (cons #\w (lambda (date pad-with port) - (display (date-week-day date) port))) - (cons #\x (lambda (date pad-with port) - (display (date->string date priv:locale-short-date-format) port))) - (cons #\X (lambda (date pad-with port) - (display (date->string date priv:locale-time-format) port))) - (cons #\W (lambda (date pad-with port) - (if (> (priv:days-before-first-week date 1) 0) - (display (priv:padding (+ (date-week-number date 1) 1) - #\0 2) port) - (display (priv:padding (date-week-number date 1) - #\0 2) port)))) - (cons #\y (lambda (date pad-with port) - (display (priv:padding (priv:last-n-digits - (date-year date) 2) - pad-with - 2) - port))) - (cons #\Y (lambda (date pad-with port) - (display (date-year date) port))) - (cons #\z (lambda (date pad-with port) - (priv:tz-printer (date-zone-offset date) port))) - (cons #\Z (lambda (date pad-with port) - (priv:locale-print-time-zone date port))) - (cons #\1 (lambda (date pad-with port) - (display (date->string date "~Y-~m-~d") port))) - (cons #\2 (lambda (date pad-with port) - (display (date->string date "~k:~M:~S~z") port))) - (cons #\3 (lambda (date pad-with port) - (display (date->string date "~k:~M:~S") port))) - (cons #\4 (lambda (date pad-with port) - (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port))) - (cons #\5 (lambda (date pad-with port) - (display (date->string date "~Y-~m-~dT~k:~M:~S") port))))) - - -(define (priv:get-formatter char) - (let ((associated (assoc char priv:directives))) - (if associated (cdr associated) #f))) - -(define (priv:date-printer date index format-string str-len port) - (if (>= index str-len) - (values) - (let ((current-char (string-ref format-string index))) - (if (not (char=? current-char #\~)) - (begin - (display current-char port) - (priv:date-printer date (+ index 1) format-string str-len port)) - (if (= (+ index 1) str-len) ; bad format string. - (priv:time-error 'priv:date-printer 'bad-date-format-string - format-string) - (let ((pad-char? (string-ref format-string (+ index 1)))) - (cond - ((char=? pad-char? #\-) - (if (= (+ index 2) str-len) ; bad format string. - (priv:time-error 'priv:date-printer - 'bad-date-format-string - format-string) - (let ((formatter (priv:get-formatter - (string-ref format-string - (+ index 2))))) - (if (not formatter) - (priv:time-error 'priv:date-printer - 'bad-date-format-string - format-string) - (begin - (formatter date #f port) - (priv:date-printer date - (+ index 3) - format-string - str-len - port)))))) - - ((char=? pad-char? #\_) - (if (= (+ index 2) str-len) ; bad format string. - (priv:time-error 'priv:date-printer - 'bad-date-format-string - format-string) - (let ((formatter (priv:get-formatter - (string-ref format-string - (+ index 2))))) - (if (not formatter) - (priv:time-error 'priv:date-printer - 'bad-date-format-string - format-string) - (begin - (formatter date #\Space port) - (priv:date-printer date - (+ index 3) - format-string - str-len - port)))))) - (else - (let ((formatter (priv:get-formatter - (string-ref format-string - (+ index 1))))) - (if (not formatter) - (priv:time-error 'priv:date-printer - 'bad-date-format-string - format-string) - (begin - (formatter date #\0 port) - (priv:date-printer date - (+ index 2) - format-string - str-len - port)))))))))))) - - -(define (date->string date . format-string) - (let ((str-port (open-output-string)) - (fmt-str (if (null? format-string) "~c" (car format-string)))) - (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port) - (get-output-string str-port))) - -(define (priv:char->int ch) - (case ch - ((#\0) 0) - ((#\1) 1) - ((#\2) 2) - ((#\3) 3) - ((#\4) 4) - ((#\5) 5) - ((#\6) 6) - ((#\7) 7) - ((#\8) 8) - ((#\9) 9) - (else (priv:time-error 'bad-date-template-string - (list "Non-integer character" ch i))))) - -;; read an integer upto n characters long on port; upto -> #f is any length -(define (priv:integer-reader upto port) - (let loop ((accum 0) (nchars 0)) - (let ((ch (peek-char port))) - (if (or (eof-object? ch) - (not (char-numeric? ch)) - (and upto (>= nchars upto))) - accum - (loop (+ (* accum 10) (priv:char->int (read-char port))) - (+ nchars 1)))))) - -(define (priv:make-integer-reader upto) - (lambda (port) - (priv:integer-reader upto port))) - -;; read *exactly* n characters and convert to integer; could be padded -(define (priv:integer-reader-exact n port) - (let ((padding-ok #t)) - (define (accum-int port accum nchars) - (let ((ch (peek-char port))) - (cond - ((>= nchars n) accum) - ((eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - "Premature ending to integer read.")) - ((char-numeric? ch) - (set! padding-ok #f) - (accum-int port - (+ (* accum 10) (priv:char->int (read-char port))) - (+ nchars 1))) - (padding-ok - (read-char port) ; consume padding - (accum-int port accum (+ nchars 1))) - (else ; padding where it shouldn't be - (priv:time-error 'string->date 'bad-date-template-string - "Non-numeric characters in integer read."))))) - (accum-int port 0 0))) - - -(define (priv:make-integer-exact-reader n) - (lambda (port) - (priv:integer-reader-exact n port))) - -(define (priv:zone-reader port) - (let ((offset 0) - (positive? #f)) - (let ((ch (read-char port))) - (if (eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone +/-" ch))) - (if (or (char=? ch #\Z) (char=? ch #\z)) - 0 - (begin - (cond - ((char=? ch #\+) (set! positive? #t)) - ((char=? ch #\-) (set! positive? #f)) - (else - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone +/-" ch)))) - (let ((ch (read-char port))) - (if (eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) - (set! offset (* (priv:char->int ch) - 10 60 60))) - (let ((ch (read-char port))) - (if (eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) - (set! offset (+ offset (* (priv:char->int ch) - 60 60)))) - (let ((ch (read-char port))) - (if (eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) - (set! offset (+ offset (* (priv:char->int ch) - 10 60)))) - (let ((ch (read-char port))) - (if (eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) - (set! offset (+ offset (* (priv:char->int ch) - 60)))) - (if positive? offset (- offset))))))) - -;; looking at a char, read the char string, run thru indexer, return index -(define (priv:locale-reader port indexer) - - (define (read-char-string result) - (let ((ch (peek-char port))) - (if (char-alphabetic? ch) - (read-char-string (cons (read-char port) result)) - (list->string (reverse! result))))) - - (let* ((str (read-char-string '())) - (index (indexer str))) - (if index index (priv:time-error 'string->date - 'bad-date-template-string - (list "Invalid string for " indexer))))) - -(define (priv:make-locale-reader indexer) - (lambda (port) - (priv:locale-reader port indexer))) - -(define (priv:make-char-id-reader char) - (lambda (port) - (if (char=? char (read-char port)) - char - (priv:time-error 'string->date - 'bad-date-template-string - "Invalid character match.")))) - -;; A List of formatted read directives. -;; Each entry is a list. -;; 1. the character directive; -;; a procedure, which takes a character as input & returns -;; 2. #t as soon as a character on the input port is acceptable -;; for input, -;; 3. a port reader procedure that knows how to read the current port -;; for a value. Its one parameter is the port. -;; 4. a action procedure, that takes the value (from 3.) and some -;; object (here, always the date) and (probably) side-effects it. -;; In some cases (e.g., ~A) the action is to do nothing - -(define priv:read-directives - (let ((ireader4 (priv:make-integer-reader 4)) - (ireader2 (priv:make-integer-reader 2)) - (ireaderf (priv:make-integer-reader #f)) - (eireader2 (priv:make-integer-exact-reader 2)) - (eireader4 (priv:make-integer-exact-reader 4)) - (locale-reader-abbr-weekday (priv:make-locale-reader - priv:locale-abbr-weekday->index)) - (locale-reader-long-weekday (priv:make-locale-reader - priv:locale-long-weekday->index)) - (locale-reader-abbr-month (priv:make-locale-reader - priv:locale-abbr-month->index)) - (locale-reader-long-month (priv:make-locale-reader - priv:locale-long-month->index)) - (char-fail (lambda (ch) #t)) - (do-nothing (lambda (val object) (values)))) - - (list - (list #\~ char-fail (priv:make-char-id-reader #\~) do-nothing) - (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing) - (list #\A char-alphabetic? locale-reader-long-weekday do-nothing) - (list #\b char-alphabetic? locale-reader-abbr-month - (lambda (val object) - (set-date-month! object val))) - (list #\B char-alphabetic? locale-reader-long-month - (lambda (val object) - (set-date-month! object val))) - (list #\d char-numeric? ireader2 (lambda (val object) - (set-date-day! - object val))) - (list #\e char-fail eireader2 (lambda (val object) - (set-date-day! object val))) - (list #\h char-alphabetic? locale-reader-abbr-month - (lambda (val object) - (set-date-month! object val))) - (list #\H char-numeric? ireader2 (lambda (val object) - (set-date-hour! object val))) - (list #\k char-fail eireader2 (lambda (val object) - (set-date-hour! object val))) - (list #\m char-numeric? ireader2 (lambda (val object) - (set-date-month! object val))) - (list #\M char-numeric? ireader2 (lambda (val object) - (set-date-minute! - object val))) - (list #\S char-numeric? ireader2 (lambda (val object) - (set-date-second! object val))) - (list #\y char-fail eireader2 - (lambda (val object) - (set-date-year! object (priv:natural-year val)))) - (list #\Y char-numeric? ireader4 (lambda (val object) - (set-date-year! object val))) - (list #\z (lambda (c) - (or (char=? c #\Z) - (char=? c #\z) - (char=? c #\+) - (char=? c #\-))) - priv:zone-reader (lambda (val object) - (set-date-zone-offset! object val)))))) - -(define (priv:string->date date index format-string str-len port template-string) - (define (skip-until port skipper) - (let ((ch (peek-char port))) - (if (eof-object? ch) - (priv:time-error 'string->date 'bad-date-format-string template-string) - (if (not (skipper ch)) - (begin (read-char port) (skip-until port skipper)))))) - (if (>= index str-len) - (begin - (values)) - (let ((current-char (string-ref format-string index))) - (if (not (char=? current-char #\~)) - (let ((port-char (read-char port))) - (if (or (eof-object? port-char) - (not (char=? current-char port-char))) - (priv:time-error 'string->date - 'bad-date-format-string template-string)) - (priv:string->date date - (+ index 1) - format-string - str-len - port - template-string)) - ;; otherwise, it's an escape, we hope - (if (> (+ index 1) str-len) - (priv:time-error 'string->date - 'bad-date-format-string template-string) - (let* ((format-char (string-ref format-string (+ index 1))) - (format-info (assoc format-char priv:read-directives))) - (if (not format-info) - (priv:time-error 'string->date - 'bad-date-format-string template-string) - (begin - (let ((skipper (cadr format-info)) - (reader (caddr format-info)) - (actor (cadddr format-info))) - (skip-until port skipper) - (let ((val (reader port))) - (if (eof-object? val) - (priv:time-error 'string->date - 'bad-date-format-string - template-string) - (actor val date))) - (priv:string->date date - (+ index 2) - format-string - str-len - port - template-string)))))))))) - -(define (string->date input-string template-string) - (define (priv:date-ok? date) - (and (date-nanosecond date) - (date-second date) - (date-minute date) - (date-hour date) - (date-day date) - (date-month date) - (date-year date) - (date-zone-offset date))) - (let ((newdate (make-date 0 0 0 0 #f #f #f #f))) - (priv:string->date newdate - 0 - template-string - (string-length template-string) - (open-input-string input-string) - template-string) - (if (not (date-zone-offset newdate)) - (begin - ;; this is necessary to get DST right -- as far as we can - ;; get it right (think of the double/missing hour in the - ;; night when we are switching between normal time and DST). - (set-date-zone-offset! newdate - (priv:local-tz-offset - (make-time time-utc 0 0))) - (set-date-zone-offset! newdate - (priv:local-tz-offset - (date->time-utc newdate))))) - (if (priv:date-ok? newdate) - newdate - (priv:time-error - 'string->date - 'bad-date-format-string - (list "Incomplete date read. " newdate template-string))))) - -;;; srfi-19.scm ends here diff --git a/srfi/srfi-2.scm b/srfi/srfi-2.scm deleted file mode 100644 index 0dfe38305..000000000 --- a/srfi/srfi-2.scm +++ /dev/null @@ -1,31 +0,0 @@ -;;; srfi-2.scm --- and-let* - -;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: - -;; This module is fully documented in the Guile Reference Manual. - -;;; Code: - -(define-module (srfi srfi-2) - :use-module (ice-9 and-let-star) - :re-export-syntax (and-let*)) - -(cond-expand-provide (current-module) '(srfi-2)) - -;;; srfi-2.scm ends here diff --git a/srfi/srfi-26.scm b/srfi/srfi-26.scm deleted file mode 100644 index 410d2e2f8..000000000 --- a/srfi/srfi-26.scm +++ /dev/null @@ -1,49 +0,0 @@ -;;; srfi-26.scm --- specializing parameters without currying. - -;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (srfi srfi-26) - :export (cut cute)) - -(cond-expand-provide (current-module) '(srfi-26)) - -(define-macro (cut slot . slots) - (let loop ((slots (cons slot slots)) - (params '()) - (args '())) - (if (null? slots) - `(lambda ,(reverse! params) ,(reverse! args)) - (let ((s (car slots)) - (rest (cdr slots))) - (case s - ((<>) - (let ((var (gensym))) - (loop rest (cons var params) (cons var args)))) - ((<...>) - (if (pair? rest) - (error "<...> not on the end of cut expression")) - (let ((var (gensym))) - `(lambda ,(append! (reverse! params) var) - (apply ,@(reverse! (cons var args)))))) - (else - (loop rest params (cons s args)))))))) - -(define-macro (cute . slots) - (let ((temp (map (lambda (s) (and (not (memq s '(<> <...>))) (gensym))) - slots))) - `(let ,(delq! #f (map (lambda (t s) (and t (list t s))) temp slots)) - (cut ,@(map (lambda (t s) (or t s)) temp slots))))) diff --git a/srfi/srfi-31.scm b/srfi/srfi-31.scm deleted file mode 100644 index 54c2f9fd4..000000000 --- a/srfi/srfi-31.scm +++ /dev/null @@ -1,35 +0,0 @@ -;;; srfi-31.scm --- special form for recursive evaluation - -;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Original author: Rob Browning <rlb@defaultvalue.org> - -(define-module (srfi srfi-31) - :export-syntax (rec)) - -(define-macro (rec arg-form . body) - (cond - ((and (symbol? arg-form) (= 1 (length body))) - ;; (rec S (cons 1 (delay S))) - `(letrec ((,arg-form ,(car body))) - ,arg-form)) - ;; (rec (f x) (+ x 1)) - ((list? arg-form) - `(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body))) - ,(car arg-form))) - (else - (error "syntax error in rec form" `(rec ,arg-form ,@body))))) diff --git a/srfi/srfi-34.scm b/srfi/srfi-34.scm deleted file mode 100644 index 18a2fda1c..000000000 --- a/srfi/srfi-34.scm +++ /dev/null @@ -1,80 +0,0 @@ -;;; srfi-34.scm --- Exception handling for programs - -;; Copyright (C) 2003, 2006, 2008 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: Neil Jerram <neil@ossau.uklinux.net> - -;;; Commentary: - -;; This is an implementation of SRFI-34: Exception Handling for -;; Programs. For documentation please see the SRFI-34 document; this -;; module is not yet documented at all in the Guile manual. - -;;; Code: - -(define-module (srfi srfi-34) - #:export (with-exception-handler - raise) - #:export-syntax (guard)) - -(cond-expand-provide (current-module) '(srfi-34)) - -(define throw-key 'srfi-34) - -(define (with-exception-handler handler thunk) - "Returns the result(s) of invoking THUNK. HANDLER must be a -procedure that accepts one argument. It is installed as the current -exception handler for the dynamic extent (as determined by -dynamic-wind) of the invocation of THUNK." - (with-throw-handler throw-key - thunk - (lambda (key obj) - (handler obj)))) - -(define (raise obj) - "Invokes the current exception handler on OBJ. The handler is -called in the dynamic environment of the call to raise, except that -the current exception handler is that in place for the call to -with-exception-handler that installed the handler being called. The -handler's continuation is otherwise unspecified." - (throw throw-key obj)) - -(define-macro (guard var+clauses . body) - "Syntax: (guard (<var> <clause1> <clause2> ...) <body>) -Each <clause> should have the same form as a `cond' clause. - -Semantics: Evaluating a guard form evaluates <body> with an exception -handler that binds the raised object to <var> and within the scope of -that binding evaluates the clauses as if they were the clauses of a -cond expression. That implicit cond expression is evaluated with the -continuation and dynamic environment of the guard expression. If -every <clause>'s <test> evaluates to false and there is no else -clause, then raise is re-invoked on the raised object within the -dynamic environment of the original call to raise except that the -current exception handler is that of the guard expression." - (let ((var (car var+clauses)) - (clauses (cdr var+clauses))) - `(catch ',throw-key - (lambda () - ,@body) - (lambda (key ,var) - (cond ,@(if (eq? (caar (last-pair clauses)) 'else) - clauses - (append clauses - `((else (throw key ,var)))))))))) - -;;; (srfi srfi-34) ends here. diff --git a/srfi/srfi-35.scm b/srfi/srfi-35.scm deleted file mode 100644 index 203546625..000000000 --- a/srfi/srfi-35.scm +++ /dev/null @@ -1,337 +0,0 @@ -;;; srfi-35.scm --- Conditions - -;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: Ludovic Courtès <ludo@gnu.org> - -;;; Commentary: - -;; This is an implementation of SRFI-35, "Conditions". Conditions are a -;; means to convey information about exceptional conditions between parts of -;; a program. - -;;; Code: - -(define-module (srfi srfi-35) - #:use-module (srfi srfi-1) - #:export (make-condition-type condition-type? - make-condition condition? condition-has-type? condition-ref - make-compound-condition extract-condition - define-condition-type condition - &condition - &message message-condition? condition-message - &serious serious-condition? - &error error?)) - -(cond-expand-provide (current-module) '(srfi-35)) - - -;;; -;;; Condition types. -;;; - -(define %condition-type-vtable - ;; The vtable of all condition types. - ;; vtable fields: vtable, self, printer - ;; user fields: id, parent, all-field-names - (make-vtable-vtable "prprpr" 0 - (lambda (ct port) - (if (eq? ct %condition-type-vtable) - (display "#<condition-type-vtable>") - (format port "#<condition-type ~a ~a>" - (condition-type-id ct) - (number->string (object-address ct) - 16)))))) - -(define (condition-type? obj) - "Return true if OBJ is a condition type." - (and (struct? obj) - (eq? (struct-vtable obj) - %condition-type-vtable))) - -(define (condition-type-id ct) - (and (condition-type? ct) - (struct-ref ct 3))) - -(define (condition-type-parent ct) - (and (condition-type? ct) - (struct-ref ct 4))) - -(define (condition-type-all-fields ct) - (and (condition-type? ct) - (struct-ref ct 5))) - - -(define (struct-layout-for-condition field-names) - ;; Return a string denoting the layout required to hold the fields listed - ;; in FIELD-NAMES. - (let loop ((field-names field-names) - (layout '("pr"))) - (if (null? field-names) - (string-concatenate/shared layout) - (loop (cdr field-names) - (cons "pr" layout))))) - -(define (print-condition c port) - (format port "#<condition ~a ~a>" - (condition-type-id (condition-type c)) - (number->string (object-address c) 16))) - -(define (make-condition-type id parent field-names) - "Return a new condition type named ID, inheriting from PARENT, and with the -fields whose names are listed in FIELD-NAMES. FIELD-NAMES must be a list of -symbols and must not contain names already used by PARENT or one of its -supertypes." - (if (symbol? id) - (if (condition-type? parent) - (let ((parent-fields (condition-type-all-fields parent))) - (if (and (every symbol? field-names) - (null? (lset-intersection eq? - field-names parent-fields))) - (let* ((all-fields (append parent-fields field-names)) - (layout (struct-layout-for-condition all-fields))) - (make-struct %condition-type-vtable 0 - (make-struct-layout layout) ;; layout - print-condition ;; printer - id parent all-fields)) - (error "invalid condition type field names" - field-names))) - (error "parent is not a condition type" parent)) - (error "condition type identifier is not a symbol" id))) - -(define (make-compound-condition-type id parents) - ;; Return a compound condition type made of the types listed in PARENTS. - ;; All fields from PARENTS are kept, even same-named ones, since they are - ;; needed by `extract-condition'. - (cond ((null? parents) - (error "`make-compound-condition-type' passed empty parent list" - id)) - ((null? (cdr parents)) - (car parents)) - (else - (let* ((all-fields (append-map condition-type-all-fields - parents)) - (layout (struct-layout-for-condition all-fields))) - (make-struct %condition-type-vtable 0 - (make-struct-layout layout) ;; layout - print-condition ;; printer - id - parents ;; list of parents! - all-fields - all-fields))))) - - -;;; -;;; Conditions. -;;; - -(define (condition? c) - "Return true if C is a condition." - (and (struct? c) - (condition-type? (struct-vtable c)))) - -(define (condition-type c) - (and (struct? c) - (let ((vtable (struct-vtable c))) - (if (condition-type? vtable) - vtable - #f)))) - -(define (condition-has-type? c type) - "Return true if condition C has type TYPE." - (if (and (condition? c) (condition-type? type)) - (let loop ((ct (condition-type c))) - (or (eq? ct type) - (and ct - (let ((parent (condition-type-parent ct))) - (if (list? parent) - (any loop parent) ;; compound condition - (loop (condition-type-parent ct))))))) - (throw 'wrong-type-arg "condition-has-type?" - "Wrong type argument"))) - -(define (condition-ref c field-name) - "Return the value of the field named FIELD-NAME from condition C." - (if (condition? c) - (if (symbol? field-name) - (let* ((type (condition-type c)) - (fields (condition-type-all-fields type)) - (index (list-index (lambda (name) - (eq? name field-name)) - fields))) - (if index - (struct-ref c index) - (error "invalid field name" field-name))) - (error "field name is not a symbol" field-name)) - (throw 'wrong-type-arg "condition-ref" - "Wrong type argument: ~S" c))) - -(define (make-condition-from-values type values) - (apply make-struct type 0 values)) - -(define (make-condition type . field+value) - "Return a new condition of type TYPE with fields initialized as specified -by FIELD+VALUE, a sequence of field names (symbols) and values." - (if (condition-type? type) - (let* ((all-fields (condition-type-all-fields type)) - (inits (fold-right (lambda (field inits) - (let ((v (memq field field+value))) - (if (pair? v) - (cons (cadr v) inits) - (error "field not specified" - field)))) - '() - all-fields))) - (make-condition-from-values type inits)) - (throw 'wrong-type-arg "make-condition" - "Wrong type argument: ~S" type))) - -(define (make-compound-condition . conditions) - "Return a new compound condition composed of CONDITIONS." - (let* ((types (map condition-type conditions)) - (ct (make-compound-condition-type 'compound types)) - (inits (append-map (lambda (c) - (let ((ct (condition-type c))) - (map (lambda (f) - (condition-ref c f)) - (condition-type-all-fields ct)))) - conditions))) - (make-condition-from-values ct inits))) - -(define (extract-condition c type) - "Return a condition of condition type TYPE with the field values specified -by C." - - (define (first-field-index parents) - ;; Return the index of the first field of TYPE within C. - (let loop ((parents parents) - (index 0)) - (let ((parent (car parents))) - (cond ((null? parents) - #f) - ((eq? parent type) - index) - ((pair? parent) - (or (loop parent index) - (loop (cdr parents) - (+ index - (apply + (map condition-type-all-fields - parent)))))) - (else - (let ((shift (length (condition-type-all-fields parent)))) - (loop (cdr parents) - (+ index shift)))))))) - - (define (list-fields start-index field-names) - ;; Return a list of the form `(FIELD-NAME VALUE...)'. - (let loop ((index start-index) - (field-names field-names) - (result '())) - (if (null? field-names) - (reverse! result) - (loop (+ 1 index) - (cdr field-names) - (cons* (struct-ref c index) - (car field-names) - result))))) - - (if (and (condition? c) (condition-type? type)) - (let* ((ct (condition-type c)) - (parent (condition-type-parent ct))) - (cond ((eq? type ct) - c) - ((pair? parent) - ;; C is a compound condition. - (let ((field-index (first-field-index parent))) - ;;(format #t "field-index: ~a ~a~%" field-index - ;; (list-fields field-index - ;; (condition-type-all-fields type))) - (apply make-condition type - (list-fields field-index - (condition-type-all-fields type))))) - (else - ;; C does not have type TYPE. - #f))) - (throw 'wrong-type-arg "extract-condition" - "Wrong type argument"))) - - -;;; -;;; Syntax. -;;; - -(define-macro (define-condition-type name parent pred . field-specs) - `(begin - (define ,name - (make-condition-type ',name ,parent - ',(map car field-specs))) - (define (,pred c) - (condition-has-type? c ,name)) - ,@(map (lambda (field-spec) - (let ((field-name (car field-spec)) - (accessor (cadr field-spec))) - `(define (,accessor c) - (condition-ref c ',field-name)))) - field-specs))) - -(define-macro (condition . type-field-bindings) - (cond ((null? type-field-bindings) - (error "`condition' syntax error" type-field-bindings)) - (else - ;; the poor man's hygienic macro - (let ((mc (gensym "mc")) - (mcct (gensym "mcct"))) - `(let ((,mc (@ (srfi srfi-35) make-condition)) - (,mcct (@@ (srfi srfi-35) make-compound-condition-type))) - (,mc (,mcct 'compound (list ,@(map car type-field-bindings))) - ,@(append-map (lambda (type-field-binding) - (append-map (lambda (field+value) - (let ((f (car field+value)) - (v (cadr field+value))) - `(',f ,v))) - (cdr type-field-binding))) - type-field-bindings))))))) - - -;;; -;;; Standard condition types. -;;; - -(define &condition - ;; The root condition type. - (make-struct %condition-type-vtable 0 - (make-struct-layout "") - (lambda (c port) - (display "<&condition>")) - '&condition #f '() '())) - -(define-condition-type &message &condition - message-condition? - (message condition-message)) - -(define-condition-type &serious &condition - serious-condition?) - -(define-condition-type &error &serious - error?) - - -;;; Local Variables: -;;; coding: latin-1 -;;; End: - -;;; srfi-35.scm ends here diff --git a/srfi/srfi-37.scm b/srfi/srfi-37.scm deleted file mode 100644 index 5e6d512a2..000000000 --- a/srfi/srfi-37.scm +++ /dev/null @@ -1,230 +0,0 @@ -;;; srfi-37.scm --- args-fold - -;; Copyright (C) 2007, 2008 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - - -;;; Commentary: -;; -;; To use this module with Guile, use (cdr (program-arguments)) as -;; the ARGS argument to `args-fold'. Here is a short example: -;; -;; (args-fold (cdr (program-arguments)) -;; (let ((display-and-exit-proc -;; (lambda (msg) -;; (lambda (opt name arg) -;; (display msg) (quit) (values))))) -;; (list (option '(#\v "version") #f #f -;; (display-and-exit-proc "Foo version 42.0\n")) -;; (option '(#\h "help") #f #f -;; (display-and-exit-proc -;; "Usage: foo scheme-file ...")))) -;; (lambda (opt name arg) -;; (error "Unrecognized option `~A'" name)) -;; (lambda (op) (load op) (values))) -;; -;;; Code: - - -;;;; Module definition & exports -(define-module (srfi srfi-37) - #:use-module (srfi srfi-9) - #:export (option option-names option-required-arg? - option-optional-arg? option-processor - args-fold)) - -(cond-expand-provide (current-module) '(srfi-37)) - -;;;; args-fold and periphery procedures - -;;; An option as answered by `option'. `names' is a list of -;;; characters and strings, representing associated short-options and -;;; long-options respectively that should use this option's -;;; `processor' in an `args-fold' call. -;;; -;;; `required-arg?' and `optional-arg?' are mutually exclusive -;;; booleans and indicate whether an argument must be or may be -;;; provided. Besides the obvious, this affects semantics of -;;; short-options, as short-options with a required or optional -;;; argument cannot be followed by other short options in the same -;;; program-arguments string, as they will be interpreted collectively -;;; as the option's argument. -;;; -;;; `processor' is called when this option is encountered. It should -;;; accept the containing option, the element of `names' (by `equal?') -;;; encountered, the option's argument (or #f if none), and the seeds -;;; as variadic arguments, answering the new seeds as values. -(define-record-type srfi-37:option - (option names required-arg? optional-arg? processor) - option? - (names option-names) - (required-arg? option-required-arg?) - (optional-arg? option-optional-arg?) - (processor option-processor)) - -(define (error-duplicate-option option-name) - (scm-error 'program-error "args-fold" - "Duplicate option name `~A~A'" - (list (if (char? option-name) #\- "--") - option-name) - #f)) - -(define (build-options-lookup options) - "Answer an `equal?' Guile hash-table that maps OPTIONS' names back -to the containing options, signalling an error if a name is -encountered more than once." - (let ((lookup (make-hash-table (* 2 (length options))))) - (for-each - (lambda (opt) - (for-each (lambda (name) - (let ((assoc (hash-create-handle! - lookup name #f))) - (if (cdr assoc) - (error-duplicate-option (car assoc)) - (set-cdr! assoc opt)))) - (option-names opt))) - options) - lookup)) - -(define (args-fold args options unrecognized-option-proc - operand-proc . seeds) - "Answer the results of folding SEEDS as multiple values against the -program-arguments in ARGS, as decided by the OPTIONS' -`option-processor's, UNRECOGNIZED-OPTION-PROC, and OPERAND-PROC." - (let ((lookup (build-options-lookup options))) - ;; I don't like Guile's `error' here - (define (error msg . args) - (scm-error 'misc-error "args-fold" msg args #f)) - - (define (mutate-seeds! procedure . params) - (set! seeds (call-with-values - (lambda () - (apply procedure (append params seeds))) - list))) - - ;; Clean up the rest of ARGS, assuming they're all operands. - (define (rest-operands) - (for-each (lambda (arg) (mutate-seeds! operand-proc arg)) - args) - (set! args '())) - - ;; Call OPT's processor with OPT, NAME, an argument to be decided, - ;; and the seeds. Depending on OPT's *-arg? specification, get - ;; the parameter by calling REQ-ARG-PROC or OPT-ARG-PROC thunks; - ;; if no argument is allowed, call NO-ARG-PROC thunk. - (define (invoke-option-processor - opt name req-arg-proc opt-arg-proc no-arg-proc) - (mutate-seeds! - (option-processor opt) opt name - (cond ((option-required-arg? opt) (req-arg-proc)) - ((option-optional-arg? opt) (opt-arg-proc)) - (else (no-arg-proc) #f)))) - - ;; Compute and answer a short option argument, advancing ARGS as - ;; necessary, for the short option whose character is at POSITION - ;; in the current ARG. - (define (short-option-argument position) - (cond ((< (1+ position) (string-length (car args))) - (let ((result (substring (car args) (1+ position)))) - (set! args (cdr args)) - result)) - ((pair? (cdr args)) - (let ((result (cadr args))) - (set! args (cddr args)) - result)) - (else #f))) - - ;; Interpret the short-option at index POSITION in (car ARGS), - ;; followed by the remaining short options in (car ARGS). - (define (short-option position) - (if (>= position (string-length (car args))) - (begin - (set! args (cdr args)) - (next-arg)) - (let* ((opt-name (string-ref (car args) position)) - (option-here (hash-ref lookup opt-name))) - (cond ((not option-here) - (mutate-seeds! unrecognized-option-proc - (option (list opt-name) #f #f - unrecognized-option-proc) - opt-name #f) - (short-option (1+ position))) - (else - (invoke-option-processor - option-here opt-name - (lambda () - (or (short-option-argument position) - (error "Missing required argument after `-~A'" opt-name))) - (lambda () - ;; edge case: -xo -zf or -xo -- where opt-name=#\o - ;; GNU getopt_long resolves these like I do - (short-option-argument position)) - (lambda () #f)) - (if (not (or (option-required-arg? option-here) - (option-optional-arg? option-here))) - (short-option (1+ position)))))))) - - ;; Process the long option in (car ARGS). We make the - ;; interesting, possibly non-standard assumption that long option - ;; names might contain #\=, so keep looking for more #\= in (car - ;; ARGS) until we find a named option in lookup. - (define (long-option) - (let ((arg (car args))) - (let place-=-after ((start-pos 2)) - (let* ((index (string-index arg #\= start-pos)) - (opt-name (substring arg 2 (or index (string-length arg)))) - (option-here (hash-ref lookup opt-name))) - (if (not option-here) - ;; look for a later #\=, unless there can't be one - (if index - (place-=-after (1+ index)) - (mutate-seeds! - unrecognized-option-proc - (option (list opt-name) #f #f unrecognized-option-proc) - opt-name #f)) - (invoke-option-processor - option-here opt-name - (lambda () - (if index - (substring arg (1+ index)) - (error "Missing required argument after `--~A'" opt-name))) - (lambda () (and index (substring arg (1+ index)))) - (lambda () - (if index - (error "Extraneous argument after `--~A'" opt-name)))))))) - (set! args (cdr args))) - - ;; Process the remaining in ARGS. Basically like calling - ;; `args-fold', but without having to regenerate `lookup' and the - ;; funcs above. - (define (next-arg) - (if (null? args) - (apply values seeds) - (let ((arg (car args))) - (cond ((or (not (char=? #\- (string-ref arg 0))) - (= 1 (string-length arg))) ;"-" - (mutate-seeds! operand-proc arg) - (set! args (cdr args))) - ((char=? #\- (string-ref arg 1)) - (if (= 2 (string-length arg)) ;"--" - (begin (set! args (cdr args)) (rest-operands)) - (long-option))) - (else (short-option 1))) - (next-arg)))) - - (next-arg))) - -;;; srfi-37.scm ends here diff --git a/srfi/srfi-39.scm b/srfi/srfi-39.scm deleted file mode 100644 index 086751170..000000000 --- a/srfi/srfi-39.scm +++ /dev/null @@ -1,137 +0,0 @@ -;;; srfi-39.scm --- Parameter objects - -;; Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> -;;; Date: 2004-05-05 - -;;; Commentary: - -;; This is an implementation of SRFI-39 (Parameter objects). -;; -;; The implementation is based on Guile's fluid objects, and is, therefore, -;; thread-safe (parameters are thread-local). -;; -;; In addition to the forms defined in SRFI-39 (`make-parameter', -;; `parameterize'), a new procedure `with-parameters*' is provided. -;; This procedures is analogous to `with-fluids*' but taking as first -;; argument a list of parameter objects instead of a list of fluids. -;; - -;;; Code: - -(define-module (srfi srfi-39) - #:use-module (ice-9 syncase) - #:use-module (srfi srfi-16) - - #:export (make-parameter) - #:export-syntax (parameterize) - - ;; helper procedure not in srfi-39. - #:export (with-parameters*) - #:replace (current-input-port current-output-port current-error-port)) - -;; Make 'srfi-39 available as a feature identifiere to `cond-expand'. -;; -(cond-expand-provide (current-module) '(srfi-39)) - -(define make-parameter - (case-lambda - ((val) (make-parameter/helper val (lambda (x) x))) - ((val conv) (make-parameter/helper val conv)))) - -(define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value -(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value - -(define (make-parameter/helper val conv) - (let ((value (make-fluid)) - (conv conv)) - (begin - (fluid-set! value (conv val)) - (lambda new-value - (cond - ((null? new-value) (fluid-ref value)) - ((eq? (car new-value) get-fluid-tag) value) - ((eq? (car new-value) get-conv-tag) conv) - ((null? (cdr new-value)) (fluid-set! value (conv (car new-value)))) - (else (error "make-parameter expects 0 or 1 arguments" new-value))))))) - -(define-syntax parameterize - (syntax-rules () - ((_ ((?param ?value) ...) ?body ...) - (with-parameters* (list ?param ...) - (list ?value ...) - (lambda () ?body ...))))) - -(define (current-input-port . new-value) - (if (null? new-value) - ((@ (guile) current-input-port)) - (apply set-current-input-port new-value))) - -(define (current-output-port . new-value) - (if (null? new-value) - ((@ (guile) current-output-port)) - (apply set-current-output-port new-value))) - -(define (current-error-port . new-value) - (if (null? new-value) - ((@ (guile) current-error-port)) - (apply set-current-error-port new-value))) - -(define port-list - (list current-input-port current-output-port current-error-port)) - -;; There are no fluids behind current-input-port etc, so those parameter -;; objects are picked out of the list and handled separately with a -;; dynamic-wind to swap their values to and from a location (the "value" -;; variable in the swapper procedure "let"). -;; -;; current-input-port etc are already per-dynamic-root, so this arrangement -;; works the same as a fluid. Perhaps they could become fluids for ease of -;; implementation here. -;; -;; Notice the use of a param local variable for the swapper procedure. It -;; ensures any application changes to the PARAMS list won't affect the -;; winding. -;; -(define (with-parameters* params values thunk) - (let more ((params params) - (values values) - (fluids '()) ;; fluids from each of PARAMS - (convs '()) ;; VALUES with conversion proc applied - (swapper noop)) ;; wind/unwind procedure for ports handling - (if (null? params) - (if (eq? noop swapper) - (with-fluids* fluids convs thunk) - (dynamic-wind - swapper - (lambda () - (with-fluids* fluids convs thunk)) - swapper)) - (if (memq (car params) port-list) - (more (cdr params) (cdr values) - fluids convs - (let ((param (car params)) - (value (car values)) - (prev-swapper swapper)) - (lambda () - (set! value (param value)) - (prev-swapper)))) - (more (cdr params) (cdr values) - (cons ((car params) get-fluid-tag) fluids) - (cons (((car params) get-conv-tag) (car values)) convs) - swapper))))) diff --git a/srfi/srfi-4.c b/srfi/srfi-4.c index f40c6b319..9b32b61a9 100644 --- a/srfi/srfi-4.c +++ b/srfi/srfi-4.c @@ -3,18 +3,19 @@ * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ /* This file is now empty since all its procedures are now in the diff --git a/srfi/srfi-4.h b/srfi/srfi-4.h index 079219ace..0439675da 100644 --- a/srfi/srfi-4.h +++ b/srfi/srfi-4.h @@ -5,18 +5,19 @@ * Copyright (C) 2001, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/srfi/srfi-4.scm b/srfi/srfi-4.scm deleted file mode 100644 index f30e83952..000000000 --- a/srfi/srfi-4.scm +++ /dev/null @@ -1,71 +0,0 @@ -;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes - -;; Copyright (C) 2001, 2002, 2004, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: Martin Grabmueller <mgrabmue@cs.tu-berlin.de> - -;;; Commentary: - -;; This module exports the homogeneous numeric vector procedures as -;; defined in SRFI-4. They are fully documented in the Guile -;; Reference Manual. - -;;; Code: - -(define-module (srfi srfi-4)) - -(re-export -;;; Unsigned 8-bit vectors. - u8vector? make-u8vector u8vector u8vector-length u8vector-ref - u8vector-set! u8vector->list list->u8vector - -;;; Signed 8-bit vectors. - s8vector? make-s8vector s8vector s8vector-length s8vector-ref - s8vector-set! s8vector->list list->s8vector - -;;; Unsigned 16-bit vectors. - u16vector? make-u16vector u16vector u16vector-length u16vector-ref - u16vector-set! u16vector->list list->u16vector - -;;; Signed 16-bit vectors. - s16vector? make-s16vector s16vector s16vector-length s16vector-ref - s16vector-set! s16vector->list list->s16vector - -;;; Unsigned 32-bit vectors. - u32vector? make-u32vector u32vector u32vector-length u32vector-ref - u32vector-set! u32vector->list list->u32vector - -;;; Signed 32-bit vectors. - s32vector? make-s32vector s32vector s32vector-length s32vector-ref - s32vector-set! s32vector->list list->s32vector - -;;; Unsigned 64-bit vectors. - u64vector? make-u64vector u64vector u64vector-length u64vector-ref - u64vector-set! u64vector->list list->u64vector - -;;; Signed 64-bit vectors. - s64vector? make-s64vector s64vector s64vector-length s64vector-ref - s64vector-set! s64vector->list list->s64vector - -;;; 32-bit floating point vectors. - f32vector? make-f32vector f32vector f32vector-length f32vector-ref - f32vector-set! f32vector->list list->f32vector - -;;; 64-bit floating point vectors. - f64vector? make-f64vector f64vector f64vector-length f64vector-ref - f64vector-set! f64vector->list list->f64vector - ) diff --git a/srfi/srfi-6.scm b/srfi/srfi-6.scm deleted file mode 100644 index 1e455bb5c..000000000 --- a/srfi/srfi-6.scm +++ /dev/null @@ -1,33 +0,0 @@ -;;; srfi-6.scm --- Basic String Ports - -;; Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: - -;; This module is fully documented in the Guile Reference Manual. - -;;; Code: - -(define-module (srfi srfi-6) - #:re-export (open-input-string open-output-string get-output-string)) - -;; Currently, guile provides these functions by default, so no action -;; is needed, and this file is just a placeholder. - -(cond-expand-provide (current-module) '(srfi-6)) - -;;; srfi-6.scm ends here diff --git a/srfi/srfi-60.c b/srfi/srfi-60.c index 7d89ca039..989898f9c 100644 --- a/srfi/srfi-60.c +++ b/srfi/srfi-60.c @@ -3,18 +3,19 @@ * Copyright (C) 2005, 2006, 2008 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ #ifdef HAVE_CONFIG_H diff --git a/srfi/srfi-60.h b/srfi/srfi-60.h index 030b32525..47a8cf766 100644 --- a/srfi/srfi-60.h +++ b/srfi/srfi-60.h @@ -3,18 +3,19 @@ * Copyright (C) 2005, 2006 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. + * modify it under the terms of the GNU Lesser General Public License + * as published by the Free Software Foundation; either version 3 of + * the License, or (at your option) any later version. * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of + * This library 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 * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA + * 02110-1301 USA */ diff --git a/srfi/srfi-60.scm b/srfi/srfi-60.scm deleted file mode 100644 index 177f97681..000000000 --- a/srfi/srfi-60.scm +++ /dev/null @@ -1,72 +0,0 @@ -;;; srfi-60.scm --- Integers as Bits - -;; Copyright (C) 2005, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -(define-module (srfi srfi-60) - #:export (bitwise-and - bitwise-ior - bitwise-xor - bitwise-not - any-bits-set? - bit-count - bitwise-if bitwise-merge - log2-binary-factors first-set-bit - bit-set? - copy-bit - bit-field - copy-bit-field - arithmetic-shift - rotate-bit-field - reverse-bit-field - integer->list - list->integer - booleans->integer) - #:re-export (logand - logior - logxor - integer-length - logtest - logcount - logbit? - ash)) - -(load-extension "libguile-srfi-srfi-60-v-3" "scm_init_srfi_60") - -(define bitwise-and logand) -(define bitwise-ior logior) -(define bitwise-xor logxor) -(define bitwise-not lognot) -(define any-bits-set? logtest) -(define bit-count logcount) - -(define (bitwise-if mask n0 n1) - (logior (logand mask n0) - (logand (lognot mask) n1))) -(define bitwise-merge bitwise-if) - -(define first-set-bit log2-binary-factors) -(define bit-set? logbit?) -(define bit-field bit-extract) - -(define (copy-bit-field n newbits start end) - (logxor n (ash (logxor (bit-extract n start end) ;; cancel old - (bit-extract newbits 0 (- end start))) ;; insert new - start))) - -(define arithmetic-shift ash) - -(cond-expand-provide (current-module) '(srfi-60)) diff --git a/srfi/srfi-69.scm b/srfi/srfi-69.scm deleted file mode 100644 index 7da560b1b..000000000 --- a/srfi/srfi-69.scm +++ /dev/null @@ -1,329 +0,0 @@ -;;; srfi-69.scm --- Basic hash tables - -;; Copyright (C) 2007 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;;; Commentary: - -;; My `hash' is compatible with core `hash', so I replace it. -;; However, my `hash-table?' and `make-hash-table' are different, so -;; importing this module will warn about them. If you don't rename my -;; imports, you shouldn't use both my hash tables and Guile's hash -;; tables in the same module. -;; -;; SRFI-13 `string-hash' and `string-hash-ci' have more arguments, but -;; are compatible with my `string-hash' and `string-ci-hash', and are -;; furthermore primitive in Guile, so I use them as my own. -;; -;; I also have the extension of allowing hash functions that require a -;; second argument to be used as the `hash-table-hash-function', and use -;; these in defaults to avoid an indirection in the hashx functions. The -;; only deviation this causes is: -;; -;; ((hash-table-hash-function (make-hash-table)) obj) -;; error> Wrong number of arguments to #<primitive-procedure hash> -;; -;; I don't think that SRFI 69 actually specifies that I *can't* do this, -;; because it only implies the signature of a hash function by way of the -;; named, exported hash functions. However, if this matters enough I can -;; add a private derivation of hash-function to the srfi-69:hash-table -;; record type, like associator is to equivalence-function. -;; -;; Also, outside of the issue of how weak keys and values are referenced -;; outside the table, I always interpret key equivalence to be that of -;; the `hash-table-equivalence-function'. For example, given the -;; requirement that `alist->hash-table' give earlier associations -;; priority, what should these answer? -;; -;; (hash-table-keys -;; (alist->hash-table '(("xY" . 1) ("Xy" . 2)) string-ci=?)) -;; -;; (let ((ht (make-hash-table string-ci=?))) -;; (hash-table-set! ht "xY" 2) -;; (hash-table-set! ht "Xy" 1) -;; (hash-table-keys ht)) -;; -;; My interpretation is that they can answer either ("Xy") or ("xY"), -;; where `hash-table-values' will of course always answer (1), because -;; the keys are the same according to the equivalence function. In this -;; implementation, both answer ("xY"). However, I don't guarantee that -;; this won't change in the future. - -;;; Code: - -;;;; Module definition & exports - -(define-module (srfi srfi-69) - #:use-module (srfi srfi-1) ;alist-cons,second&c,assoc - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-13) ;string-hash,string-hash-ci - #:use-module (ice-9 optargs) - #:export (;; Type constructors & predicate - make-hash-table hash-table? alist->hash-table - ;; Reflective queries - hash-table-equivalence-function hash-table-hash-function - ;; Dealing with single elements - hash-table-ref hash-table-ref/default hash-table-set! - hash-table-delete! hash-table-exists? hash-table-update! - hash-table-update!/default - ;; Dealing with the whole contents - hash-table-size hash-table-keys hash-table-values - hash-table-walk hash-table-fold hash-table->alist - hash-table-copy hash-table-merge! - ;; Hashing - string-ci-hash hash-by-identity) - #:re-export (string-hash) - #:replace (hash)) - -(cond-expand-provide (current-module) '(srfi-37)) - -;;;; Hashing - -;;; The largest fixnum is in `most-positive-fixnum' in module (guile), -;;; though not documented anywhere but libguile/numbers.c. - -(define (caller-with-default-size hash-fn) - "Answer a function that makes `most-positive-fixnum' the default -second argument to HASH-FN, a 2-arg procedure." - (lambda* (obj #:optional (size most-positive-fixnum)) - (hash-fn obj size))) - -(define hash (caller-with-default-size (@ (guile) hash))) - -(define string-ci-hash string-hash-ci) - -(define hash-by-identity (caller-with-default-size hashq)) - -;;;; Reflective queries, construction, predicate - -(define-record-type srfi-69:hash-table - (make-srfi-69-hash-table real-table associator size weakness - equivalence-function hash-function) - hash-table? - (real-table ht-real-table) - (associator ht-associator) - ;; required for O(1) by SRFI-69. It really makes a mess of things, - ;; and I'd like to compute it in O(n) and memoize it because it - ;; doesn't seem terribly useful, but SRFI-69 is final. - (size ht-size ht-size!) - ;; required for `hash-table-copy' - (weakness ht-weakness) - ;; used only to implement hash-table-equivalence-function; I don't - ;; use it internally other than for `ht-associator'. - (equivalence-function hash-table-equivalence-function) - (hash-function hash-table-hash-function)) - -(define (guess-hash-function equal-proc) - "Guess a hash function for EQUAL-PROC, falling back on `hash', as -specified in SRFI-69 for `make-hash-table'." - (cond ((eq? equal? equal-proc) (@ (guile) hash)) ;shortcut most common case - ((eq? eq? equal-proc) hashq) - ((eq? eqv? equal-proc) hashv) - ((eq? string=? equal-proc) string-hash) - ((eq? string-ci=? equal-proc) string-ci-hash) - (else (@ (guile) hash)))) - -(define (without-keyword-args rest-list) - "Answer REST-LIST with all keywords removed along with items that -follow them." - (let lp ((acc '()) (rest-list rest-list)) - (cond ((null? rest-list) (reverse! acc)) - ((keyword? (first rest-list)) - (lp acc (cddr rest-list))) - (else (lp (cons (first rest-list) acc) (cdr rest-list)))))) - -(define (guile-ht-ctor weakness) - "Answer the Guile HT constructor for the given WEAKNESS." - (case weakness - ((#f) (@ (guile) make-hash-table)) - ((key) make-weak-key-hash-table) - ((value) make-weak-value-hash-table) - ((key-or-value) make-doubly-weak-hash-table) - (else (error "Invalid weak hash table type" weakness)))) - -(define (equivalence-proc->associator equal-proc) - "Answer an `assoc'-like procedure that compares the argument key to -alist keys with EQUAL-PROC." - (cond ((or (eq? equal? equal-proc) - (eq? string=? equal-proc)) (@ (guile) assoc)) - ((eq? eq? equal-proc) assq) - ((eq? eqv? equal-proc) assv) - (else (lambda (item alist) - (assoc item alist equal-proc))))) - -(define* (make-hash-table - #:optional (equal-proc equal?) - (hash-proc (guess-hash-function equal-proc)) - #:key (weak #f) #:rest guile-opts) - "Answer a new hash table using EQUAL-PROC as the comparison -function, and HASH-PROC as the hash function. See the reference -manual for specifics, of which there are many." - (make-srfi-69-hash-table - (apply (guile-ht-ctor weak) (without-keyword-args guile-opts)) - (equivalence-proc->associator equal-proc) - 0 weak equal-proc hash-proc)) - -(define (alist->hash-table alist . mht-args) - "Convert ALIST to a hash table created with MHT-ARGS." - (let* ((result (apply make-hash-table mht-args)) - (size (ht-size result))) - (with-hashx-values (hash-proc associator real-table) result - (for-each (lambda (pair) - (let ((handle (hashx-get-handle hash-proc associator - real-table (car pair)))) - (cond ((not handle) - (set! size (1+ size)) - (hashx-set! hash-proc associator real-table - (car pair) (cdr pair)))))) - alist)) - (ht-size! result size) - result)) - -;;;; Accessing table items - -;; We use this to denote missing or unspecified values to avoid -;; possible collision with *unspecified*. -(define ht-unspecified (cons *unspecified* "ht-value")) - -;; I am a macro only for efficiency, to avoid varargs/apply. -(define-macro (hashx-invoke hashx-proc ht-var . args) - "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function, -assoc-function, and the hash-table as first args." - `(,hashx-proc (hash-table-hash-function ,ht-var) - (ht-associator ,ht-var) - (ht-real-table ,ht-var) - . ,args)) - -(define-macro (with-hashx-values bindings ht-var . body-forms) - "Bind BINDINGS to the hash-function, associator, and real-table of -HT-VAR, while evaluating BODY-FORMS." - `(let ((,(first bindings) (hash-table-hash-function ,ht-var)) - (,(second bindings) (ht-associator ,ht-var)) - (,(third bindings) (ht-real-table ,ht-var))) - . ,body-forms)) - -(define (hash-table-ref ht key . default-thunk-lst) - "Lookup KEY in HT and answer the value, invoke DEFAULT-THUNK if KEY -isn't present, or signal an error if DEFAULT-THUNK isn't provided." - (let ((result (hashx-invoke hashx-ref ht key ht-unspecified))) - (if (eq? ht-unspecified result) - (if (pair? default-thunk-lst) - ((first default-thunk-lst)) - (error "Key not in table" key ht)) - result))) - -(define (hash-table-ref/default ht key default) - "Lookup KEY in HT and answer the value. Answer DEFAULT if KEY isn't -present." - (hashx-invoke hashx-ref ht key default)) - -(define (hash-table-set! ht key new-value) - "Set KEY to NEW-VALUE in HT." - (let ((handle (hashx-invoke hashx-create-handle! ht key ht-unspecified))) - (if (eq? ht-unspecified (cdr handle)) - (ht-size! ht (1+ (ht-size ht)))) - (set-cdr! handle new-value)) - *unspecified*) - -(define (hash-table-delete! ht key) - "Remove KEY's association in HT." - (with-hashx-values (h a real-ht) ht - (if (hashx-get-handle h a real-ht key) - (begin - (ht-size! ht (1- (ht-size ht))) - (hashx-remove! h a real-ht key)))) - *unspecified*) - -(define (hash-table-exists? ht key) - "Return whether KEY is a key in HT." - (and (hashx-invoke hashx-get-handle ht key) #t)) - -;;; `hashx-set!' duplicates the hash lookup, but we use it anyway to -;;; avoid creating a handle in case DEFAULT-THUNK exits -;;; `hash-table-update!' non-locally. -(define (hash-table-update! ht key modifier . default-thunk-lst) - "Modify HT's value at KEY by passing its value to MODIFIER and -setting it to the result thereof. Invoke DEFAULT-THUNK for the old -value if KEY isn't in HT, or signal an error if DEFAULT-THUNK is not -provided." - (with-hashx-values (hash-proc associator real-table) ht - (let ((handle (hashx-get-handle hash-proc associator real-table key))) - (cond (handle - (set-cdr! handle (modifier (cdr handle)))) - (else - (hashx-set! hash-proc associator real-table key - (if (pair? default-thunk-lst) - (modifier ((car default-thunk-lst))) - (error "Key not in table" key ht))) - (ht-size! ht (1+ (ht-size ht))))))) - *unspecified*) - -(define (hash-table-update!/default ht key modifier default) - "Modify HT's value at KEY by passing its old value, or DEFAULT if it -doesn't have one, to MODIFIER, and setting it to the result thereof." - (hash-table-update! ht key modifier (lambda () default))) - -;;;; Accessing whole tables - -(define (hash-table-size ht) - "Return the number of associations in HT. This is guaranteed O(1) -for tables where #:weak was #f or not specified at creation time." - (if (ht-weakness ht) - (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0) - (ht-size ht))) - -(define (hash-table-keys ht) - "Return a list of the keys in HT." - (hash-table-fold ht (lambda (k v lst) (cons k lst)) '())) - -(define (hash-table-values ht) - "Return a list of the values in HT." - (hash-table-fold ht (lambda (k v lst) (cons v lst)) '())) - -(define (hash-table-walk ht proc) - "Call PROC with each key and value as two arguments." - (hash-table-fold ht (lambda (k v unspec) (proc k v) unspec) - *unspecified*)) - -(define (hash-table-fold ht f knil) - "Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is -the result of the previous invocation, using KNIL as the first PREV. -Answer the final F result." - (hash-fold f knil (ht-real-table ht))) - -(define (hash-table->alist ht) - "Return an alist for HT." - (hash-table-fold ht alist-cons '())) - -(define (hash-table-copy ht) - "Answer a copy of HT." - (with-hashx-values (h a real-ht) ht - (let* ((size (hash-table-size ht)) (weak (ht-weakness ht)) - (new-real-ht ((guile-ht-ctor weak) size))) - (hash-fold (lambda (k v ign) (hashx-set! h a new-real-ht k v)) - #f real-ht) - (make-srfi-69-hash-table ;real,assoc,size,weak,equiv,h - new-real-ht a size weak - (hash-table-equivalence-function ht) h)))) - -(define (hash-table-merge! ht other-ht) - "Add all key/value pairs from OTHER-HT to HT, overriding HT's -mappings where present. Return HT." - (hash-table-fold - ht (lambda (k v ign) (hash-table-set! ht k v)) #f) - ht) - -;;; srfi-69.scm ends here diff --git a/srfi/srfi-8.scm b/srfi/srfi-8.scm deleted file mode 100644 index c15cbe9c0..000000000 --- a/srfi/srfi-8.scm +++ /dev/null @@ -1,31 +0,0 @@ -;;; srfi-8.scm --- receive - -;; Copyright (C) 2000, 2001, 2002, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: - -;; This module is fully documented in the Guile Reference Manual. - -;;; Code: - -(define-module (srfi srfi-8) - :use-module (ice-9 receive) - :re-export-syntax (receive)) - -(cond-expand-provide (current-module) '(srfi-8)) - -;;; srfi-8.scm ends here diff --git a/srfi/srfi-88.scm b/srfi/srfi-88.scm deleted file mode 100644 index ebde81d0b..000000000 --- a/srfi/srfi-88.scm +++ /dev/null @@ -1,50 +0,0 @@ -;;; srfi-88.scm --- Keyword Objects - -;; Copyright (C) 2008 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: Ludovic Courtès <ludo@gnu.org> - -;;; Commentary: - -;; This is a convenience module providing SRFI-88 "keyword object". All it -;; does is setup the right reader option and export keyword-related -;; convenience procedures. - -;;; Code: - -(define-module (srfi srfi-88) - #:re-export (keyword?) - #:export (keyword->string string->keyword)) - -(cond-expand-provide (current-module) '(srfi-88)) - - -(read-set! keywords 'postfix) - -(define (keyword->string k) - "Return the name of @var{k} as a string." - (symbol->string (keyword->symbol k))) - -(define (string->keyword s) - "Return the keyword object whose name is @var{s}." - (symbol->keyword (string->symbol s))) - -;;; Local Variables: -;;; coding: latin-1 -;;; End: - -;;; srfi-88.scm ends here diff --git a/srfi/srfi-9.scm b/srfi/srfi-9.scm deleted file mode 100644 index 59d23bf53..000000000 --- a/srfi/srfi-9.scm +++ /dev/null @@ -1,91 +0,0 @@ -;;; srfi-9.scm --- define-record-type - -;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc. -;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2.1 of the License, or (at your option) any later version. -;; -;; This library 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 -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Commentary: - -;; This module exports the syntactic form `define-record-type', which -;; is the means for creating record types defined in SRFI-9. -;; -;; The syntax of a record type definition is: -;; -;; <record type definition> -;; -> (define-record-type <type name> -;; (<constructor name> <field tag> ...) -;; <predicate name> -;; <field spec> ...) -;; -;; <field spec> -> (<field tag> <accessor name>) -;; -> (<field tag> <accessor name> <modifier name>) -;; -;; <field tag> -> <identifier> -;; <... name> -> <identifier> -;; -;; Usage example: -;; -;; guile> (use-modules (srfi srfi-9)) -;; guile> (define-record-type :foo (make-foo x) foo? -;; (x get-x) (y get-y set-y!)) -;; guile> (define f (make-foo 1)) -;; guile> f -;; #<:foo x: 1 y: #f> -;; guile> (get-x f) -;; 1 -;; guile> (set-y! f 2) -;; 2 -;; guile> (get-y f) -;; 2 -;; guile> f -;; #<:foo x: 1 y: 2> -;; guile> (foo? f) -;; #t -;; guile> (foo? 1) -;; #f - -;;; Code: - -(define-module (srfi srfi-9) - :export-syntax (define-record-type)) - -(cond-expand-provide (current-module) '(srfi-9)) - -(define-macro (define-record-type type-name constructor/field-tag - predicate-name . field-specs) - `(begin - (define ,type-name - (make-record-type ',type-name ',(map car field-specs))) - (define ,(car constructor/field-tag) - (record-constructor ,type-name ',(cdr constructor/field-tag))) - (define ,predicate-name - (record-predicate ,type-name)) - ,@(map - (lambda (spec) - (cond - ((= (length spec) 2) - `(define ,(cadr spec) - (record-accessor ,type-name ',(car spec)))) - ((= (length spec) 3) - `(begin - (define ,(cadr spec) - (record-accessor ,type-name ',(car spec))) - (define ,(caddr spec) - (record-modifier ,type-name ',(car spec))))) - (else - (error "invalid field spec " spec)))) - field-specs))) - -;;; srfi-9.scm ends here |