From ea93465de79826ca8bbd3689bfbccca58e8d9353 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 1 Nov 2008 13:49:23 +0100 Subject: move scm srfi files to module/srfi, and compile them. * .gitignore: Add gdb-pre-inst-guile. * configure.in: Add module/srfi/Makefile. * module/Makefile.am: Add srfi/. * module/srfi/: SRFI scheme files moved here, and compiled. * srfi/Makefile.am: Remove the bits about the scheme files. --- .gitignore | 1 + configure.in | 1 + module/Makefile.am | 2 +- module/srfi/Makefile.am | 52 ++ module/srfi/srfi-1.scm | 588 +++++++++++++++++++ module/srfi/srfi-10.scm | 89 +++ module/srfi/srfi-11.scm | 254 ++++++++ module/srfi/srfi-13.scm | 132 +++++ module/srfi/srfi-14.scm | 99 ++++ module/srfi/srfi-16.scm | 126 ++++ module/srfi/srfi-17.scm | 174 ++++++ module/srfi/srfi-18.scm | 382 ++++++++++++ module/srfi/srfi-19.scm | 1491 +++++++++++++++++++++++++++++++++++++++++++++++ module/srfi/srfi-2.scm | 31 + module/srfi/srfi-26.scm | 49 ++ module/srfi/srfi-31.scm | 35 ++ module/srfi/srfi-34.scm | 80 +++ module/srfi/srfi-35.scm | 337 +++++++++++ module/srfi/srfi-37.scm | 230 ++++++++ module/srfi/srfi-39.scm | 137 +++++ module/srfi/srfi-4.scm | 71 +++ module/srfi/srfi-6.scm | 33 ++ module/srfi/srfi-60.scm | 72 +++ module/srfi/srfi-69.scm | 329 +++++++++++ module/srfi/srfi-8.scm | 31 + module/srfi/srfi-88.scm | 50 ++ module/srfi/srfi-9.scm | 91 +++ srfi/Makefile.am | 27 +- srfi/srfi-1.scm | 588 ------------------- srfi/srfi-10.scm | 89 --- srfi/srfi-11.scm | 254 -------- srfi/srfi-13.scm | 132 ----- srfi/srfi-14.scm | 99 ---- srfi/srfi-16.scm | 126 ---- srfi/srfi-17.scm | 174 ------ srfi/srfi-18.scm | 382 ------------ srfi/srfi-19.scm | 1491 ----------------------------------------------- srfi/srfi-2.scm | 31 - srfi/srfi-26.scm | 49 -- srfi/srfi-31.scm | 35 -- srfi/srfi-34.scm | 80 --- srfi/srfi-35.scm | 337 ----------- srfi/srfi-37.scm | 230 -------- srfi/srfi-39.scm | 137 ----- srfi/srfi-4.scm | 71 --- srfi/srfi-6.scm | 33 -- srfi/srfi-60.scm | 72 --- srfi/srfi-69.scm | 329 ----------- srfi/srfi-8.scm | 31 - srfi/srfi-88.scm | 50 -- srfi/srfi-9.scm | 91 --- 51 files changed, 4967 insertions(+), 4938 deletions(-) create mode 100644 module/srfi/Makefile.am create mode 100644 module/srfi/srfi-1.scm create mode 100644 module/srfi/srfi-10.scm create mode 100644 module/srfi/srfi-11.scm create mode 100644 module/srfi/srfi-13.scm create mode 100644 module/srfi/srfi-14.scm create mode 100644 module/srfi/srfi-16.scm create mode 100644 module/srfi/srfi-17.scm create mode 100644 module/srfi/srfi-18.scm create mode 100644 module/srfi/srfi-19.scm create mode 100644 module/srfi/srfi-2.scm create mode 100644 module/srfi/srfi-26.scm create mode 100644 module/srfi/srfi-31.scm create mode 100644 module/srfi/srfi-34.scm create mode 100644 module/srfi/srfi-35.scm create mode 100644 module/srfi/srfi-37.scm create mode 100644 module/srfi/srfi-39.scm create mode 100644 module/srfi/srfi-4.scm create mode 100644 module/srfi/srfi-6.scm create mode 100644 module/srfi/srfi-60.scm create mode 100644 module/srfi/srfi-69.scm create mode 100644 module/srfi/srfi-8.scm create mode 100644 module/srfi/srfi-88.scm create mode 100644 module/srfi/srfi-9.scm delete mode 100644 srfi/srfi-1.scm delete mode 100644 srfi/srfi-10.scm delete mode 100644 srfi/srfi-11.scm delete mode 100644 srfi/srfi-13.scm delete mode 100644 srfi/srfi-14.scm delete mode 100644 srfi/srfi-16.scm delete mode 100644 srfi/srfi-17.scm delete mode 100644 srfi/srfi-18.scm delete mode 100644 srfi/srfi-19.scm delete mode 100644 srfi/srfi-2.scm delete mode 100644 srfi/srfi-26.scm delete mode 100644 srfi/srfi-31.scm delete mode 100644 srfi/srfi-34.scm delete mode 100644 srfi/srfi-35.scm delete mode 100644 srfi/srfi-37.scm delete mode 100644 srfi/srfi-39.scm delete mode 100644 srfi/srfi-4.scm delete mode 100644 srfi/srfi-6.scm delete mode 100644 srfi/srfi-60.scm delete mode 100644 srfi/srfi-69.scm delete mode 100644 srfi/srfi-8.scm delete mode 100644 srfi/srfi-88.scm delete mode 100644 srfi/srfi-9.scm diff --git a/.gitignore b/.gitignore index 3ba3b6f35..f5953c90e 100644 --- a/.gitignore +++ b/.gitignore @@ -73,3 +73,4 @@ TAGS guile-1.8.pc lib/alloca.h lib/strings.h +gdb-pre-inst-guile diff --git a/configure.in b/configure.in index 56b74e229..881a472a1 100644 --- a/configure.in +++ b/configure.in @@ -1560,6 +1560,7 @@ AC_CONFIG_FILES([ module/ice-9/Makefile module/ice-9/debugger/Makefile module/ice-9/debugging/Makefile + module/srfi/Makefile module/oop/Makefile module/oop/goops/Makefile testsuite/Makefile diff --git a/module/Makefile.am b/module/Makefile.am index feefcdfb0..0dbb1b9cc 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -1 +1 @@ -SUBDIRS = system language ice-9 oop +SUBDIRS = system language ice-9 srfi oop diff --git a/module/srfi/Makefile.am b/module/srfi/Makefile.am new file mode 100644 index 000000000..0fc926e40 --- /dev/null +++ b/module/srfi/Makefile.am @@ -0,0 +1,52 @@ +## Process this file with automake to produce Makefile.in. +## +## Copyright (C) 2000, 2004, 2006, 2008 Free Software Foundation, Inc. +## +## 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 +## (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. +## +## 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 + +AUTOMAKE_OPTIONS = gnu + +modpath = srfi +SOURCES = \ + 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 + +# Will poke this later. +NOCOMP_SOURCES = srfi-18.scm + +include $(top_srcdir)/am/guilec diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm new file mode 100644 index 000000000..7c55d9923 --- /dev/null +++ b/module/srfi/srfi-1.scm @@ -0,0 +1,588 @@ +;;; 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 +;;; 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/module/srfi/srfi-10.scm b/module/srfi/srfi-10.scm new file mode 100644 index 000000000..8e7181a3b --- /dev/null +++ b/module/srfi/srfi-10.scm @@ -0,0 +1,89 @@ +;;; 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 +;; +;; #,( ...) +;; +;; where 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/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm new file mode 100644 index 000000000..9e17d6632 --- /dev/null +++ b/module/srfi/srfi-11.scm @@ -0,0 +1,254 @@ +;;; 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 ( . ) +;; (call-with-values (lambda () (bar c)) +;; (lambda ( ) +;; (let ((x ) +;; (y ) +;; (z ) +;; (p ) +;; (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 +; ;; ( ) ...) 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 ( +; ;; ) ...) 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/module/srfi/srfi-13.scm b/module/srfi/srfi-13.scm new file mode 100644 index 000000000..1036a0f47 --- /dev/null +++ b/module/srfi/srfi-13.scm @@ -0,0 +1,132 @@ +;;; 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/module/srfi/srfi-14.scm b/module/srfi/srfi-14.scm new file mode 100644 index 000000000..100b43b8e --- /dev/null +++ b/module/srfi/srfi-14.scm @@ -0,0 +1,99 @@ +;;; 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/module/srfi/srfi-16.scm b/module/srfi/srfi-16.scm new file mode 100644 index 000000000..0b213fde7 --- /dev/null +++ b/module/srfi/srfi-16.scm @@ -0,0 +1,126 @@ +;;; 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 ) +;; +;; --> ( *) +;; +;; --> (*) +;; | (* . ) +;; | +;; +;; 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/module/srfi/srfi-17.scm b/module/srfi/srfi-17.scm new file mode 100644 index 000000000..c9cb2abfe --- /dev/null +++ b/module/srfi/srfi-17.scm @@ -0,0 +1,174 @@ +;;; 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 + +;;; 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/module/srfi/srfi-18.scm b/module/srfi/srfi-18.scm new file mode 100644 index 000000000..925ecb304 --- /dev/null +++ b/module/srfi/srfi-18.scm @@ -0,0 +1,382 @@ +;;; 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 +;;; 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/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm new file mode 100644 index 000000000..96ef3448a --- /dev/null +++ b/module/srfi/srfi-19.scm @@ -0,0 +1,1491 @@ +;;; 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 +;;; 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 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))))) + +;; -- 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 priv:locale-abbr-weekday 7 string=?)) + +(define (priv:locale-long-weekday->index string) + (priv:date-reverse-lookup string priv:locale-long-weekday 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? port) + (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/module/srfi/srfi-2.scm b/module/srfi/srfi-2.scm new file mode 100644 index 000000000..0dfe38305 --- /dev/null +++ b/module/srfi/srfi-2.scm @@ -0,0 +1,31 @@ +;;; 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/module/srfi/srfi-26.scm b/module/srfi/srfi-26.scm new file mode 100644 index 000000000..410d2e2f8 --- /dev/null +++ b/module/srfi/srfi-26.scm @@ -0,0 +1,49 @@ +;;; 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/module/srfi/srfi-31.scm b/module/srfi/srfi-31.scm new file mode 100644 index 000000000..54c2f9fd4 --- /dev/null +++ b/module/srfi/srfi-31.scm @@ -0,0 +1,35 @@ +;;; 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 + +(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/module/srfi/srfi-34.scm b/module/srfi/srfi-34.scm new file mode 100644 index 000000000..5101b543d --- /dev/null +++ b/module/srfi/srfi-34.scm @@ -0,0 +1,80 @@ +;;; srfi-34.scm --- Exception handling for programs + +;; Copyright (C) 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: Neil Jerram + +;;; 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." + (lazy-catch 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 ( ...) ) +Each should have the same form as a `cond' clause. + +Semantics: Evaluating a guard form evaluates with an exception +handler that binds the raised object to 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 's 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/module/srfi/srfi-35.scm b/module/srfi/srfi-35.scm new file mode 100644 index 000000000..203546625 --- /dev/null +++ b/module/srfi/srfi-35.scm @@ -0,0 +1,337 @@ +;;; 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 + +;;; 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 "#") + (format port "#" + (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-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/module/srfi/srfi-37.scm b/module/srfi/srfi-37.scm new file mode 100644 index 000000000..5e6d512a2 --- /dev/null +++ b/module/srfi/srfi-37.scm @@ -0,0 +1,230 @@ +;;; 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/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm new file mode 100644 index 000000000..086751170 --- /dev/null +++ b/module/srfi/srfi-39.scm @@ -0,0 +1,137 @@ +;;; 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 +;;; 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/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm new file mode 100644 index 000000000..f30e83952 --- /dev/null +++ b/module/srfi/srfi-4.scm @@ -0,0 +1,71 @@ +;;; 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 + +;;; 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/module/srfi/srfi-6.scm b/module/srfi/srfi-6.scm new file mode 100644 index 000000000..1e455bb5c --- /dev/null +++ b/module/srfi/srfi-6.scm @@ -0,0 +1,33 @@ +;;; 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/module/srfi/srfi-60.scm b/module/srfi/srfi-60.scm new file mode 100644 index 000000000..177f97681 --- /dev/null +++ b/module/srfi/srfi-60.scm @@ -0,0 +1,72 @@ +;;; 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/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm new file mode 100644 index 000000000..7da560b1b --- /dev/null +++ b/module/srfi/srfi-69.scm @@ -0,0 +1,329 @@ +;;; 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 # +;; +;; 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/module/srfi/srfi-8.scm b/module/srfi/srfi-8.scm new file mode 100644 index 000000000..c15cbe9c0 --- /dev/null +++ b/module/srfi/srfi-8.scm @@ -0,0 +1,31 @@ +;;; 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/module/srfi/srfi-88.scm b/module/srfi/srfi-88.scm new file mode 100644 index 000000000..ebde81d0b --- /dev/null +++ b/module/srfi/srfi-88.scm @@ -0,0 +1,50 @@ +;;; 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 + +;;; 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/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm new file mode 100644 index 000000000..59d23bf53 --- /dev/null +++ b/module/srfi/srfi-9.scm @@ -0,0 +1,91 @@ +;;; 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: +;; +;; +;; -> (define-record-type +;; ( ...) +;; +;; ...) +;; +;; -> ( ) +;; -> ( ) +;; +;; -> +;; <... name> -> +;; +;; 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 diff --git a/srfi/Makefile.am b/srfi/Makefile.am index 048898dce..02fa12b04 100644 --- a/srfi/Makefile.am +++ b/srfi/Makefile.am @@ -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.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 -;;; 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 -;; -;; #,( ...) -;; -;; where 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 ( . ) -;; (call-with-values (lambda () (bar c)) -;; (lambda ( ) -;; (let ((x ) -;; (y ) -;; (z ) -;; (p ) -;; (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 -; ;; ( ) ...) 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 ( -; ;; ) ...) 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.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.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 ) -;; -;; --> ( *) -;; -;; --> (*) -;; | (* . ) -;; | -;; -;; 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 - -;;; 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 -;;; 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 96ef3448a..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 -;;; 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 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))))) - -;; -- 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 priv:locale-abbr-weekday 7 string=?)) - -(define (priv:locale-long-weekday->index string) - (priv:date-reverse-lookup string priv:locale-long-weekday 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? port) - (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 - -(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 5101b543d..000000000 --- a/srfi/srfi-34.scm +++ /dev/null @@ -1,80 +0,0 @@ -;;; srfi-34.scm --- Exception handling for programs - -;; Copyright (C) 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: Neil Jerram - -;;; 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." - (lazy-catch 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 ( ...) ) -Each should have the same form as a `cond' clause. - -Semantics: Evaluating a guard form evaluates with an exception -handler that binds the raised object to 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 's 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 - -;;; 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 "#") - (format port "#" - (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-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 -;;; 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.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 - -;;; 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.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 # -;; -;; 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 - -;;; 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: -;; -;; -;; -> (define-record-type -;; ( ...) -;; -;; ...) -;; -;; -> ( ) -;; -> ( ) -;; -;; -> -;; <... name> -> -;; -;; 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 -- cgit v1.2.3