diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/Makefile.am | 2 | ||||
-rw-r--r-- | module/srfi/Makefile.am | 52 | ||||
-rw-r--r-- | module/srfi/srfi-1.scm | 588 | ||||
-rw-r--r-- | module/srfi/srfi-10.scm | 89 | ||||
-rw-r--r-- | module/srfi/srfi-11.scm | 254 | ||||
-rw-r--r-- | module/srfi/srfi-13.scm | 132 | ||||
-rw-r--r-- | module/srfi/srfi-14.scm | 99 | ||||
-rw-r--r-- | module/srfi/srfi-16.scm | 126 | ||||
-rw-r--r-- | module/srfi/srfi-17.scm | 174 | ||||
-rw-r--r-- | module/srfi/srfi-18.scm | 382 | ||||
-rw-r--r-- | module/srfi/srfi-19.scm | 1491 | ||||
-rw-r--r-- | module/srfi/srfi-2.scm | 31 | ||||
-rw-r--r-- | module/srfi/srfi-26.scm | 49 | ||||
-rw-r--r-- | module/srfi/srfi-31.scm | 35 | ||||
-rw-r--r-- | module/srfi/srfi-34.scm | 80 | ||||
-rw-r--r-- | module/srfi/srfi-35.scm | 337 | ||||
-rw-r--r-- | module/srfi/srfi-37.scm | 230 | ||||
-rw-r--r-- | module/srfi/srfi-39.scm | 137 | ||||
-rw-r--r-- | module/srfi/srfi-4.scm | 71 | ||||
-rw-r--r-- | module/srfi/srfi-6.scm | 33 | ||||
-rw-r--r-- | module/srfi/srfi-60.scm | 72 | ||||
-rw-r--r-- | module/srfi/srfi-69.scm | 329 | ||||
-rw-r--r-- | module/srfi/srfi-8.scm | 31 | ||||
-rw-r--r-- | module/srfi/srfi-88.scm | 50 | ||||
-rw-r--r-- | module/srfi/srfi-9.scm | 91 |
25 files changed, 4964 insertions, 1 deletions
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 <mgrabmue@cs.tu-berlin.de> +;;; Date: 2001-06-06 + +;;; Commentary: + +;; This is an implementation of SRFI-1 (List Library). +;; +;; All procedures defined in SRFI-1, which are not already defined in +;; the Guile core library, are exported. The procedures in this +;; implementation work, but they have not been tuned for speed or +;; memory usage. +;; +;; This module is fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-1) + :export ( +;;; Constructors + ;; cons <= in the core + ;; list <= in the core + xcons + ;; cons* <= in the core + ;; make-list <= in the core + list-tabulate + list-copy + circular-list + ;; iota ; Extended. + +;;; Predicates + proper-list? + circular-list? + dotted-list? + ;; pair? <= in the core + ;; null? <= in the core + null-list? + not-pair? + list= + +;;; Selectors + ;; car <= in the core + ;; cdr <= in the core + ;; caar <= in the core + ;; cadr <= in the core + ;; cdar <= in the core + ;; cddr <= in the core + ;; caaar <= in the core + ;; caadr <= in the core + ;; cadar <= in the core + ;; caddr <= in the core + ;; cdaar <= in the core + ;; cdadr <= in the core + ;; cddar <= in the core + ;; cdddr <= in the core + ;; caaaar <= in the core + ;; caaadr <= in the core + ;; caadar <= in the core + ;; caaddr <= in the core + ;; cadaar <= in the core + ;; cadadr <= in the core + ;; caddar <= in the core + ;; cadddr <= in the core + ;; cdaaar <= in the core + ;; cdaadr <= in the core + ;; cdadar <= in the core + ;; cdaddr <= in the core + ;; cddaar <= in the core + ;; cddadr <= in the core + ;; cdddar <= in the core + ;; cddddr <= in the core + ;; list-ref <= in the core + first + second + third + fourth + fifth + sixth + seventh + eighth + ninth + tenth + car+cdr + take + drop + take-right + drop-right + take! + drop-right! + split-at + split-at! + last + ;; last-pair <= in the core + +;;; Miscelleneous: length, append, concatenate, reverse, zip & count + ;; length <= in the core + length+ + ;; append <= in the core + ;; append! <= in the core + concatenate + concatenate! + ;; reverse <= in the core + ;; reverse! <= in the core + append-reverse + append-reverse! + zip + unzip1 + unzip2 + unzip3 + unzip4 + unzip5 + count + +;;; Fold, unfold & map + fold + fold-right + pair-fold + pair-fold-right + reduce + reduce-right + unfold + unfold-right + ;; map ; Extended. + ;; for-each ; Extended. + append-map + append-map! + map! + ;; map-in-order ; Extended. + pair-for-each + filter-map + +;;; Filtering & partitioning + ;; filter <= in the core + partition + remove + ;; filter! <= in the core + partition! + remove! + +;;; Searching + find + find-tail + take-while + take-while! + drop-while + span + span! + break + break! + any + every + ;; list-index ; Extended. + ;; member ; Extended. + ;; memq <= in the core + ;; memv <= in the core + +;;; Deletion + ;; delete ; Extended. + ;; delete! ; Extended. + delete-duplicates + delete-duplicates! + +;;; Association lists + ;; assoc ; Extended. + ;; assq <= in the core + ;; assv <= in the core + alist-cons + alist-copy + alist-delete + alist-delete! + +;;; Set operations on lists + lset<= + lset= + lset-adjoin + lset-union + lset-intersection + lset-difference + lset-xor + lset-diff+intersection + lset-union! + lset-intersection! + lset-difference! + lset-xor! + lset-diff+intersection! + +;;; Primitive side-effects + ;; set-car! <= in the core + ;; set-cdr! <= in the core + ) + :re-export (cons list cons* make-list pair? null? + car cdr caar cadr cdar cddr + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr + list-ref last-pair length append append! reverse reverse! + filter filter! memq memv assq assv set-car! set-cdr!) + :replace (iota map for-each map-in-order list-copy list-index member + delete delete! assoc) + ) + +(cond-expand-provide (current-module) '(srfi-1)) + +;; Load the compiled primitives from the shared library. +;; +(load-extension "libguile-srfi-srfi-1-v-4" "scm_init_srfi_1") + + +;;; Constructors + +;; internal helper, similar to (scsh utilities) check-arg. +(define (check-arg-type pred arg caller) + (if (pred arg) + arg + (scm-error 'wrong-type-arg caller + "Wrong type argument: ~S" (list arg) '()))) + +;; the srfi spec doesn't seem to forbid inexact integers. +(define (non-negative-integer? x) (and (integer? x) (>= x 0))) + + + +(define (circular-list elt1 . elts) + (set! elts (cons elt1 elts)) + (set-cdr! (last-pair elts) elts) + elts) + +(define (iota count . rest) + (check-arg-type non-negative-integer? count "iota") + (let ((start (if (pair? rest) (car rest) 0)) + (step (if (and (pair? rest) (pair? (cdr rest))) (cadr rest) 1))) + (let lp ((n 0) (acc '())) + (if (= n count) + (reverse! acc) + (lp (+ n 1) (cons (+ start (* n step)) acc)))))) + +;;; Predicates + +(define (proper-list? x) + (list? x)) + +(define (circular-list? x) + (if (not-pair? x) + #f + (let lp ((hare (cdr x)) (tortoise x)) + (if (not-pair? hare) + #f + (let ((hare (cdr hare))) + (if (not-pair? hare) + #f + (if (eq? hare tortoise) + #t + (lp (cdr hare) (cdr tortoise))))))))) + +(define (dotted-list? x) + (cond + ((null? x) #f) + ((not-pair? x) #t) + (else + (let lp ((hare (cdr x)) (tortoise x)) + (cond + ((null? hare) #f) + ((not-pair? hare) #t) + (else + (let ((hare (cdr hare))) + (cond + ((null? hare) #f) + ((not-pair? hare) #t) + ((eq? hare tortoise) #f) + (else + (lp (cdr hare) (cdr tortoise))))))))))) + +(define (null-list? x) + (cond + ((proper-list? x) + (null? x)) + ((circular-list? x) + #f) + (else + (error "not a proper list in null-list?")))) + +(define (list= elt= . rest) + (define (lists-equal a b) + (let lp ((a a) (b b)) + (cond ((null? a) + (null? b)) + ((null? b) + #f) + (else + (and (elt= (car a) (car b)) + (lp (cdr a) (cdr b))))))) + (or (null? rest) + (let lp ((lists rest)) + (or (null? (cdr lists)) + (and (lists-equal (car lists) (cadr lists)) + (lp (cdr lists))))))) + +;;; Selectors + +(define first car) +(define second cadr) +(define third caddr) +(define fourth cadddr) + +(define take list-head) +(define drop list-tail) + +;;; Miscelleneous: length, append, concatenate, reverse, zip & count + +(define (zip clist1 . rest) + (let lp ((l (cons clist1 rest)) (acc '())) + (if (any null? l) + (reverse! acc) + (lp (map1 cdr l) (cons (map1 car l) acc))))) + + +(define (unzip1 l) + (map1 first l)) +(define (unzip2 l) + (values (map1 first l) (map1 second l))) +(define (unzip3 l) + (values (map1 first l) (map1 second l) (map1 third l))) +(define (unzip4 l) + (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l))) +(define (unzip5 l) + (values (map1 first l) (map1 second l) (map1 third l) (map1 fourth l) + (map1 fifth l))) + +;;; Fold, unfold & map + +(define (fold-right kons knil clist1 . rest) + (if (null? rest) + (let f ((list1 clist1)) + (if (null? list1) + knil + (kons (car list1) (f (cdr list1))))) + (let f ((lists (cons clist1 rest))) + (if (any null? lists) + knil + (apply kons (append! (map1 car lists) (list (f (map1 cdr lists))))))))) + +(define (pair-fold kons knil clist1 . rest) + (if (null? rest) + (let f ((knil knil) (list1 clist1)) + (if (null? list1) + knil + (let ((tail (cdr list1))) + (f (kons list1 knil) tail)))) + (let f ((knil knil) (lists (cons clist1 rest))) + (if (any null? lists) + knil + (let ((tails (map1 cdr lists))) + (f (apply kons (append! lists (list knil))) tails)))))) + + +(define (pair-fold-right kons knil clist1 . rest) + (if (null? rest) + (let f ((list1 clist1)) + (if (null? list1) + knil + (kons list1 (f (cdr list1))))) + (let f ((lists (cons clist1 rest))) + (if (any null? lists) + knil + (apply kons (append! lists (list (f (map1 cdr lists))))))))) + +(define (unfold p f g seed . rest) + (let ((tail-gen (if (pair? rest) + (if (pair? (cdr rest)) + (scm-error 'wrong-number-of-args + "unfold" "too many arguments" '() '()) + (car rest)) + (lambda (x) '())))) + (let uf ((seed seed)) + (if (p seed) + (tail-gen seed) + (cons (f seed) + (uf (g seed))))))) + +(define (unfold-right p f g seed . rest) + (let ((tail (if (pair? rest) + (if (pair? (cdr rest)) + (scm-error 'wrong-number-of-args + "unfold-right" "too many arguments" '() + '()) + (car rest)) + '()))) + (let uf ((seed seed) (lis tail)) + (if (p seed) + lis + (uf (g seed) (cons (f seed) lis)))))) + + +;; Internal helper procedure. Map `f' over the single list `ls'. +;; +(define map1 map) + +(define (append-map f clist1 . rest) + (concatenate (apply map f clist1 rest))) + +(define (append-map! f clist1 . rest) + (concatenate! (apply map f clist1 rest))) + +;; OPTIMIZE-ME: Re-use cons cells of list1 +(define map! map) + +(define (pair-for-each f clist1 . rest) + (if (null? rest) + (let lp ((l clist1)) + (if (null? l) + (if #f #f) + (begin + (f l) + (lp (cdr l))))) + (let lp ((l (cons clist1 rest))) + (if (any1 null? l) + (if #f #f) + (begin + (apply f l) + (lp (map1 cdr l))))))) + +;;; Searching + +(define (any pred ls . lists) + (if (null? lists) + (any1 pred ls) + (let lp ((lists (cons ls lists))) + (cond ((any1 null? lists) + #f) + ((any1 null? (map1 cdr lists)) + (apply pred (map1 car lists))) + (else + (or (apply pred (map1 car lists)) (lp (map1 cdr lists)))))))) + +(define (any1 pred ls) + (let lp ((ls ls)) + (cond ((null? ls) + #f) + ((null? (cdr ls)) + (pred (car ls))) + (else + (or (pred (car ls)) (lp (cdr ls))))))) + +(define (every pred ls . lists) + (if (null? lists) + (every1 pred ls) + (let lp ((lists (cons ls lists))) + (cond ((any1 null? lists) + #t) + ((any1 null? (map1 cdr lists)) + (apply pred (map1 car lists))) + (else + (and (apply pred (map1 car lists)) (lp (map1 cdr lists)))))))) + +(define (every1 pred ls) + (let lp ((ls ls)) + (cond ((null? ls) + #t) + ((null? (cdr ls)) + (pred (car ls))) + (else + (and (pred (car ls)) (lp (cdr ls))))))) + +;;; Association lists + +(define alist-cons acons) + +(define (alist-delete key alist . rest) + (let ((k= (if (pair? rest) (car rest) equal?))) + (let lp ((a alist) (rl '())) + (if (null? a) + (reverse! rl) + (if (k= key (caar a)) + (lp (cdr a) rl) + (lp (cdr a) (cons (car a) rl))))))) + +(define (alist-delete! key alist . rest) + (let ((k= (if (pair? rest) (car rest) equal?))) + (alist-delete key alist k=))) ; XXX:optimize + +;;; Set operations on lists + +(define (lset<= = . rest) + (if (null? rest) + #t + (let lp ((f (car rest)) (r (cdr rest))) + (or (null? r) + (and (every (lambda (el) (member el (car r) =)) f) + (lp (car r) (cdr r))))))) + +(define (lset= = . rest) + (if (null? rest) + #t + (let lp ((f (car rest)) (r (cdr rest))) + (or (null? r) + (and (every (lambda (el) (member el (car r) =)) f) + (every (lambda (el) (member el f (lambda (x y) (= y x)))) (car r)) + (lp (car r) (cdr r))))))) + +(define (lset-union = . rest) + (let ((acc '())) + (for-each (lambda (lst) + (if (null? acc) + (set! acc lst) + (for-each (lambda (elem) + (if (not (member elem acc + (lambda (x y) (= y x)))) + (set! acc (cons elem acc)))) + lst))) + rest) + acc)) + +(define (lset-intersection = list1 . rest) + (let lp ((l list1) (acc '())) + (if (null? l) + (reverse! acc) + (if (every (lambda (ll) (member (car l) ll =)) rest) + (lp (cdr l) (cons (car l) acc)) + (lp (cdr l) acc))))) + +(define (lset-difference = list1 . rest) + (if (null? rest) + list1 + (let lp ((l list1) (acc '())) + (if (null? l) + (reverse! acc) + (if (any (lambda (ll) (member (car l) ll =)) rest) + (lp (cdr l) acc) + (lp (cdr l) (cons (car l) acc))))))) + +;(define (fold kons knil list1 . rest) + +(define (lset-xor = . rest) + (fold (lambda (lst res) + (let lp ((l lst) (acc '())) + (if (null? l) + (let lp0 ((r res) (acc acc)) + (if (null? r) + (reverse! acc) + (if (member (car r) lst =) + (lp0 (cdr r) acc) + (lp0 (cdr r) (cons (car r) acc))))) + (if (member (car l) res =) + (lp (cdr l) acc) + (lp (cdr l) (cons (car l) acc)))))) + '() + rest)) + +(define (lset-diff+intersection = list1 . rest) + (let lp ((l list1) (accd '()) (acci '())) + (if (null? l) + (values (reverse! accd) (reverse! acci)) + (let ((appears (every (lambda (ll) (member (car l) ll =)) rest))) + (if appears + (lp (cdr l) accd (cons (car l) acci)) + (lp (cdr l) (cons (car l) accd) acci)))))) + + +(define (lset-union! = . rest) + (apply lset-union = rest)) ; XXX:optimize + +(define (lset-intersection! = list1 . rest) + (apply lset-intersection = list1 rest)) ; XXX:optimize + +(define (lset-xor! = . rest) + (apply lset-xor = rest)) ; XXX:optimize + +(define (lset-diff+intersection! = list1 . rest) + (apply lset-diff+intersection = list1 rest)) ; XXX:optimize + +;;; srfi-1.scm ends here diff --git a/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 +;; +;; #,(<ctor> <datum> ...) +;; +;; where <ctor> must be a symbol for which a read constructor was +;; defined previously. +;; +;; Example: +;; +;; (define-reader-ctor 'file open-input-file) +;; (define f '#,(file "/etc/passwd")) +;; (read-line f) +;; => +;; "root:x:0:0:root:/root:/bin/bash" +;; +;; Please note the quote before the #,(file ...) expression. This is +;; necessary because ports are not self-evaluating in Guile. +;; +;; This module is fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-10) + :use-module (ice-9 rdelim) + :export (define-reader-ctor)) + +(cond-expand-provide (current-module) '(srfi-10)) + +;; This hash table stores the association between comma-hash tags and +;; the corresponding constructor procedures. +;; +(define reader-ctors (make-hash-table 31)) + +;; This procedure installs the procedure @var{proc} as the constructor +;; for the comma-hash tag @var{symbol}. +;; +(define (define-reader-ctor symbol proc) + (hashq-set! reader-ctors symbol proc) + (if #f #f)) ; Return unspecified value. + +;; Retrieve the constructor procedure for the tag @var{symbol} or +;; throw an error if no such tag is defined. +;; +(define (lookup symbol) + (let ((p (hashq-ref reader-ctors symbol #f))) + (if (procedure? p) + p + (error "unknown hash-comma tag " symbol)))) + +;; This is the actual reader extension. +;; +(define (hash-comma char port) + (let* ((obj (read port))) + (if (and (list? obj) (positive? (length obj)) (symbol? (car obj))) + (let ((p (lookup (car obj)))) + (let ((res (apply p (cdr obj)))) + res)) + (error "syntax error in hash-comma expression")))) + +;; Install the hash extension. +;; +(read-hash-extend #\, hash-comma) + +;;; srfi-10.scm ends here diff --git a/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 (<tmp-x> <tmp-y> . <tmp-z>) +;; (call-with-values (lambda () (bar c)) +;; (lambda (<tmp-p> <tmp-q>) +;; (let ((x <tmp-x>) +;; (y <tmp-y>) +;; (z <tmp-z>) +;; (p <tmp-p>) +;; (q <tmp-q>)) +;; (baz x y z p q)))))) + +;; I originally wrote this as a define-macro, but then I found out +;; that guile's gensym/gentemp was broken, so I tried rewriting it as +;; a syntax-rules statement. +;; [make-symbol now fixes gensym/gentemp problems.] +;; +;; Since syntax-rules didn't seem powerful enough to implement +;; let-values in one definition without exposing illegal syntax (or +;; perhaps my brain's just not powerful enough :>). I tried writing +;; it using a private helper, but that didn't work because the +;; let-values expands outside the scope of this module. I wonder why +;; syntax-rules wasn't designed to allow "private" patterns or +;; similar... +;; +;; So in the end, I dumped the syntax-rules implementation, reproduced +;; here for posterity, and went with the define-macro one below -- +;; gensym/gentemp's got to be fixed anyhow... +; +; (define-syntax let-values-helper +; (syntax-rules () +; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y +; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda +; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the +; ;; temps you create so you can use them later... +; ;; +; ;; I really don't fully understand why the (var-1 var-1) trick +; ;; works below, but basically, when all those (x x) bindings show +; ;; up in the final "let", syntax-rules forces a renaming. + +; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings +; body ...) +; (lambda lambda-tmps +; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) + +; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings +; body ...) +; (let-values-helper "consumer" +; (var-2 ...) +; (lambda-tmp ... var-1) +; ((var-1 var-1) . final-let-bindings) +; lv-bindings +; body ...)) + +; ((_ "cwv" () final-let-bindings body ...) +; (let final-let-bindings +; body ...)) + +; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings +; body ...) +; (call-with-values (lambda () binding-1) +; (let-values-helper "consumer" +; vars-1 +; () +; final-let-bindings +; (other-bindings ...) +; body ...))))) +; +; (define-syntax let-values +; (syntax-rules () +; ((let-values () body ...) +; (begin body ...)) +; ((let-values (binding ...) body ...) +; (let-values-helper "cwv" (binding ...) () body ...)))) +; +; +; (define-syntax let-values +; (letrec-syntax ((build-consumer +; ;; Take the vars from one let binding (i.e. the (x +; ;; y z) from ((x y z) (values 1 2 3)) and turn it +; ;; in to the corresponding (lambda (<tmp-x> <tmp-y> +; ;; <tmp-z>) ...) from above. +; (syntax-rules () +; ((_ () new-tmps tmp-vars () body ...) +; (lambda new-tmps +; body ...)) +; ((_ () new-tmps tmp-vars vars body ...) +; (lambda new-tmps +; (lv-builder vars tmp-vars body ...))) +; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...) +; (build-consumer (var-2 ...) +; (tmp-1 . new-tmps) +; ((var-1 tmp-1) . tmp-vars) +; bindings +; body ...)))) +; (lv-builder +; (syntax-rules () +; ((_ () tmp-vars body ...) +; (let tmp-vars +; body ...)) +; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...) +; tmp-vars +; body ...) +; (call-with-values (lambda () binding-1) +; (build-consumer vars-1 +; () +; tmp-vars +; ((vars-2 binding-2) ...) +; body ...)))))) +; +; (syntax-rules () +; ((_ () body ...) +; (begin body ...)) +; ((_ ((vars binding) ...) body ...) +; (lv-builder ((vars binding) ...) () body ...))))) + +(define-macro (let-values vars . body) + + (define (map-1-dot proc elts) + ;; map over one optionally dotted (a b c . d) list, producing an + ;; optionally dotted result. + (cond + ((null? elts) '()) + ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts)))) + (else (proc elts)))) + + (define (undot-list lst) + ;; produce a non-dotted list from a possibly dotted list. + (cond + ((null? lst) '()) + ((pair? lst) (cons (car lst) (undot-list (cdr lst)))) + (else (list lst)))) + + (define (let-values-helper vars body prev-let-vars) + (let* ((var-binding (car vars)) + (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var")) + (car var-binding))) + (let-vars (map (lambda (sym tmp) (list sym tmp)) + (undot-list (car var-binding)) + (undot-list new-tmps)))) + + (if (null? (cdr vars)) + `(call-with-values (lambda () ,(cadr var-binding)) + (lambda ,new-tmps + (let ,(apply append let-vars prev-let-vars) + ,@body))) + `(call-with-values (lambda () ,(cadr var-binding)) + (lambda ,new-tmps + ,(let-values-helper (cdr vars) body + (cons let-vars prev-let-vars))))))) + + (if (null? vars) + `(begin ,@body) + (let-values-helper vars body '()))) + +;;;;;;;;;;;;;; +;; let*-values +;; +;; Current approach is to translate +;; +;; (let*-values (((x y z) (foo a b)) +;; ((p q) (bar c))) +;; (baz x y z p q)) +;; +;; into +;; +;; (call-with-values (lambda () (foo a b)) +;; (lambda (x y z) +;; (call-with-values (lambda (bar c)) +;; (lambda (p q) +;; (baz x y z p q))))) + +(define-syntax let*-values + (syntax-rules () + ((let*-values () body ...) + (begin body ...)) + ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) + (call-with-values (lambda () binding-1) + (lambda vars-1 + (let*-values ((vars-2 binding-2) ...) + body ...)))))) + +; Alternate define-macro implementation... +; +; (define-macro (let*-values vars . body) +; (define (let-values-helper vars body) +; (let ((var-binding (car vars))) +; (if (null? (cdr vars)) +; `(call-with-values (lambda () ,(cadr var-binding)) +; (lambda ,(car var-binding) +; ,@body)) +; `(call-with-values (lambda () ,(cadr var-binding)) +; (lambda ,(car var-binding) +; ,(let-values-helper (cdr vars) body)))))) + +; (if (null? vars) +; `(begin ,@body) +; (let-values-helper vars body))) + +;;; srfi-11.scm ends here diff --git a/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> +;; --> (case-lambda <case-lambda-clause>) +;; <case-lambda-clause> +;; --> (<signature> <definition-or-command>*) +;; <signature> +;; --> (<identifier>*) +;; | (<identifier>* . <identifier>) +;; | <identifier> +;; +;; The value returned by a `case-lambda' form is a procedure which +;; matches the number of actual arguments against the signatures in +;; the various clauses, in order. The first matching clause is +;; selected, the corresponding values from the actual parameter list +;; are bound to the variable names in the clauses and the body of the +;; clause is evaluated. + +;;; Code: + +(define-module (srfi srfi-16) + :export-syntax (case-lambda)) + +(cond-expand-provide (current-module) '(srfi-16)) + +(define-macro (case-lambda . clauses) + + ;; Return the length of the list @var{l}, but allow dotted list. + ;; + (define (alength l) + (cond ((null? l) 0) + ((pair? l) (+ 1 (alength (cdr l)))) + (else 0))) + + ;; Return @code{#t} if @var{l} is a dotted list, @code{#f} if it is + ;; a normal list. + ;; + (define (dotted? l) + (cond ((null? l) #f) + ((pair? l) (dotted? (cdr l))) + (else #t))) + + ;; Return the expression for accessing the @var{index}th element of + ;; the list called @var{args-name}. If @var{tail?} is true, code + ;; for accessing the list-tail is generated, otherwise for accessing + ;; the list element itself. + ;; + (define (accessor args-name index tail?) + (if tail? + (case index + ((0) `,args-name) + ((1) `(cdr ,args-name)) + ((2) `(cddr ,args-name)) + ((3) `(cdddr ,args-name)) + ((4) `(cddddr ,args-name)) + (else `(list-tail ,args-name ,index))) + (case index + ((0) `(car ,args-name)) + ((1) `(cadr ,args-name)) + ((2) `(caddr ,args-name)) + ((3) `(cadddr ,args-name)) + (else `(list-ref ,args-name ,index))))) + + ;; Generate the binding lists of the variables of one case-lambda + ;; clause. @var{vars} is the (possibly dotted) list of variables + ;; and @var{args-name} is the generated name used for the argument + ;; list. + ;; + (define (gen-temps vars args-name) + (let lp ((v vars) (i 0)) + (cond ((null? v) '()) + ((pair? v) + (cons `(,(car v) ,(accessor args-name i #f)) + (lp (cdr v) (+ i 1)))) + (else `((,v ,(accessor args-name i #t))))))) + + ;; Generate the cond clauses for each of the clauses of case-lambda, + ;; including the parameter count check, binding of the parameters + ;; and the code of the corresponding body. + ;; + (define (gen-clauses l length-name args-name) + (cond ((null? l) (list '(else (error "too few arguments")))) + (else + (cons + `((,(if (dotted? (caar l)) '>= '=) + ,length-name ,(alength (caar l))) + (let ,(gen-temps (caar l) args-name) + ,@(cdar l))) + (gen-clauses (cdr l) length-name args-name))))) + + (let ((args-name (gensym)) + (length-name (gensym))) + (let ((proc + `(lambda ,args-name + (let ((,length-name (length ,args-name))) + (cond ,@(gen-clauses clauses length-name args-name)))))) + proc))) + +;;; srfi-16.scm ends here diff --git a/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 <mkoeppe@mail.math.uni-magdeburg.de> + +;;; Commentary: + +;; This is an implementation of SRFI-17: Generalized set! +;; +;; It exports the Guile procedure `make-procedure-with-setter' under +;; the SRFI name `getter-with-setter' and exports the standard +;; procedures `car', `cdr', ..., `cdddr', `string-ref' and +;; `vector-ref' as procedures with setters, as required by the SRFI. +;; +;; SRFI-17 was heavily criticized during its discussion period but it +;; was finalized anyway. One issue was its concept of globally +;; associating setter "properties" with (procedure) values, which is +;; non-Schemy. For this reason, this implementation chooses not to +;; provide a way to set the setter of a procedure. In fact, (set! +;; (setter PROC) SETTER) signals an error. The only way to attach a +;; setter to a procedure is to create a new object (a "procedure with +;; setter") via the `getter-with-setter' procedure. This procedure is +;; also specified in the SRFI. Using it avoids the described +;; problems. +;; +;; This module is fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-17) + :export (getter-with-setter) + :replace (;; redefined standard procedures + setter + car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar + cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr + caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr + cdddar cddddr string-ref vector-ref)) + +(cond-expand-provide (current-module) '(srfi-17)) + +;;; Procedures + +(define getter-with-setter make-procedure-with-setter) + +(define setter + (getter-with-setter + (@ (guile) setter) + (lambda args + (error "Setting setters is not supported for a good reason.")))) + +;;; Redefine R5RS procedures to appropriate procedures with setters + +(define (compose-setter setter location) + (lambda (obj value) + (setter (location obj) value))) + +(define car + (getter-with-setter (@ (guile) car) + set-car!)) +(define cdr + (getter-with-setter (@ (guile) cdr) + set-cdr!)) + +(define caar + (getter-with-setter (@ (guile) caar) + (compose-setter set-car! (@ (guile) car)))) +(define cadr + (getter-with-setter (@ (guile) cadr) + (compose-setter set-car! (@ (guile) cdr)))) +(define cdar + (getter-with-setter (@ (guile) cdar) + (compose-setter set-cdr! (@ (guile) car)))) +(define cddr + (getter-with-setter (@ (guile) cddr) + (compose-setter set-cdr! (@ (guile) cdr)))) + +(define caaar + (getter-with-setter (@ (guile) caaar) + (compose-setter set-car! (@ (guile) caar)))) +(define caadr + (getter-with-setter (@ (guile) caadr) + (compose-setter set-car! (@ (guile) cadr)))) +(define cadar + (getter-with-setter (@ (guile) cadar) + (compose-setter set-car! (@ (guile) cdar)))) +(define caddr + (getter-with-setter (@ (guile) caddr) + (compose-setter set-car! (@ (guile) cddr)))) +(define cdaar + (getter-with-setter (@ (guile) cdaar) + (compose-setter set-cdr! (@ (guile) caar)))) +(define cdadr + (getter-with-setter (@ (guile) cdadr) + (compose-setter set-cdr! (@ (guile) cadr)))) +(define cddar + (getter-with-setter (@ (guile) cddar) + (compose-setter set-cdr! (@ (guile) cdar)))) +(define cdddr + (getter-with-setter (@ (guile) cdddr) + (compose-setter set-cdr! (@ (guile) cddr)))) + +(define caaaar + (getter-with-setter (@ (guile) caaaar) + (compose-setter set-car! (@ (guile) caaar)))) +(define caaadr + (getter-with-setter (@ (guile) caaadr) + (compose-setter set-car! (@ (guile) caadr)))) +(define caadar + (getter-with-setter (@ (guile) caadar) + (compose-setter set-car! (@ (guile) cadar)))) +(define caaddr + (getter-with-setter (@ (guile) caaddr) + (compose-setter set-car! (@ (guile) caddr)))) +(define cadaar + (getter-with-setter (@ (guile) cadaar) + (compose-setter set-car! (@ (guile) cdaar)))) +(define cadadr + (getter-with-setter (@ (guile) cadadr) + (compose-setter set-car! (@ (guile) cdadr)))) +(define caddar + (getter-with-setter (@ (guile) caddar) + (compose-setter set-car! (@ (guile) cddar)))) +(define cadddr + (getter-with-setter (@ (guile) cadddr) + (compose-setter set-car! (@ (guile) cdddr)))) +(define cdaaar + (getter-with-setter (@ (guile) cdaaar) + (compose-setter set-cdr! (@ (guile) caaar)))) +(define cdaadr + (getter-with-setter (@ (guile) cdaadr) + (compose-setter set-cdr! (@ (guile) caadr)))) +(define cdadar + (getter-with-setter (@ (guile) cdadar) + (compose-setter set-cdr! (@ (guile) cadar)))) +(define cdaddr + (getter-with-setter (@ (guile) cdaddr) + (compose-setter set-cdr! (@ (guile) caddr)))) +(define cddaar + (getter-with-setter (@ (guile) cddaar) + (compose-setter set-cdr! (@ (guile) cdaar)))) +(define cddadr + (getter-with-setter (@ (guile) cddadr) + (compose-setter set-cdr! (@ (guile) cdadr)))) +(define cdddar + (getter-with-setter (@ (guile) cdddar) + (compose-setter set-cdr! (@ (guile) cddar)))) +(define cddddr + (getter-with-setter (@ (guile) cddddr) + (compose-setter set-cdr! (@ (guile) cdddr)))) + +(define string-ref + (getter-with-setter (@ (guile) string-ref) + string-set!)) + +(define vector-ref + (getter-with-setter (@ (guile) vector-ref) + vector-set!)) + +;;; srfi-17.scm ends here diff --git a/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 <julian.graham@aya.yale.edu> +;;; Date: 2008-04-11 + +;;; Commentary: + +;; This is an implementation of SRFI-18 (Multithreading support). +;; +;; All procedures defined in SRFI-18, which are not already defined in +;; the Guile core library, are exported. +;; +;; This module is fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-18) + :use-module (srfi srfi-34) + :export ( + +;;; Threads + ;; current-thread <= in the core + ;; thread? <= in the core + make-thread + thread-name + thread-specific + thread-specific-set! + thread-start! + thread-yield! + thread-sleep! + thread-terminate! + thread-join! + +;;; Mutexes + ;; mutex? <= in the core + make-mutex + mutex-name + mutex-specific + mutex-specific-set! + mutex-state + mutex-lock! + mutex-unlock! + +;;; Condition variables + ;; condition-variable? <= in the core + make-condition-variable + condition-variable-name + condition-variable-specific + condition-variable-specific-set! + condition-variable-signal! + condition-variable-broadcast! + condition-variable-wait! + +;;; Time + current-time + time? + time->seconds + seconds->time + + current-exception-handler + with-exception-handler + raise + join-timeout-exception? + abandoned-mutex-exception? + terminated-thread-exception? + uncaught-exception? + uncaught-exception-reason + ) + :re-export (thread? mutex? condition-variable?) + :replace (current-time + make-thread + make-mutex + make-condition-variable + raise)) + +(if (not (provided? 'threads)) + (error "SRFI-18 requires Guile with threads support")) + +(cond-expand-provide (current-module) '(srfi-18)) + +(define (check-arg-type pred arg caller) + (if (pred arg) + arg + (scm-error 'wrong-type-arg caller + "Wrong type argument: ~S" (list arg) '()))) + +(define abandoned-mutex-exception (list 'abandoned-mutex-exception)) +(define join-timeout-exception (list 'join-timeout-exception)) +(define terminated-thread-exception (list 'terminated-thread-exception)) +(define uncaught-exception (list 'uncaught-exception)) + +(define mutex-owners (make-weak-key-hash-table)) +(define object-names (make-weak-key-hash-table)) +(define object-specifics (make-weak-key-hash-table)) +(define thread-start-conds (make-weak-key-hash-table)) +(define thread-exception-handlers (make-weak-key-hash-table)) + +;; EXCEPTIONS + +(define raise (@ (srfi srfi-34) raise)) +(define (initial-handler obj) + (srfi-18-exception-preserver (cons uncaught-exception obj))) + +(define thread->exception (make-object-property)) + +(define (srfi-18-exception-preserver obj) + (if (or (terminated-thread-exception? obj) + (uncaught-exception? obj)) + (set! (thread->exception (current-thread)) obj))) + +(define (srfi-18-exception-handler key . args) + + ;; SRFI 34 exceptions continue to bubble up no matter who handles them, so + ;; if one is caught at this level, it has already been taken care of by + ;; `initial-handler'. + + (and (not (eq? key 'srfi-34)) + (srfi-18-exception-preserver (if (null? args) + (cons uncaught-exception key) + (cons* uncaught-exception key args))))) + +(define (current-handler-stack) + (let ((ct (current-thread))) + (or (hashq-ref thread-exception-handlers ct) + (hashq-set! thread-exception-handlers ct (list initial-handler))))) + +(define (with-exception-handler handler thunk) + (let ((ct (current-thread)) + (hl (current-handler-stack))) + (check-arg-type procedure? handler "with-exception-handler") + (check-arg-type thunk? thunk "with-exception-handler") + (hashq-set! thread-exception-handlers ct (cons handler hl)) + (apply (@ (srfi srfi-34) with-exception-handler) + (list (lambda (obj) + (hashq-set! thread-exception-handlers ct hl) + (handler obj)) + (lambda () + (let ((r (thunk))) + (hashq-set! thread-exception-handlers ct hl) r)))))) + +(define (current-exception-handler) + (car (current-handler-stack))) + +(define (join-timeout-exception? obj) (eq? obj join-timeout-exception)) +(define (abandoned-mutex-exception? obj) (eq? obj abandoned-mutex-exception)) +(define (uncaught-exception? obj) + (and (pair? obj) (eq? (car obj) uncaught-exception))) +(define (uncaught-exception-reason exc) + (cdr (check-arg-type uncaught-exception? exc "uncaught-exception-reason"))) +(define (terminated-thread-exception? obj) + (eq? obj terminated-thread-exception)) + +;; THREADS + +;; Create a new thread and prevent it from starting using a condition variable. +;; Once started, install a top-level exception handler that rethrows any +;; exceptions wrapped in an uncaught-exception wrapper. + +(define make-thread + (let ((make-cond-wrapper (lambda (thunk lcond lmutex scond smutex) + (lambda () + (lock-mutex lmutex) + (signal-condition-variable lcond) + (lock-mutex smutex) + (unlock-mutex lmutex) + (wait-condition-variable scond smutex) + (unlock-mutex smutex) + (with-exception-handler initial-handler + thunk))))) + (lambda (thunk . name) + (let ((n (and (pair? name) (car name))) + + (lm (make-mutex 'launch-mutex)) + (lc (make-condition-variable 'launch-condition-variable)) + (sm (make-mutex 'start-mutex)) + (sc (make-condition-variable 'start-condition-variable))) + + (lock-mutex lm) + (let ((t (call-with-new-thread (make-cond-wrapper thunk lc lm sc sm) + srfi-18-exception-handler))) + (hashq-set! thread-start-conds t (cons sm sc)) + (and n (hashq-set! object-names t n)) + (wait-condition-variable lc lm) + (unlock-mutex lm) + t))))) + +(define (thread-name thread) + (hashq-ref object-names (check-arg-type thread? thread "thread-name"))) + +(define (thread-specific thread) + (hashq-ref object-specifics + (check-arg-type thread? thread "thread-specific"))) + +(define (thread-specific-set! thread obj) + (hashq-set! object-specifics + (check-arg-type thread? thread "thread-specific-set!") + obj) + *unspecified*) + +(define (thread-start! thread) + (let ((x (hashq-ref thread-start-conds + (check-arg-type thread? thread "thread-start!")))) + (and x (let ((smutex (car x)) + (scond (cdr x))) + (hashq-remove! thread-start-conds thread) + (lock-mutex smutex) + (signal-condition-variable scond) + (unlock-mutex smutex))) + thread)) + +(define (thread-yield!) (yield) *unspecified*) + +(define (thread-sleep! timeout) + (let* ((ct (time->seconds (current-time))) + (t (cond ((time? timeout) (- (time->seconds timeout) ct)) + ((number? timeout) (- timeout ct)) + (else (scm-error 'wrong-type-arg caller + "Wrong type argument: ~S" + (list timeout) + '())))) + (secs (inexact->exact (truncate t))) + (usecs (inexact->exact (truncate (* (- t secs) 1000))))) + (and (> secs 0) (sleep secs)) + (and (> usecs 0) (usleep usecs)) + *unspecified*)) + +;; A convenience function for installing exception handlers on SRFI-18 +;; primitives that resume the calling continuation after the handler is +;; invoked -- this resolves a behavioral incompatibility with Guile's +;; implementation of SRFI-34, which uses lazy-catch and rethrows handled +;; exceptions. (SRFI-18, "Primitives and exceptions") + +(define (wrap thunk) + (lambda (continuation) + (with-exception-handler (lambda (obj) + (apply (current-exception-handler) (list obj)) + (apply continuation (list))) + thunk))) + +;; A pass-thru to cancel-thread that first installs a handler that throws +;; terminated-thread exception, as per SRFI-18, + +(define (thread-terminate! thread) + (define (thread-terminate-inner!) + (let ((current-handler (thread-cleanup thread))) + (if (thunk? current-handler) + (set-thread-cleanup! thread + (lambda () + (with-exception-handler initial-handler + current-handler) + (srfi-18-exception-preserver + terminated-thread-exception))) + (set-thread-cleanup! thread + (lambda () (srfi-18-exception-preserver + terminated-thread-exception)))) + (cancel-thread thread) + *unspecified*)) + (thread-terminate-inner!)) + +(define (thread-join! thread . args) + (define thread-join-inner! + (wrap (lambda () + (let ((v (apply join-thread (cons thread args))) + (e (thread->exception thread))) + (if (and (= (length args) 1) (not v)) + (raise join-timeout-exception)) + (if e (raise e)) + v)))) + (call/cc thread-join-inner!)) + +;; MUTEXES +;; These functions are all pass-thrus to the existing Guile implementations. + +(define make-mutex + (lambda name + (let ((n (and (pair? name) (car name))) + (m ((@ (guile) make-mutex) + 'unchecked-unlock + 'allow-external-unlock + 'recursive))) + (and n (hashq-set! object-names m n)) m))) + +(define (mutex-name mutex) + (hashq-ref object-names (check-arg-type mutex? mutex "mutex-name"))) + +(define (mutex-specific mutex) + (hashq-ref object-specifics + (check-arg-type mutex? mutex "mutex-specific"))) + +(define (mutex-specific-set! mutex obj) + (hashq-set! object-specifics + (check-arg-type mutex? mutex "mutex-specific-set!") + obj) + *unspecified*) + +(define (mutex-state mutex) + (let ((owner (mutex-owner mutex))) + (if owner + (if (thread-exited? owner) 'abandoned owner) + (if (> (mutex-level mutex) 0) 'not-owned 'not-abandoned)))) + +(define (mutex-lock! mutex . args) + (define mutex-lock-inner! + (wrap (lambda () + (catch 'abandoned-mutex-error + (lambda () (apply lock-mutex (cons mutex args))) + (lambda (key . args) (raise abandoned-mutex-exception)))))) + (call/cc mutex-lock-inner!)) + +(define (mutex-unlock! mutex . args) + (apply unlock-mutex (cons mutex args))) + +;; CONDITION VARIABLES +;; These functions are all pass-thrus to the existing Guile implementations. + +(define make-condition-variable + (lambda name + (let ((n (and (pair? name) (car name))) + (m ((@ (guile) make-condition-variable)))) + (and n (hashq-set! object-names m n)) m))) + +(define (condition-variable-name condition-variable) + (hashq-ref object-names (check-arg-type condition-variable? + condition-variable + "condition-variable-name"))) + +(define (condition-variable-specific condition-variable) + (hashq-ref object-specifics (check-arg-type condition-variable? + condition-variable + "condition-variable-specific"))) + +(define (condition-variable-specific-set! condition-variable obj) + (hashq-set! object-specifics + (check-arg-type condition-variable? + condition-variable + "condition-variable-specific-set!") + obj) + *unspecified*) + +(define (condition-variable-signal! cond) + (signal-condition-variable cond) + *unspecified*) + +(define (condition-variable-broadcast! cond) + (broadcast-condition-variable cond) + *unspecified*) + +;; TIME + +(define current-time gettimeofday) +(define (time? obj) + (and (pair? obj) + (let ((co (car obj))) (and (integer? co) (>= co 0))) + (let ((co (cdr obj))) (and (integer? co) (>= co 0))))) + +(define (time->seconds time) + (and (check-arg-type time? time "time->seconds") + (+ (car time) (/ (cdr time) 1000000)))) + +(define (seconds->time x) + (and (check-arg-type number? x "seconds->time") + (let ((fx (truncate x))) + (cons (inexact->exact fx) + (inexact->exact (truncate (* (- x fx) 1000000))))))) + +;; srfi-18.scm ends here
\ No newline at end of file diff --git a/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 <rlb@cs.utexas.edu> +;;; Originally from SRFI reference implementation by Will Fitzgerald. + +;;; Commentary: + +;; This module is fully documented in the Guile Reference Manual. + +;;; Code: + +;; FIXME: I haven't checked a decent amount of this code for potential +;; performance improvements, but I suspect that there may be some +;; substantial ones to be realized, esp. in the later "parsing" half +;; of the file, by rewriting the code with use of more Guile native +;; functions that do more work in a "chunk". +;; +;; FIXME: mkoeppe: Time zones are treated a little simplistic in +;; SRFI-19; they are only a numeric offset. Thus, printing time zones +;; (PRIV:LOCALE-PRINT-TIME-ZONE) can't be implemented sensibly. The +;; functions taking an optional TZ-OFFSET should be extended to take a +;; symbolic time-zone (like "CET"); this string should be stored in +;; the DATE structure. + +(define-module (srfi srfi-19) + :use-module (srfi srfi-6) + :use-module (srfi srfi-8) + :use-module (srfi srfi-9) + :use-module (ice-9 i18n)) + +(begin-deprecated + ;; Prevent `export' from re-exporting core bindings. This behaviour + ;; of `export' is deprecated and will disappear in one of the next + ;; releases. + (define current-time #f)) + +(export ;; Constants + time-duration + time-monotonic + time-process + time-tai + time-thread + time-utc + ;; Current time and clock resolution + current-date + current-julian-day + current-modified-julian-day + current-time + time-resolution + ;; Time object and accessors + make-time + time? + time-type + time-nanosecond + time-second + set-time-type! + set-time-nanosecond! + set-time-second! + copy-time + ;; Time comparison procedures + time<=? + time<? + time=? + time>=? + time>? + ;; Time arithmetic procedures + time-difference + time-difference! + add-duration + add-duration! + subtract-duration + subtract-duration! + ;; Date object and accessors + make-date + date? + date-nanosecond + date-second + date-minute + date-hour + date-day + date-month + date-year + date-zone-offset + date-year-day + date-week-day + date-week-number + ;; Time/Date/Julian Day/Modified Julian Day converters + date->julian-day + date->modified-julian-day + date->time-monotonic + date->time-tai + date->time-utc + julian-day->date + julian-day->time-monotonic + julian-day->time-tai + julian-day->time-utc + modified-julian-day->date + modified-julian-day->time-monotonic + modified-julian-day->time-tai + modified-julian-day->time-utc + time-monotonic->date + time-monotonic->time-tai + time-monotonic->time-tai! + time-monotonic->time-utc + time-monotonic->time-utc! + time-tai->date + time-tai->julian-day + time-tai->modified-julian-day + time-tai->time-monotonic + time-tai->time-monotonic! + time-tai->time-utc + time-tai->time-utc! + time-utc->date + time-utc->julian-day + time-utc->modified-julian-day + time-utc->time-monotonic + time-utc->time-monotonic! + time-utc->time-tai + time-utc->time-tai! + ;; Date to string/string to date converters. + date->string + string->date) + +(cond-expand-provide (current-module) '(srfi-19)) + +(define time-tai 'time-tai) +(define time-utc 'time-utc) +(define time-monotonic 'time-monotonic) +(define time-thread 'time-thread) +(define time-process 'time-process) +(define time-duration 'time-duration) + +;; FIXME: do we want to add gc time? +;; (define time-gc 'time-gc) + +;;-- LOCALE dependent constants + +(define priv:locale-number-separator locale-decimal-point) +(define priv:locale-pm locale-pm-string) +(define priv:locale-am locale-am-string) + +;; See date->string +(define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y") +(define priv:locale-short-date-format "~m/~d/~y") +(define priv:locale-time-format "~H:~M:~S") +(define priv:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z") + +;;-- Miscellaneous Constants. +;;-- only the priv:tai-epoch-in-jd might need changing if +;; a different epoch is used. + +(define priv:nano 1000000000) ; nanoseconds in a second +(define priv:sid 86400) ; seconds in a day +(define priv:sihd 43200) ; seconds in a half day +(define priv:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch' + +;; FIXME: should this be something other than misc-error? +(define (priv:time-error caller type value) + (if value + (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f) + (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f))) + +;; A table of leap seconds +;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat +;; and update as necessary. +;; this procedures reads the file in the abover +;; format and creates the leap second table +;; it also calls the almost standard, but not R5 procedures read-line +;; & open-input-string +;; ie (set! priv:leap-second-table (priv:read-tai-utc-date "tai-utc.dat")) + +(define (priv:read-tai-utc-data filename) + (define (convert-jd jd) + (* (- (inexact->exact jd) priv:tai-epoch-in-jd) priv:sid)) + (define (convert-sec sec) + (inexact->exact sec)) + (let ((port (open-input-file filename)) + (table '())) + (let loop ((line (read-line port))) + (if (not (eof-object? line)) + (begin + (let* ((data (read (open-input-string + (string-append "(" line ")")))) + (year (car data)) + (jd (cadddr (cdr data))) + (secs (cadddr (cdddr data)))) + (if (>= year 1972) + (set! table (cons + (cons (convert-jd jd) (convert-sec secs)) + table))) + (loop (read-line port)))))) + table)) + +;; each entry is (tai seconds since epoch . # seconds to subtract for utc) +;; note they go higher to lower, and end in 1972. +(define priv:leap-second-table + '((1136073600 . 33) + (915148800 . 32) + (867715200 . 31) + (820454400 . 30) + (773020800 . 29) + (741484800 . 28) + (709948800 . 27) + (662688000 . 26) + (631152000 . 25) + (567993600 . 24) + (489024000 . 23) + (425865600 . 22) + (394329600 . 21) + (362793600 . 20) + (315532800 . 19) + (283996800 . 18) + (252460800 . 17) + (220924800 . 16) + (189302400 . 15) + (157766400 . 14) + (126230400 . 13) + (94694400 . 12) + (78796800 . 11) + (63072000 . 10))) + +(define (read-leap-second-table filename) + (set! priv:leap-second-table (priv:read-tai-utc-data filename)) + (values)) + + +(define (priv:leap-second-delta utc-seconds) + (letrec ((lsd (lambda (table) + (cond ((>= utc-seconds (caar table)) + (cdar table)) + (else (lsd (cdr table))))))) + (if (< utc-seconds (* (- 1972 1970) 365 priv:sid)) 0 + (lsd priv:leap-second-table)))) + + +;;; the TIME structure; creates the accessors, too. + +(define-record-type time + (make-time-unnormalized type nanosecond second) + time? + (type time-type set-time-type!) + (nanosecond time-nanosecond set-time-nanosecond!) + (second time-second set-time-second!)) + +(define (copy-time time) + (make-time (time-type time) (time-nanosecond time) (time-second time))) + +(define (priv:split-real r) + (if (integer? r) + (values (inexact->exact r) 0) + (let ((l (truncate r))) + (values (inexact->exact l) (- r l))))) + +(define (priv:time-normalize! t) + (if (>= (abs (time-nanosecond t)) 1000000000) + (receive (int frac) + (priv:split-real (time-nanosecond t)) + (set-time-second! t (+ (time-second t) + (quotient int 1000000000))) + (set-time-nanosecond! t (+ (remainder int 1000000000) + frac)))) + (if (and (positive? (time-second t)) + (negative? (time-nanosecond t))) + (begin + (set-time-second! t (- (time-second t) 1)) + (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))) + (if (and (negative? (time-second t)) + (positive? (time-nanosecond t))) + (begin + (set-time-second! t (+ (time-second t) 1)) + (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))))) + t) + +(define (make-time type nanosecond second) + (priv:time-normalize! (make-time-unnormalized type nanosecond second))) + +;; Helpers +;; FIXME: finish this and publish it? +(define (date->broken-down-time date) + (let ((result (mktime 0))) + ;; FIXME: What should we do about leap-seconds which may overflow + ;; set-tm:sec? + (set-tm:sec result (date-second date)) + (set-tm:min result (date-minute date)) + (set-tm:hour result (date-hour date)) + ;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday). + (set-tm:mday result (date-day date)) + (set-tm:month result (- (date-month date) 1)) + ;; FIXME: need to signal error on range violation. + (set-tm:year result (+ 1900 (date-year date))) + (set-tm:isdst result -1) + (set-tm:gmtoff result (- (date-zone-offset date))) + result)) + +;;; current-time + +;;; specific time getters. + +(define (priv:current-time-utc) + ;; Resolution is microseconds. + (let ((tod (gettimeofday))) + (make-time time-utc (* (cdr tod) 1000) (car tod)))) + +(define (priv:current-time-tai) + ;; Resolution is microseconds. + (let* ((tod (gettimeofday)) + (sec (car tod)) + (usec (cdr tod))) + (make-time time-tai + (* usec 1000) + (+ (car tod) (priv:leap-second-delta sec))))) + +;;(define (priv:current-time-ms-time time-type proc) +;; (let ((current-ms (proc))) +;; (make-time time-type +;; (quotient current-ms 10000) +;; (* (remainder current-ms 1000) 10000)))) + +;; -- we define it to be the same as TAI. +;; A different implemation of current-time-montonic +;; will require rewriting all of the time-monotonic converters, +;; of course. + +(define (priv:current-time-monotonic) + ;; Resolution is microseconds. + (priv:current-time-tai)) + +(define (priv:current-time-thread) + (priv:time-error 'current-time 'unsupported-clock-type 'time-thread)) + +(define priv:ns-per-guile-tick (/ 1000000000 internal-time-units-per-second)) + +(define (priv:current-time-process) + (let ((run-time (get-internal-run-time))) + (make-time + time-process + (* (remainder run-time internal-time-units-per-second) + priv:ns-per-guile-tick) + (quotient run-time internal-time-units-per-second)))) + +;;(define (priv:current-time-gc) +;; (priv:current-time-ms-time time-gc current-gc-milliseconds)) + +(define (current-time . clock-type) + (let ((clock-type (if (null? clock-type) time-utc (car clock-type)))) + (cond + ((eq? clock-type time-tai) (priv:current-time-tai)) + ((eq? clock-type time-utc) (priv:current-time-utc)) + ((eq? clock-type time-monotonic) (priv:current-time-monotonic)) + ((eq? clock-type time-thread) (priv:current-time-thread)) + ((eq? clock-type time-process) (priv:current-time-process)) + ;; ((eq? clock-type time-gc) (priv:current-time-gc)) + (else (priv:time-error 'current-time 'invalid-clock-type clock-type))))) + +;; -- Time Resolution +;; This is the resolution of the clock in nanoseconds. +;; This will be implementation specific. + +(define (time-resolution . clock-type) + (let ((clock-type (if (null? clock-type) time-utc (car clock-type)))) + (case clock-type + ((time-tai) 1000) + ((time-utc) 1000) + ((time-monotonic) 1000) + ((time-process) priv:ns-per-guile-tick) + ;; ((eq? clock-type time-thread) 1000) + ;; ((eq? clock-type time-gc) 10000) + (else (priv:time-error 'time-resolution 'invalid-clock-type clock-type))))) + +;; -- Time comparisons + +(define (time=? t1 t2) + ;; Arrange tests for speed and presume that t1 and t2 are actually times. + ;; also presume it will be rare to check two times of different types. + (and (= (time-second t1) (time-second t2)) + (= (time-nanosecond t1) (time-nanosecond t2)) + (eq? (time-type t1) (time-type t2)))) + +(define (time>? t1 t2) + (or (> (time-second t1) (time-second t2)) + (and (= (time-second t1) (time-second t2)) + (> (time-nanosecond t1) (time-nanosecond t2))))) + +(define (time<? t1 t2) + (or (< (time-second t1) (time-second t2)) + (and (= (time-second t1) (time-second t2)) + (< (time-nanosecond t1) (time-nanosecond t2))))) + +(define (time>=? t1 t2) + (or (> (time-second t1) (time-second t2)) + (and (= (time-second t1) (time-second t2)) + (>= (time-nanosecond t1) (time-nanosecond t2))))) + +(define (time<=? t1 t2) + (or (< (time-second t1) (time-second t2)) + (and (= (time-second t1) (time-second t2)) + (<= (time-nanosecond t1) (time-nanosecond t2))))) + +;; -- Time arithmetic + +(define (time-difference! time1 time2) + (let ((sec-diff (- (time-second time1) (time-second time2))) + (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2)))) + (set-time-type! time1 time-duration) + (set-time-second! time1 sec-diff) + (set-time-nanosecond! time1 nsec-diff) + (priv:time-normalize! time1))) + +(define (time-difference time1 time2) + (let ((result (copy-time time1))) + (time-difference! result time2))) + +(define (add-duration! t duration) + (if (not (eq? (time-type duration) time-duration)) + (priv:time-error 'add-duration 'not-duration duration) + (let ((sec-plus (+ (time-second t) (time-second duration))) + (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration)))) + (set-time-second! t sec-plus) + (set-time-nanosecond! t nsec-plus) + (priv:time-normalize! t)))) + +(define (add-duration t duration) + (let ((result (copy-time t))) + (add-duration! result duration))) + +(define (subtract-duration! t duration) + (if (not (eq? (time-type duration) time-duration)) + (priv:time-error 'add-duration 'not-duration duration) + (let ((sec-minus (- (time-second t) (time-second duration))) + (nsec-minus (- (time-nanosecond t) (time-nanosecond duration)))) + (set-time-second! t sec-minus) + (set-time-nanosecond! t nsec-minus) + (priv:time-normalize! t)))) + +(define (subtract-duration time1 duration) + (let ((result (copy-time time1))) + (subtract-duration! result duration))) + +;; -- Converters between types. + +(define (priv:time-tai->time-utc! time-in time-out caller) + (if (not (eq? (time-type time-in) time-tai)) + (priv:time-error caller 'incompatible-time-types time-in)) + (set-time-type! time-out time-utc) + (set-time-nanosecond! time-out (time-nanosecond time-in)) + (set-time-second! time-out (- (time-second time-in) + (priv:leap-second-delta + (time-second time-in)))) + time-out) + +(define (time-tai->time-utc time-in) + (priv:time-tai->time-utc! time-in (make-time-unnormalized #f #f #f) 'time-tai->time-utc)) + + +(define (time-tai->time-utc! time-in) + (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!)) + +(define (priv:time-utc->time-tai! time-in time-out caller) + (if (not (eq? (time-type time-in) time-utc)) + (priv:time-error caller 'incompatible-time-types time-in)) + (set-time-type! time-out time-tai) + (set-time-nanosecond! time-out (time-nanosecond time-in)) + (set-time-second! time-out (+ (time-second time-in) + (priv:leap-second-delta + (time-second time-in)))) + time-out) + +(define (time-utc->time-tai time-in) + (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-tai)) + +(define (time-utc->time-tai! time-in) + (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!)) + +;; -- these depend on time-monotonic having the same definition as time-tai! +(define (time-monotonic->time-utc time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (priv:time-error caller 'incompatible-time-types time-in)) + (let ((ntime (copy-time time-in))) + (set-time-type! ntime time-tai) + (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))) + +(define (time-monotonic->time-utc! time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (priv:time-error caller 'incompatible-time-types time-in)) + (set-time-type! time-in time-tai) + (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)) + +(define (time-monotonic->time-tai time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (priv:time-error caller 'incompatible-time-types time-in)) + (let ((ntime (copy-time time-in))) + (set-time-type! ntime time-tai) + ntime)) + +(define (time-monotonic->time-tai! time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (priv:time-error caller 'incompatible-time-types time-in)) + (set-time-type! time-in time-tai) + time-in) + +(define (time-utc->time-monotonic time-in) + (if (not (eq? (time-type time-in) time-utc)) + (priv:time-error caller 'incompatible-time-types time-in)) + (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) + 'time-utc->time-monotonic))) + (set-time-type! ntime time-monotonic) + ntime)) + +(define (time-utc->time-monotonic! time-in) + (if (not (eq? (time-type time-in) time-utc)) + (priv:time-error caller 'incompatible-time-types time-in)) + (let ((ntime (priv:time-utc->time-tai! time-in time-in + 'time-utc->time-monotonic!))) + (set-time-type! ntime time-monotonic) + ntime)) + +(define (time-tai->time-monotonic time-in) + (if (not (eq? (time-type time-in) time-tai)) + (priv:time-error caller 'incompatible-time-types time-in)) + (let ((ntime (copy-time time-in))) + (set-time-type! ntime time-monotonic) + ntime)) + +(define (time-tai->time-monotonic! time-in) + (if (not (eq? (time-type time-in) time-tai)) + (priv:time-error caller 'incompatible-time-types time-in)) + (set-time-type! time-in time-monotonic) + time-in) + +;; -- Date Structures + +;; FIXME: to be really safe, perhaps we should normalize the +;; seconds/nanoseconds/minutes coming in to make-date... + +(define-record-type date + (make-date nanosecond second minute + hour day month + year + zone-offset) + date? + (nanosecond date-nanosecond set-date-nanosecond!) + (second date-second set-date-second!) + (minute date-minute set-date-minute!) + (hour date-hour set-date-hour!) + (day date-day set-date-day!) + (month date-month set-date-month!) + (year date-year set-date-year!) + (zone-offset date-zone-offset set-date-zone-offset!)) + +;; gives the julian day which starts at noon. +(define (priv:encode-julian-day-number day month year) + (let* ((a (quotient (- 14 month) 12)) + (y (- (+ year 4800) a (if (negative? year) -1 0))) + (m (- (+ month (* 12 a)) 3))) + (+ day + (quotient (+ (* 153 m) 2) 5) + (* 365 y) + (quotient y 4) + (- (quotient y 100)) + (quotient y 400) + -32045))) + +;; gives the seconds/date/month/year +(define (priv:decode-julian-day-number jdn) + (let* ((days (inexact->exact (truncate jdn))) + (a (+ days 32044)) + (b (quotient (+ (* 4 a) 3) 146097)) + (c (- a (quotient (* 146097 b) 4))) + (d (quotient (+ (* 4 c) 3) 1461)) + (e (- c (quotient (* 1461 d) 4))) + (m (quotient (+ (* 5 e) 2) 153)) + (y (+ (* 100 b) d -4800 (quotient m 10)))) + (values ; seconds date month year + (* (- jdn days) priv:sid) + (+ e (- (quotient (+ (* 153 m) 2) 5)) 1) + (+ m 3 (* -12 (quotient m 10))) + (if (>= 0 y) (- y 1) y)))) + +;; relies on the fact that we named our time zone accessor +;; differently from MzScheme's.... +;; This should be written to be OS specific. + +(define (priv:local-tz-offset utc-time) + ;; SRFI uses seconds West, but guile (and libc) use seconds East. + (- (tm:gmtoff (localtime (time-second utc-time))))) + +;; special thing -- ignores nanos +(define (priv:time->julian-day-number seconds tz-offset) + (+ (/ (+ seconds tz-offset priv:sihd) + priv:sid) + priv:tai-epoch-in-jd)) + +(define (priv:leap-second? second) + (and (assoc second priv:leap-second-table) #t)) + +(define (time-utc->date time . tz-offset) + (if (not (eq? (time-type time) time-utc)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (let* ((offset (if (null? tz-offset) + (priv:local-tz-offset time) + (car tz-offset))) + (leap-second? (priv:leap-second? (+ offset (time-second time)))) + (jdn (priv:time->julian-day-number (if leap-second? + (- (time-second time) 1) + (time-second time)) + offset))) + + (call-with-values (lambda () (priv:decode-julian-day-number jdn)) + (lambda (secs date month year) + ;; secs is a real because jdn is a real in Guile; + ;; but it is conceptionally an integer. + (let* ((int-secs (inexact->exact (round secs))) + (hours (quotient int-secs (* 60 60))) + (rem (remainder int-secs (* 60 60))) + (minutes (quotient rem 60)) + (seconds (remainder rem 60))) + (make-date (time-nanosecond time) + (if leap-second? (+ seconds 1) seconds) + minutes + hours + date + month + year + offset)))))) + +(define (time-tai->date time . tz-offset) + (if (not (eq? (time-type time) time-tai)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (let* ((offset (if (null? tz-offset) + (priv:local-tz-offset (time-tai->time-utc time)) + (car tz-offset))) + (seconds (- (time-second time) + (priv:leap-second-delta (time-second time)))) + (leap-second? (priv:leap-second? (+ offset seconds))) + (jdn (priv:time->julian-day-number (if leap-second? + (- seconds 1) + seconds) + offset))) + (call-with-values (lambda () (priv:decode-julian-day-number jdn)) + (lambda (secs date month year) + ;; secs is a real because jdn is a real in Guile; + ;; but it is conceptionally an integer. + ;; adjust for leap seconds if necessary ... + (let* ((int-secs (inexact->exact (round secs))) + (hours (quotient int-secs (* 60 60))) + (rem (remainder int-secs (* 60 60))) + (minutes (quotient rem 60)) + (seconds (remainder rem 60))) + (make-date (time-nanosecond time) + (if leap-second? (+ seconds 1) seconds) + minutes + hours + date + month + year + offset)))))) + +;; this is the same as time-tai->date. +(define (time-monotonic->date time . tz-offset) + (if (not (eq? (time-type time) time-monotonic)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (let* ((offset (if (null? tz-offset) + (priv:local-tz-offset (time-monotonic->time-utc time)) + (car tz-offset))) + (seconds (- (time-second time) + (priv:leap-second-delta (time-second time)))) + (leap-second? (priv:leap-second? (+ offset seconds))) + (jdn (priv:time->julian-day-number (if leap-second? + (- seconds 1) + seconds) + offset))) + (call-with-values (lambda () (priv:decode-julian-day-number jdn)) + (lambda (secs date month year) + ;; secs is a real because jdn is a real in Guile; + ;; but it is conceptionally an integer. + ;; adjust for leap seconds if necessary ... + (let* ((int-secs (inexact->exact (round secs))) + (hours (quotient int-secs (* 60 60))) + (rem (remainder int-secs (* 60 60))) + (minutes (quotient rem 60)) + (seconds (remainder rem 60))) + (make-date (time-nanosecond time) + (if leap-second? (+ seconds 1) seconds) + minutes + hours + date + month + year + offset)))))) + +(define (date->time-utc date) + (let* ((jdays (- (priv:encode-julian-day-number (date-day date) + (date-month date) + (date-year date)) + priv:tai-epoch-in-jd)) + ;; jdays is an integer plus 1/2, + (jdays-1/2 (inexact->exact (- jdays 1/2)))) + (make-time + time-utc + (date-nanosecond date) + (+ (* jdays-1/2 24 60 60) + (* (date-hour date) 60 60) + (* (date-minute date) 60) + (date-second date) + (- (date-zone-offset date)))))) + +(define (date->time-tai date) + (time-utc->time-tai! (date->time-utc date))) + +(define (date->time-monotonic date) + (time-utc->time-monotonic! (date->time-utc date))) + +(define (priv:leap-year? year) + (or (= (modulo year 400) 0) + (and (= (modulo year 4) 0) (not (= (modulo year 100) 0))))) + +(define (leap-year? date) + (priv:leap-year? (date-year date))) + +;; Map 1-based month number M to number of days in the year before the +;; start of month M (in a non-leap year). +(define priv:month-assoc '((1 . 0) (2 . 31) (3 . 59) (4 . 90) + (5 . 120) (6 . 151) (7 . 181) (8 . 212) + (9 . 243) (10 . 273) (11 . 304) (12 . 334))) + +(define (priv:year-day day month year) + (let ((days-pr (assoc month priv:month-assoc))) + (if (not days-pr) + (priv:error 'date-year-day 'invalid-month-specification month)) + (if (and (priv:leap-year? year) (> month 2)) + (+ day (cdr days-pr) 1) + (+ day (cdr days-pr))))) + +(define (date-year-day date) + (priv:year-day (date-day date) (date-month date) (date-year date))) + +;; from calendar faq +(define (priv:week-day day month year) + (let* ((a (quotient (- 14 month) 12)) + (y (- year a)) + (m (+ month (* 12 a) -2))) + (modulo (+ day + y + (quotient y 4) + (- (quotient y 100)) + (quotient y 400) + (quotient (* 31 m) 12)) + 7))) + +(define (date-week-day date) + (priv:week-day (date-day date) (date-month date) (date-year date))) + +(define (priv:days-before-first-week date day-of-week-starting-week) + (let* ((first-day (make-date 0 0 0 0 + 1 + 1 + (date-year date) + #f)) + (fdweek-day (date-week-day first-day))) + (modulo (- day-of-week-starting-week fdweek-day) + 7))) + +;; The "-1" here is a fix for the reference implementation, to make a new +;; week start on the given day-of-week-starting-week. date-year-day returns +;; a day starting from 1 for 1st Jan. +;; +(define (date-week-number date day-of-week-starting-week) + (quotient (- (date-year-day date) + 1 + (priv:days-before-first-week date day-of-week-starting-week)) + 7)) + +(define (current-date . tz-offset) + (let ((time (current-time time-utc))) + (time-utc->date + time + (if (null? tz-offset) + (priv:local-tz-offset time) + (car tz-offset))))) + +;; given a 'two digit' number, find the year within 50 years +/- +(define (priv:natural-year n) + (let* ((current-year (date-year (current-date))) + (current-century (* (quotient current-year 100) 100))) + (cond + ((>= n 100) n) + ((< n 0) n) + ((<= (- (+ current-century n) current-year) 50) (+ current-century n)) + (else (+ (- current-century 100) n))))) + +(define (date->julian-day date) + (let ((nanosecond (date-nanosecond date)) + (second (date-second date)) + (minute (date-minute date)) + (hour (date-hour date)) + (day (date-day date)) + (month (date-month date)) + (year (date-year date)) + (offset (date-zone-offset date))) + (+ (priv:encode-julian-day-number day month year) + (- 1/2) + (+ (/ (+ (- offset) + (* hour 60 60) + (* minute 60) + second + (/ nanosecond priv:nano)) + priv:sid))))) + +(define (date->modified-julian-day date) + (- (date->julian-day date) + 4800001/2)) + +(define (time-utc->julian-day time) + (if (not (eq? (time-type time) time-utc)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (+ (/ (+ (time-second time) (/ (time-nanosecond time) priv:nano)) + priv:sid) + priv:tai-epoch-in-jd)) + +(define (time-utc->modified-julian-day time) + (- (time-utc->julian-day time) + 4800001/2)) + +(define (time-tai->julian-day time) + (if (not (eq? (time-type time) time-tai)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (+ (/ (+ (- (time-second time) + (priv:leap-second-delta (time-second time))) + (/ (time-nanosecond time) priv:nano)) + priv:sid) + priv:tai-epoch-in-jd)) + +(define (time-tai->modified-julian-day time) + (- (time-tai->julian-day time) + 4800001/2)) + +;; this is the same as time-tai->julian-day +(define (time-monotonic->julian-day time) + (if (not (eq? (time-type time) time-monotonic)) + (priv:time-error 'time->date 'incompatible-time-types time)) + (+ (/ (+ (- (time-second time) + (priv:leap-second-delta (time-second time))) + (/ (time-nanosecond time) priv:nano)) + priv:sid) + priv:tai-epoch-in-jd)) + +(define (time-monotonic->modified-julian-day time) + (- (time-monotonic->julian-day time) + 4800001/2)) + +(define (julian-day->time-utc jdn) + (let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd)))) + (receive (seconds parts) + (priv:split-real secs) + (make-time time-utc + (* parts priv:nano) + seconds)))) + +(define (julian-day->time-tai jdn) + (time-utc->time-tai! (julian-day->time-utc jdn))) + +(define (julian-day->time-monotonic jdn) + (time-utc->time-monotonic! (julian-day->time-utc jdn))) + +(define (julian-day->date jdn . tz-offset) + (let* ((time (julian-day->time-utc jdn)) + (offset (if (null? tz-offset) + (priv:local-tz-offset time) + (car tz-offset)))) + (time-utc->date time offset))) + +(define (modified-julian-day->date jdn . tz-offset) + (apply julian-day->date (+ jdn 4800001/2) + tz-offset)) + +(define (modified-julian-day->time-utc jdn) + (julian-day->time-utc (+ jdn 4800001/2))) + +(define (modified-julian-day->time-tai jdn) + (julian-day->time-tai (+ jdn 4800001/2))) + +(define (modified-julian-day->time-monotonic jdn) + (julian-day->time-monotonic (+ jdn 4800001/2))) + +(define (current-julian-day) + (time-utc->julian-day (current-time time-utc))) + +(define (current-modified-julian-day) + (time-utc->modified-julian-day (current-time time-utc))) + +;; returns a string rep. of number N, of minimum LENGTH, padded with +;; character PAD-WITH. If PAD-WITH is #f, no padding is done, and it's +;; as if number->string was used. if string is longer than or equal +;; in length to LENGTH, it's as if number->string was used. + +(define (priv:padding n pad-with length) + (let* ((str (number->string n)) + (str-len (string-length str))) + (if (or (>= str-len length) + (not pad-with)) + str + (string-append (make-string (- length str-len) pad-with) str)))) + +(define (priv:last-n-digits i n) + (abs (remainder i (expt 10 n)))) + +(define (priv:locale-abbr-weekday n) (locale-day-short (+ 1 n))) +(define (priv:locale-long-weekday n) (locale-day (+ 1 n))) +(define priv:locale-abbr-month locale-month-short) +(define priv:locale-long-month locale-month) + +(define (priv:date-reverse-lookup needle haystack-ref haystack-len + same?) + ;; Lookup NEEDLE (a string) using HAYSTACK-REF (a one argument procedure + ;; that returns a string corresponding to the given index) by passing it + ;; indices lower than HAYSTACK-LEN. + (let loop ((index 1)) + (cond ((> index haystack-len) #f) + ((same? needle (haystack-ref index)) + index) + (else (loop (+ index 1)))))) + +(define (priv:locale-abbr-weekday->index string) + (priv:date-reverse-lookup string 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 <rlb@defaultvalue.org> + +(define-module (srfi srfi-31) + :export-syntax (rec)) + +(define-macro (rec arg-form . body) + (cond + ((and (symbol? arg-form) (= 1 (length body))) + ;; (rec S (cons 1 (delay S))) + `(letrec ((,arg-form ,(car body))) + ,arg-form)) + ;; (rec (f x) (+ x 1)) + ((list? arg-form) + `(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body))) + ,(car arg-form))) + (else + (error "syntax error in rec form" `(rec ,arg-form ,@body))))) diff --git a/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 <neil@ossau.uklinux.net> + +;;; Commentary: + +;; This is an implementation of SRFI-34: Exception Handling for +;; Programs. For documentation please see the SRFI-34 document; this +;; module is not yet documented at all in the Guile manual. + +;;; Code: + +(define-module (srfi srfi-34) + #:export (with-exception-handler + raise) + #:export-syntax (guard)) + +(cond-expand-provide (current-module) '(srfi-34)) + +(define throw-key 'srfi-34) + +(define (with-exception-handler handler thunk) + "Returns the result(s) of invoking THUNK. HANDLER must be a +procedure that accepts one argument. It is installed as the current +exception handler for the dynamic extent (as determined by +dynamic-wind) of the invocation of THUNK." + (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 (<var> <clause1> <clause2> ...) <body>) +Each <clause> should have the same form as a `cond' clause. + +Semantics: Evaluating a guard form evaluates <body> with an exception +handler that binds the raised object to <var> and within the scope of +that binding evaluates the clauses as if they were the clauses of a +cond expression. That implicit cond expression is evaluated with the +continuation and dynamic environment of the guard expression. If +every <clause>'s <test> evaluates to false and there is no else +clause, then raise is re-invoked on the raised object within the +dynamic environment of the original call to raise except that the +current exception handler is that of the guard expression." + (let ((var (car var+clauses)) + (clauses (cdr var+clauses))) + `(catch ',throw-key + (lambda () + ,@body) + (lambda (key ,var) + (cond ,@(if (eq? (caar (last-pair clauses)) 'else) + clauses + (append clauses + `((else (throw key ,var)))))))))) + +;;; (srfi srfi-34) ends here. diff --git a/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 <ludo@gnu.org> + +;;; Commentary: + +;; This is an implementation of SRFI-35, "Conditions". Conditions are a +;; means to convey information about exceptional conditions between parts of +;; a program. + +;;; Code: + +(define-module (srfi srfi-35) + #:use-module (srfi srfi-1) + #:export (make-condition-type condition-type? + make-condition condition? condition-has-type? condition-ref + make-compound-condition extract-condition + define-condition-type condition + &condition + &message message-condition? condition-message + &serious serious-condition? + &error error?)) + +(cond-expand-provide (current-module) '(srfi-35)) + + +;;; +;;; Condition types. +;;; + +(define %condition-type-vtable + ;; The vtable of all condition types. + ;; vtable fields: vtable, self, printer + ;; user fields: id, parent, all-field-names + (make-vtable-vtable "prprpr" 0 + (lambda (ct port) + (if (eq? ct %condition-type-vtable) + (display "#<condition-type-vtable>") + (format port "#<condition-type ~a ~a>" + (condition-type-id ct) + (number->string (object-address ct) + 16)))))) + +(define (condition-type? obj) + "Return true if OBJ is a condition type." + (and (struct? obj) + (eq? (struct-vtable obj) + %condition-type-vtable))) + +(define (condition-type-id ct) + (and (condition-type? ct) + (struct-ref ct 3))) + +(define (condition-type-parent ct) + (and (condition-type? ct) + (struct-ref ct 4))) + +(define (condition-type-all-fields ct) + (and (condition-type? ct) + (struct-ref ct 5))) + + +(define (struct-layout-for-condition field-names) + ;; Return a string denoting the layout required to hold the fields listed + ;; in FIELD-NAMES. + (let loop ((field-names field-names) + (layout '("pr"))) + (if (null? field-names) + (string-concatenate/shared layout) + (loop (cdr field-names) + (cons "pr" layout))))) + +(define (print-condition c port) + (format port "#<condition ~a ~a>" + (condition-type-id (condition-type c)) + (number->string (object-address c) 16))) + +(define (make-condition-type id parent field-names) + "Return a new condition type named ID, inheriting from PARENT, and with the +fields whose names are listed in FIELD-NAMES. FIELD-NAMES must be a list of +symbols and must not contain names already used by PARENT or one of its +supertypes." + (if (symbol? id) + (if (condition-type? parent) + (let ((parent-fields (condition-type-all-fields parent))) + (if (and (every symbol? field-names) + (null? (lset-intersection eq? + field-names parent-fields))) + (let* ((all-fields (append parent-fields field-names)) + (layout (struct-layout-for-condition all-fields))) + (make-struct %condition-type-vtable 0 + (make-struct-layout layout) ;; layout + print-condition ;; printer + id parent all-fields)) + (error "invalid condition type field names" + field-names))) + (error "parent is not a condition type" parent)) + (error "condition type identifier is not a symbol" id))) + +(define (make-compound-condition-type id parents) + ;; Return a compound condition type made of the types listed in PARENTS. + ;; All fields from PARENTS are kept, even same-named ones, since they are + ;; needed by `extract-condition'. + (cond ((null? parents) + (error "`make-compound-condition-type' passed empty parent list" + id)) + ((null? (cdr parents)) + (car parents)) + (else + (let* ((all-fields (append-map condition-type-all-fields + parents)) + (layout (struct-layout-for-condition all-fields))) + (make-struct %condition-type-vtable 0 + (make-struct-layout layout) ;; layout + print-condition ;; printer + id + parents ;; list of parents! + all-fields + all-fields))))) + + +;;; +;;; Conditions. +;;; + +(define (condition? c) + "Return true if C is a condition." + (and (struct? c) + (condition-type? (struct-vtable c)))) + +(define (condition-type c) + (and (struct? c) + (let ((vtable (struct-vtable c))) + (if (condition-type? vtable) + vtable + #f)))) + +(define (condition-has-type? c type) + "Return true if condition C has type TYPE." + (if (and (condition? c) (condition-type? type)) + (let loop ((ct (condition-type c))) + (or (eq? ct type) + (and ct + (let ((parent (condition-type-parent ct))) + (if (list? parent) + (any loop parent) ;; compound condition + (loop (condition-type-parent ct))))))) + (throw 'wrong-type-arg "condition-has-type?" + "Wrong type argument"))) + +(define (condition-ref c field-name) + "Return the value of the field named FIELD-NAME from condition C." + (if (condition? c) + (if (symbol? field-name) + (let* ((type (condition-type c)) + (fields (condition-type-all-fields type)) + (index (list-index (lambda (name) + (eq? name field-name)) + fields))) + (if index + (struct-ref c index) + (error "invalid field name" field-name))) + (error "field name is not a symbol" field-name)) + (throw 'wrong-type-arg "condition-ref" + "Wrong type argument: ~S" c))) + +(define (make-condition-from-values type values) + (apply make-struct type 0 values)) + +(define (make-condition type . field+value) + "Return a new condition of type TYPE with fields initialized as specified +by FIELD+VALUE, a sequence of field names (symbols) and values." + (if (condition-type? type) + (let* ((all-fields (condition-type-all-fields type)) + (inits (fold-right (lambda (field inits) + (let ((v (memq field field+value))) + (if (pair? v) + (cons (cadr v) inits) + (error "field not specified" + field)))) + '() + all-fields))) + (make-condition-from-values type inits)) + (throw 'wrong-type-arg "make-condition" + "Wrong type argument: ~S" type))) + +(define (make-compound-condition . conditions) + "Return a new compound condition composed of CONDITIONS." + (let* ((types (map condition-type conditions)) + (ct (make-compound-condition-type 'compound types)) + (inits (append-map (lambda (c) + (let ((ct (condition-type c))) + (map (lambda (f) + (condition-ref c f)) + (condition-type-all-fields ct)))) + conditions))) + (make-condition-from-values ct inits))) + +(define (extract-condition c type) + "Return a condition of condition type TYPE with the field values specified +by C." + + (define (first-field-index parents) + ;; Return the index of the first field of TYPE within C. + (let loop ((parents parents) + (index 0)) + (let ((parent (car parents))) + (cond ((null? parents) + #f) + ((eq? parent type) + index) + ((pair? parent) + (or (loop parent index) + (loop (cdr parents) + (+ index + (apply + (map condition-type-all-fields + parent)))))) + (else + (let ((shift (length (condition-type-all-fields parent)))) + (loop (cdr parents) + (+ index shift)))))))) + + (define (list-fields start-index field-names) + ;; Return a list of the form `(FIELD-NAME VALUE...)'. + (let loop ((index start-index) + (field-names field-names) + (result '())) + (if (null? field-names) + (reverse! result) + (loop (+ 1 index) + (cdr field-names) + (cons* (struct-ref c index) + (car field-names) + result))))) + + (if (and (condition? c) (condition-type? type)) + (let* ((ct (condition-type c)) + (parent (condition-type-parent ct))) + (cond ((eq? type ct) + c) + ((pair? parent) + ;; C is a compound condition. + (let ((field-index (first-field-index parent))) + ;;(format #t "field-index: ~a ~a~%" field-index + ;; (list-fields field-index + ;; (condition-type-all-fields type))) + (apply make-condition type + (list-fields field-index + (condition-type-all-fields type))))) + (else + ;; C does not have type TYPE. + #f))) + (throw 'wrong-type-arg "extract-condition" + "Wrong type argument"))) + + +;;; +;;; Syntax. +;;; + +(define-macro (define-condition-type name parent pred . field-specs) + `(begin + (define ,name + (make-condition-type ',name ,parent + ',(map car field-specs))) + (define (,pred c) + (condition-has-type? c ,name)) + ,@(map (lambda (field-spec) + (let ((field-name (car field-spec)) + (accessor (cadr field-spec))) + `(define (,accessor c) + (condition-ref c ',field-name)))) + field-specs))) + +(define-macro (condition . type-field-bindings) + (cond ((null? type-field-bindings) + (error "`condition' syntax error" type-field-bindings)) + (else + ;; the poor man's hygienic macro + (let ((mc (gensym "mc")) + (mcct (gensym "mcct"))) + `(let ((,mc (@ (srfi srfi-35) make-condition)) + (,mcct (@@ (srfi srfi-35) make-compound-condition-type))) + (,mc (,mcct 'compound (list ,@(map car type-field-bindings))) + ,@(append-map (lambda (type-field-binding) + (append-map (lambda (field+value) + (let ((f (car field+value)) + (v (cadr field+value))) + `(',f ,v))) + (cdr type-field-binding))) + type-field-bindings))))))) + + +;;; +;;; Standard condition types. +;;; + +(define &condition + ;; The root condition type. + (make-struct %condition-type-vtable 0 + (make-struct-layout "") + (lambda (c port) + (display "<&condition>")) + '&condition #f '() '())) + +(define-condition-type &message &condition + message-condition? + (message condition-message)) + +(define-condition-type &serious &condition + serious-condition?) + +(define-condition-type &error &serious + error?) + + +;;; Local Variables: +;;; coding: latin-1 +;;; End: + +;;; srfi-35.scm ends here diff --git a/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 <jao@gnu.org> +;;; Date: 2004-05-05 + +;;; Commentary: + +;; This is an implementation of SRFI-39 (Parameter objects). +;; +;; The implementation is based on Guile's fluid objects, and is, therefore, +;; thread-safe (parameters are thread-local). +;; +;; In addition to the forms defined in SRFI-39 (`make-parameter', +;; `parameterize'), a new procedure `with-parameters*' is provided. +;; This procedures is analogous to `with-fluids*' but taking as first +;; argument a list of parameter objects instead of a list of fluids. +;; + +;;; Code: + +(define-module (srfi srfi-39) + #:use-module (ice-9 syncase) + #:use-module (srfi srfi-16) + + #:export (make-parameter) + #:export-syntax (parameterize) + + ;; helper procedure not in srfi-39. + #:export (with-parameters*) + #:replace (current-input-port current-output-port current-error-port)) + +;; Make 'srfi-39 available as a feature identifiere to `cond-expand'. +;; +(cond-expand-provide (current-module) '(srfi-39)) + +(define make-parameter + (case-lambda + ((val) (make-parameter/helper val (lambda (x) x))) + ((val conv) (make-parameter/helper val conv)))) + +(define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value +(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value + +(define (make-parameter/helper val conv) + (let ((value (make-fluid)) + (conv conv)) + (begin + (fluid-set! value (conv val)) + (lambda new-value + (cond + ((null? new-value) (fluid-ref value)) + ((eq? (car new-value) get-fluid-tag) value) + ((eq? (car new-value) get-conv-tag) conv) + ((null? (cdr new-value)) (fluid-set! value (conv (car new-value)))) + (else (error "make-parameter expects 0 or 1 arguments" new-value))))))) + +(define-syntax parameterize + (syntax-rules () + ((_ ((?param ?value) ...) ?body ...) + (with-parameters* (list ?param ...) + (list ?value ...) + (lambda () ?body ...))))) + +(define (current-input-port . new-value) + (if (null? new-value) + ((@ (guile) current-input-port)) + (apply set-current-input-port new-value))) + +(define (current-output-port . new-value) + (if (null? new-value) + ((@ (guile) current-output-port)) + (apply set-current-output-port new-value))) + +(define (current-error-port . new-value) + (if (null? new-value) + ((@ (guile) current-error-port)) + (apply set-current-error-port new-value))) + +(define port-list + (list current-input-port current-output-port current-error-port)) + +;; There are no fluids behind current-input-port etc, so those parameter +;; objects are picked out of the list and handled separately with a +;; dynamic-wind to swap their values to and from a location (the "value" +;; variable in the swapper procedure "let"). +;; +;; current-input-port etc are already per-dynamic-root, so this arrangement +;; works the same as a fluid. Perhaps they could become fluids for ease of +;; implementation here. +;; +;; Notice the use of a param local variable for the swapper procedure. It +;; ensures any application changes to the PARAMS list won't affect the +;; winding. +;; +(define (with-parameters* params values thunk) + (let more ((params params) + (values values) + (fluids '()) ;; fluids from each of PARAMS + (convs '()) ;; VALUES with conversion proc applied + (swapper noop)) ;; wind/unwind procedure for ports handling + (if (null? params) + (if (eq? noop swapper) + (with-fluids* fluids convs thunk) + (dynamic-wind + swapper + (lambda () + (with-fluids* fluids convs thunk)) + swapper)) + (if (memq (car params) port-list) + (more (cdr params) (cdr values) + fluids convs + (let ((param (car params)) + (value (car values)) + (prev-swapper swapper)) + (lambda () + (set! value (param value)) + (prev-swapper)))) + (more (cdr params) (cdr values) + (cons ((car params) get-fluid-tag) fluids) + (cons (((car params) get-conv-tag) (car values)) convs) + swapper))))) diff --git a/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 <mgrabmue@cs.tu-berlin.de> + +;;; Commentary: + +;; This module exports the homogeneous numeric vector procedures as +;; defined in SRFI-4. They are fully documented in the Guile +;; Reference Manual. + +;;; Code: + +(define-module (srfi srfi-4)) + +(re-export +;;; Unsigned 8-bit vectors. + u8vector? make-u8vector u8vector u8vector-length u8vector-ref + u8vector-set! u8vector->list list->u8vector + +;;; Signed 8-bit vectors. + s8vector? make-s8vector s8vector s8vector-length s8vector-ref + s8vector-set! s8vector->list list->s8vector + +;;; Unsigned 16-bit vectors. + u16vector? make-u16vector u16vector u16vector-length u16vector-ref + u16vector-set! u16vector->list list->u16vector + +;;; Signed 16-bit vectors. + s16vector? make-s16vector s16vector s16vector-length s16vector-ref + s16vector-set! s16vector->list list->s16vector + +;;; Unsigned 32-bit vectors. + u32vector? make-u32vector u32vector u32vector-length u32vector-ref + u32vector-set! u32vector->list list->u32vector + +;;; Signed 32-bit vectors. + s32vector? make-s32vector s32vector s32vector-length s32vector-ref + s32vector-set! s32vector->list list->s32vector + +;;; Unsigned 64-bit vectors. + u64vector? make-u64vector u64vector u64vector-length u64vector-ref + u64vector-set! u64vector->list list->u64vector + +;;; Signed 64-bit vectors. + s64vector? make-s64vector s64vector s64vector-length s64vector-ref + s64vector-set! s64vector->list list->s64vector + +;;; 32-bit floating point vectors. + f32vector? make-f32vector f32vector f32vector-length f32vector-ref + f32vector-set! f32vector->list list->f32vector + +;;; 64-bit floating point vectors. + f64vector? make-f64vector f64vector f64vector-length f64vector-ref + f64vector-set! f64vector->list list->f64vector + ) diff --git a/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 #<primitive-procedure hash> +;; +;; I don't think that SRFI 69 actually specifies that I *can't* do this, +;; because it only implies the signature of a hash function by way of the +;; named, exported hash functions. However, if this matters enough I can +;; add a private derivation of hash-function to the srfi-69:hash-table +;; record type, like associator is to equivalence-function. +;; +;; Also, outside of the issue of how weak keys and values are referenced +;; outside the table, I always interpret key equivalence to be that of +;; the `hash-table-equivalence-function'. For example, given the +;; requirement that `alist->hash-table' give earlier associations +;; priority, what should these answer? +;; +;; (hash-table-keys +;; (alist->hash-table '(("xY" . 1) ("Xy" . 2)) string-ci=?)) +;; +;; (let ((ht (make-hash-table string-ci=?))) +;; (hash-table-set! ht "xY" 2) +;; (hash-table-set! ht "Xy" 1) +;; (hash-table-keys ht)) +;; +;; My interpretation is that they can answer either ("Xy") or ("xY"), +;; where `hash-table-values' will of course always answer (1), because +;; the keys are the same according to the equivalence function. In this +;; implementation, both answer ("xY"). However, I don't guarantee that +;; this won't change in the future. + +;;; Code: + +;;;; Module definition & exports + +(define-module (srfi srfi-69) + #:use-module (srfi srfi-1) ;alist-cons,second&c,assoc + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-13) ;string-hash,string-hash-ci + #:use-module (ice-9 optargs) + #:export (;; Type constructors & predicate + make-hash-table hash-table? alist->hash-table + ;; Reflective queries + hash-table-equivalence-function hash-table-hash-function + ;; Dealing with single elements + hash-table-ref hash-table-ref/default hash-table-set! + hash-table-delete! hash-table-exists? hash-table-update! + hash-table-update!/default + ;; Dealing with the whole contents + hash-table-size hash-table-keys hash-table-values + hash-table-walk hash-table-fold hash-table->alist + hash-table-copy hash-table-merge! + ;; Hashing + string-ci-hash hash-by-identity) + #:re-export (string-hash) + #:replace (hash)) + +(cond-expand-provide (current-module) '(srfi-37)) + +;;;; Hashing + +;;; The largest fixnum is in `most-positive-fixnum' in module (guile), +;;; though not documented anywhere but libguile/numbers.c. + +(define (caller-with-default-size hash-fn) + "Answer a function that makes `most-positive-fixnum' the default +second argument to HASH-FN, a 2-arg procedure." + (lambda* (obj #:optional (size most-positive-fixnum)) + (hash-fn obj size))) + +(define hash (caller-with-default-size (@ (guile) hash))) + +(define string-ci-hash string-hash-ci) + +(define hash-by-identity (caller-with-default-size hashq)) + +;;;; Reflective queries, construction, predicate + +(define-record-type srfi-69:hash-table + (make-srfi-69-hash-table real-table associator size weakness + equivalence-function hash-function) + hash-table? + (real-table ht-real-table) + (associator ht-associator) + ;; required for O(1) by SRFI-69. It really makes a mess of things, + ;; and I'd like to compute it in O(n) and memoize it because it + ;; doesn't seem terribly useful, but SRFI-69 is final. + (size ht-size ht-size!) + ;; required for `hash-table-copy' + (weakness ht-weakness) + ;; used only to implement hash-table-equivalence-function; I don't + ;; use it internally other than for `ht-associator'. + (equivalence-function hash-table-equivalence-function) + (hash-function hash-table-hash-function)) + +(define (guess-hash-function equal-proc) + "Guess a hash function for EQUAL-PROC, falling back on `hash', as +specified in SRFI-69 for `make-hash-table'." + (cond ((eq? equal? equal-proc) (@ (guile) hash)) ;shortcut most common case + ((eq? eq? equal-proc) hashq) + ((eq? eqv? equal-proc) hashv) + ((eq? string=? equal-proc) string-hash) + ((eq? string-ci=? equal-proc) string-ci-hash) + (else (@ (guile) hash)))) + +(define (without-keyword-args rest-list) + "Answer REST-LIST with all keywords removed along with items that +follow them." + (let lp ((acc '()) (rest-list rest-list)) + (cond ((null? rest-list) (reverse! acc)) + ((keyword? (first rest-list)) + (lp acc (cddr rest-list))) + (else (lp (cons (first rest-list) acc) (cdr rest-list)))))) + +(define (guile-ht-ctor weakness) + "Answer the Guile HT constructor for the given WEAKNESS." + (case weakness + ((#f) (@ (guile) make-hash-table)) + ((key) make-weak-key-hash-table) + ((value) make-weak-value-hash-table) + ((key-or-value) make-doubly-weak-hash-table) + (else (error "Invalid weak hash table type" weakness)))) + +(define (equivalence-proc->associator equal-proc) + "Answer an `assoc'-like procedure that compares the argument key to +alist keys with EQUAL-PROC." + (cond ((or (eq? equal? equal-proc) + (eq? string=? equal-proc)) (@ (guile) assoc)) + ((eq? eq? equal-proc) assq) + ((eq? eqv? equal-proc) assv) + (else (lambda (item alist) + (assoc item alist equal-proc))))) + +(define* (make-hash-table + #:optional (equal-proc equal?) + (hash-proc (guess-hash-function equal-proc)) + #:key (weak #f) #:rest guile-opts) + "Answer a new hash table using EQUAL-PROC as the comparison +function, and HASH-PROC as the hash function. See the reference +manual for specifics, of which there are many." + (make-srfi-69-hash-table + (apply (guile-ht-ctor weak) (without-keyword-args guile-opts)) + (equivalence-proc->associator equal-proc) + 0 weak equal-proc hash-proc)) + +(define (alist->hash-table alist . mht-args) + "Convert ALIST to a hash table created with MHT-ARGS." + (let* ((result (apply make-hash-table mht-args)) + (size (ht-size result))) + (with-hashx-values (hash-proc associator real-table) result + (for-each (lambda (pair) + (let ((handle (hashx-get-handle hash-proc associator + real-table (car pair)))) + (cond ((not handle) + (set! size (1+ size)) + (hashx-set! hash-proc associator real-table + (car pair) (cdr pair)))))) + alist)) + (ht-size! result size) + result)) + +;;;; Accessing table items + +;; We use this to denote missing or unspecified values to avoid +;; possible collision with *unspecified*. +(define ht-unspecified (cons *unspecified* "ht-value")) + +;; I am a macro only for efficiency, to avoid varargs/apply. +(define-macro (hashx-invoke hashx-proc ht-var . args) + "Invoke HASHX-PROC, a `hashx-*' procedure taking a hash-function, +assoc-function, and the hash-table as first args." + `(,hashx-proc (hash-table-hash-function ,ht-var) + (ht-associator ,ht-var) + (ht-real-table ,ht-var) + . ,args)) + +(define-macro (with-hashx-values bindings ht-var . body-forms) + "Bind BINDINGS to the hash-function, associator, and real-table of +HT-VAR, while evaluating BODY-FORMS." + `(let ((,(first bindings) (hash-table-hash-function ,ht-var)) + (,(second bindings) (ht-associator ,ht-var)) + (,(third bindings) (ht-real-table ,ht-var))) + . ,body-forms)) + +(define (hash-table-ref ht key . default-thunk-lst) + "Lookup KEY in HT and answer the value, invoke DEFAULT-THUNK if KEY +isn't present, or signal an error if DEFAULT-THUNK isn't provided." + (let ((result (hashx-invoke hashx-ref ht key ht-unspecified))) + (if (eq? ht-unspecified result) + (if (pair? default-thunk-lst) + ((first default-thunk-lst)) + (error "Key not in table" key ht)) + result))) + +(define (hash-table-ref/default ht key default) + "Lookup KEY in HT and answer the value. Answer DEFAULT if KEY isn't +present." + (hashx-invoke hashx-ref ht key default)) + +(define (hash-table-set! ht key new-value) + "Set KEY to NEW-VALUE in HT." + (let ((handle (hashx-invoke hashx-create-handle! ht key ht-unspecified))) + (if (eq? ht-unspecified (cdr handle)) + (ht-size! ht (1+ (ht-size ht)))) + (set-cdr! handle new-value)) + *unspecified*) + +(define (hash-table-delete! ht key) + "Remove KEY's association in HT." + (with-hashx-values (h a real-ht) ht + (if (hashx-get-handle h a real-ht key) + (begin + (ht-size! ht (1- (ht-size ht))) + (hashx-remove! h a real-ht key)))) + *unspecified*) + +(define (hash-table-exists? ht key) + "Return whether KEY is a key in HT." + (and (hashx-invoke hashx-get-handle ht key) #t)) + +;;; `hashx-set!' duplicates the hash lookup, but we use it anyway to +;;; avoid creating a handle in case DEFAULT-THUNK exits +;;; `hash-table-update!' non-locally. +(define (hash-table-update! ht key modifier . default-thunk-lst) + "Modify HT's value at KEY by passing its value to MODIFIER and +setting it to the result thereof. Invoke DEFAULT-THUNK for the old +value if KEY isn't in HT, or signal an error if DEFAULT-THUNK is not +provided." + (with-hashx-values (hash-proc associator real-table) ht + (let ((handle (hashx-get-handle hash-proc associator real-table key))) + (cond (handle + (set-cdr! handle (modifier (cdr handle)))) + (else + (hashx-set! hash-proc associator real-table key + (if (pair? default-thunk-lst) + (modifier ((car default-thunk-lst))) + (error "Key not in table" key ht))) + (ht-size! ht (1+ (ht-size ht))))))) + *unspecified*) + +(define (hash-table-update!/default ht key modifier default) + "Modify HT's value at KEY by passing its old value, or DEFAULT if it +doesn't have one, to MODIFIER, and setting it to the result thereof." + (hash-table-update! ht key modifier (lambda () default))) + +;;;; Accessing whole tables + +(define (hash-table-size ht) + "Return the number of associations in HT. This is guaranteed O(1) +for tables where #:weak was #f or not specified at creation time." + (if (ht-weakness ht) + (hash-table-fold ht (lambda (k v ans) (1+ ans)) 0) + (ht-size ht))) + +(define (hash-table-keys ht) + "Return a list of the keys in HT." + (hash-table-fold ht (lambda (k v lst) (cons k lst)) '())) + +(define (hash-table-values ht) + "Return a list of the values in HT." + (hash-table-fold ht (lambda (k v lst) (cons v lst)) '())) + +(define (hash-table-walk ht proc) + "Call PROC with each key and value as two arguments." + (hash-table-fold ht (lambda (k v unspec) (proc k v) unspec) + *unspecified*)) + +(define (hash-table-fold ht f knil) + "Invoke (F KEY VAL PREV) for each KEY and VAL in HT, where PREV is +the result of the previous invocation, using KNIL as the first PREV. +Answer the final F result." + (hash-fold f knil (ht-real-table ht))) + +(define (hash-table->alist ht) + "Return an alist for HT." + (hash-table-fold ht alist-cons '())) + +(define (hash-table-copy ht) + "Answer a copy of HT." + (with-hashx-values (h a real-ht) ht + (let* ((size (hash-table-size ht)) (weak (ht-weakness ht)) + (new-real-ht ((guile-ht-ctor weak) size))) + (hash-fold (lambda (k v ign) (hashx-set! h a new-real-ht k v)) + #f real-ht) + (make-srfi-69-hash-table ;real,assoc,size,weak,equiv,h + new-real-ht a size weak + (hash-table-equivalence-function ht) h)))) + +(define (hash-table-merge! ht other-ht) + "Add all key/value pairs from OTHER-HT to HT, overriding HT's +mappings where present. Return HT." + (hash-table-fold + ht (lambda (k v ign) (hash-table-set! ht k v)) #f) + ht) + +;;; srfi-69.scm ends here diff --git a/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 <ludo@gnu.org> + +;;; Commentary: + +;; This is a convenience module providing SRFI-88 "keyword object". All it +;; does is setup the right reader option and export keyword-related +;; convenience procedures. + +;;; Code: + +(define-module (srfi srfi-88) + #:re-export (keyword?) + #:export (keyword->string string->keyword)) + +(cond-expand-provide (current-module) '(srfi-88)) + + +(read-set! keywords 'postfix) + +(define (keyword->string k) + "Return the name of @var{k} as a string." + (symbol->string (keyword->symbol k))) + +(define (string->keyword s) + "Return the keyword object whose name is @var{s}." + (symbol->keyword (string->symbol s))) + +;;; Local Variables: +;;; coding: latin-1 +;;; End: + +;;; srfi-88.scm ends here diff --git a/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: +;; +;; <record type definition> +;; -> (define-record-type <type name> +;; (<constructor name> <field tag> ...) +;; <predicate name> +;; <field spec> ...) +;; +;; <field spec> -> (<field tag> <accessor name>) +;; -> (<field tag> <accessor name> <modifier name>) +;; +;; <field tag> -> <identifier> +;; <... name> -> <identifier> +;; +;; Usage example: +;; +;; guile> (use-modules (srfi srfi-9)) +;; guile> (define-record-type :foo (make-foo x) foo? +;; (x get-x) (y get-y set-y!)) +;; guile> (define f (make-foo 1)) +;; guile> f +;; #<:foo x: 1 y: #f> +;; guile> (get-x f) +;; 1 +;; guile> (set-y! f 2) +;; 2 +;; guile> (get-y f) +;; 2 +;; guile> f +;; #<:foo x: 1 y: 2> +;; guile> (foo? f) +;; #t +;; guile> (foo? 1) +;; #f + +;;; Code: + +(define-module (srfi srfi-9) + :export-syntax (define-record-type)) + +(cond-expand-provide (current-module) '(srfi-9)) + +(define-macro (define-record-type type-name constructor/field-tag + predicate-name . field-specs) + `(begin + (define ,type-name + (make-record-type ',type-name ',(map car field-specs))) + (define ,(car constructor/field-tag) + (record-constructor ,type-name ',(cdr constructor/field-tag))) + (define ,predicate-name + (record-predicate ,type-name)) + ,@(map + (lambda (spec) + (cond + ((= (length spec) 2) + `(define ,(cadr spec) + (record-accessor ,type-name ',(car spec)))) + ((= (length spec) 3) + `(begin + (define ,(cadr spec) + (record-accessor ,type-name ',(car spec))) + (define ,(caddr spec) + (record-modifier ,type-name ',(car spec))))) + (else + (error "invalid field spec " spec)))) + field-specs))) + +;;; srfi-9.scm ends here |