diff options
Diffstat (limited to 'module/srfi')
40 files changed, 11037 insertions, 0 deletions
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm new file mode 100644 index 000000000..0806e7363 --- /dev/null +++ b/module/srfi/srfi-1.scm @@ -0,0 +1,1061 @@ +;;; srfi-1.scm --- List Library + +;; Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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 + +;;; Some parts from the reference implementation, which is +;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with +;;; this code as long as you do not remove this copyright notice or +;;; hold me liable for its use. + +;;; 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 (string-append "libguile-" (effective-version)) + "scm_init_srfi_1") + + +;;; Constructors + +(define (xcons d a) + "Like `cons', but with interchanged arguments. Useful mostly when passed to +higher-order procedures." + (cons a d)) + +(define (wrong-type-arg caller arg) + (scm-error 'wrong-type-arg (symbol->string caller) + "Wrong type argument: ~S" (list arg) '())) + +(define-syntax-rule (check-arg pred arg caller) + (if (not (pred arg)) + (wrong-type-arg 'caller arg))) + +(define (out-of-range proc arg) + (scm-error 'out-of-range proc + "Value out of range: ~A" (list arg) (list arg))) + +;; the srfi spec doesn't seem to forbid inexact integers. +(define (non-negative-integer? x) (and (integer? x) (>= x 0))) + +(define (list-tabulate n init-proc) + "Return an N-element list, where each list element is produced by applying the +procedure INIT-PROC to the corresponding list index. The order in which +INIT-PROC is applied to the indices is not specified." + (check-arg non-negative-integer? n list-tabulate) + (let lp ((n n) (acc '())) + (if (<= n 0) + acc + (lp (- n 1) (cons (init-proc (- n 1)) acc))))) + +(define (circular-list elt1 . elts) + (set! elts (cons elt1 elts)) + (set-cdr! (last-pair elts) elts) + elts) + +(define* (iota count #:optional (start 0) (step 1)) + (check-arg non-negative-integer? count iota) + (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 (not-pair? x) + "Return #t if X is not a pair, #f otherwise. + +This is shorthand notation `(not (pair? X))' and is supposed to be used for +end-of-list checking in contexts where dotted lists are allowed." + (not (pair? x))) + +(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))))))) + + (check-arg procedure? elt= list=) + (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 (fifth x) (car (cddddr x))) +(define (sixth x) (cadr (cddddr x))) +(define (seventh x) (caddr (cddddr x))) +(define (eighth x) (cadddr (cddddr x))) +(define (ninth x) (car (cddddr (cddddr x)))) +(define (tenth x) (cadr (cddddr (cddddr x)))) + +(define (car+cdr x) + "Return two values, the `car' and the `cdr' of PAIR." + (values (car x) (cdr x))) + +(define take list-head) +(define drop list-tail) + +;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list, +;;; off by K, then chasing down the list until the lead pointer falls off +;;; the end. Note that they diverge for circular lists. + +(define (take-right lis k) + (let lp ((lag lis) (lead (drop lis k))) + (if (pair? lead) + (lp (cdr lag) (cdr lead)) + lag))) + +(define (drop-right lis k) + (let recur ((lag lis) (lead (drop lis k))) + (if (pair? lead) + (cons (car lag) (recur (cdr lag) (cdr lead))) + '()))) + +(define (take! lst i) + "Linear-update variant of `take'." + (if (= i 0) + '() + (let ((tail (drop lst (- i 1)))) + (set-cdr! tail '()) + lst))) + +(define (drop-right! lst i) + "Linear-update variant of `drop-right'." + (let ((tail (drop lst i))) + (if (null? tail) + '() + (let loop ((prev lst) + (tail (cdr tail))) + (if (null? tail) + (if (pair? prev) + (begin + (set-cdr! prev '()) + lst) + lst) + (loop (cdr prev) + (cdr tail))))))) + +(define (split-at lst i) + "Return two values, a list of the elements before index I in LST, and +a list of those after." + (if (< i 0) + (out-of-range 'split-at i) + (let lp ((l lst) (n i) (acc '())) + (if (<= n 0) + (values (reverse! acc) l) + (lp (cdr l) (- n 1) (cons (car l) acc)))))) + +(define (split-at! lst i) + "Linear-update variant of `split-at'." + (cond ((< i 0) + (out-of-range 'split-at! i)) + ((= i 0) + (values '() lst)) + (else + (let lp ((l lst) (n (- i 1))) + (if (<= n 0) + (let ((tmp (cdr l))) + (set-cdr! l '()) + (values lst tmp)) + (lp (cdr l) (- n 1))))))) + +(define (last pair) + "Return the last element of the non-empty, finite list PAIR." + (car (last-pair pair))) + +;;; 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 (map cdr l) (cons (map car l) acc))))) + + +(define (unzip1 l) + (map first l)) +(define (unzip2 l) + (values (map first l) (map second l))) +(define (unzip3 l) + (values (map first l) (map second l) (map third l))) +(define (unzip4 l) + (values (map first l) (map second l) (map third l) (map fourth l))) +(define (unzip5 l) + (values (map first l) (map second l) (map third l) (map fourth l) + (map fifth l))) + +;;; Fold, unfold & map + +(define fold + (case-lambda + "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return +that result. See the manual for details." + ((kons knil list1) + (check-arg procedure? kons fold) + (check-arg list? list1 fold) + (let fold1 ((knil knil) (list1 list1)) + (if (pair? list1) + (fold1 (kons (car list1) knil) (cdr list1)) + knil))) + ((kons knil list1 list2) + (check-arg procedure? kons fold) + (let* ((len1 (length+ list1)) + (len2 (length+ list2)) + (len (if (and len1 len2) + (min len1 len2) + (or len1 len2)))) + (unless len + (scm-error 'wrong-type-arg "fold" + "Args do not contain a proper (finite) list: ~S" + (list (list list1 list2)) #f)) + (let fold2 ((knil knil) (list1 list1) (list2 list2) (len len)) + (if (zero? len) + knil + (fold2 (kons (car list1) (car list2) knil) + (cdr list1) (cdr list2) (1- len)))))) + ((kons knil list1 . rest) + (check-arg procedure? kons fold) + (let foldn ((knil knil) (lists (cons list1 rest))) + (if (any null? lists) + knil + (let ((cars (map car lists)) + (cdrs (map cdr lists))) + (foldn (apply kons (append! cars (list knil))) cdrs))))))) + +(define (fold-right kons knil clist1 . rest) + (check-arg procedure? kons fold-right) + (if (null? rest) + (let loop ((lst (reverse clist1)) + (result knil)) + (if (null? lst) + result + (loop (cdr lst) + (kons (car lst) result)))) + (let loop ((lists (map reverse (cons clist1 rest))) + (result knil)) + (if (any1 null? lists) + result + (loop (map cdr lists) + (apply kons (append! (map car lists) (list result)))))))) + +(define (pair-fold kons knil clist1 . rest) + (check-arg procedure? kons pair-fold) + (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 (map cdr lists))) + (f (apply kons (append! lists (list knil))) tails)))))) + + +(define (pair-fold-right kons knil clist1 . rest) + (check-arg procedure? kons pair-fold-right) + (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 (map cdr lists))))))))) + +(define* (unfold p f g seed #:optional (tail-gen (lambda (x) '()))) + (define (reverse+tail lst seed) + (let loop ((lst lst) + (result (tail-gen seed))) + (if (null? lst) + result + (loop (cdr lst) + (cons (car lst) result))))) + + (check-arg procedure? p unfold) + (check-arg procedure? f unfold) + (check-arg procedure? g unfold) + (check-arg procedure? tail-gen unfold) + (let loop ((seed seed) + (result '())) + (if (p seed) + (reverse+tail result seed) + (loop (g seed) + (cons (f seed) result))))) + +(define* (unfold-right p f g seed #:optional (tail '())) + (check-arg procedure? p unfold-right) + (check-arg procedure? f unfold-right) + (check-arg procedure? g unfold-right) + (let uf ((seed seed) (lis tail)) + (if (p seed) + lis + (uf (g seed) (cons (f seed) lis))))) + +(define (reduce f ridentity lst) + "`reduce' is a variant of `fold', where the first call to F is on two +elements from LST, rather than one element and a given initial value. +If LST is empty, RIDENTITY is returned. If LST has just one element +then that's the return value." + (check-arg procedure? f reduce) + (if (null? lst) + ridentity + (fold f (car lst) (cdr lst)))) + +(define (reduce-right f ridentity lst) + "`reduce-right' is a variant of `fold-right', where the first call to +F is on two elements from LST, rather than one element and a given +initial value. If LST is empty, RIDENTITY is returned. If LST +has just one element then that's the return value." + (check-arg procedure? f reduce) + (if (null? lst) + ridentity + (fold-right f (last lst) (drop-right lst 1)))) + +(define map + (case-lambda + ((f l) + (check-arg procedure? f map) + (check-arg list? l map) + (let map1 ((l l)) + (if (pair? l) + (cons (f (car l)) (map1 (cdr l))) + '()))) + + ((f l1 l2) + (check-arg procedure? f map) + (let* ((len1 (length+ l1)) + (len2 (length+ l2)) + (len (if (and len1 len2) + (min len1 len2) + (or len1 len2)))) + (unless len + (scm-error 'wrong-type-arg "map" + "Args do not contain a proper (finite) list: ~S" + (list (list l1 l2)) #f)) + (let map2 ((l1 l1) (l2 l2) (len len)) + (if (zero? len) + '() + (cons (f (car l1) (car l2)) + (map2 (cdr l1) (cdr l2) (1- len))))))) + + ((f l1 . rest) + (check-arg procedure? f map) + (let ((len (fold (lambda (ls len) + (let ((ls-len (length+ ls))) + (if len + (if ls-len (min ls-len len) len) + ls-len))) + (length+ l1) + rest))) + (if (not len) + (scm-error 'wrong-type-arg "map" + "Args do not contain a proper (finite) list: ~S" + (list (cons l1 rest)) #f)) + (let mapn ((l1 l1) (rest rest) (len len)) + (if (zero? len) + '() + (cons (apply f (car l1) (map car rest)) + (mapn (cdr l1) (map cdr rest) (1- len))))))))) + +(define map-in-order map) + +(define for-each + (case-lambda + ((f l) + (check-arg procedure? f for-each) + (check-arg list? l for-each) + (let for-each1 ((l l)) + (unless (null? l) + (f (car l)) + (for-each1 (cdr l))))) + + ((f l1 l2) + (check-arg procedure? f for-each) + (let* ((len1 (length+ l1)) + (len2 (length+ l2)) + (len (if (and len1 len2) + (min len1 len2) + (or len1 len2)))) + (unless len + (scm-error 'wrong-type-arg "for-each" + "Args do not contain a proper (finite) list: ~S" + (list (list l1 l2)) #f)) + (let for-each2 ((l1 l1) (l2 l2) (len len)) + (unless (zero? len) + (f (car l1) (car l2)) + (for-each2 (cdr l1) (cdr l2) (1- len)))))) + + ((f l1 . rest) + (check-arg procedure? f for-each) + (let ((len (fold (lambda (ls len) + (let ((ls-len (length+ ls))) + (if len + (if ls-len (min ls-len len) len) + ls-len))) + (length+ l1) + rest))) + (if (not len) + (scm-error 'wrong-type-arg "for-each" + "Args do not contain a proper (finite) list: ~S" + (list (cons l1 rest)) #f)) + (let for-eachn ((l1 l1) (rest rest) (len len)) + (if (> len 0) + (begin + (apply f (car l1) (map car rest)) + (for-eachn (cdr l1) (map cdr rest) (1- len))))))))) + +(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 (filter-map proc list1 . rest) + "Apply PROC to the elements of LIST1... and return a list of the +results as per SRFI-1 `map', except that any #f results are omitted from +the list returned." + (check-arg procedure? proc filter-map) + (if (null? rest) + (let lp ((l list1) + (rl '())) + (if (null? l) + (reverse! rl) + (let ((res (proc (car l)))) + (if res + (lp (cdr l) (cons res rl)) + (lp (cdr l) rl))))) + (let lp ((l (cons list1 rest)) + (rl '())) + (if (any1 null? l) + (reverse! rl) + (let ((res (apply proc (map car l)))) + (if res + (lp (map cdr l) (cons res rl)) + (lp (map cdr l) rl))))))) + +(define (pair-for-each f clist1 . rest) + (check-arg procedure? f pair-for-each) + (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 (map cdr l))))))) + + +;;; Searching + +(define (take-while pred ls) + "Return a new list which is the longest initial prefix of LS whose +elements all satisfy the predicate PRED." + (check-arg procedure? pred take-while) + (cond ((null? ls) '()) + ((not (pred (car ls))) '()) + (else + (let ((result (list (car ls)))) + (let lp ((ls (cdr ls)) (p result)) + (cond ((null? ls) result) + ((not (pred (car ls))) result) + (else + (set-cdr! p (list (car ls))) + (lp (cdr ls) (cdr p))))))))) + +(define (take-while! pred lst) + "Linear-update variant of `take-while'." + (check-arg procedure? pred take-while!) + (let loop ((prev #f) + (rest lst)) + (cond ((null? rest) + lst) + ((pred (car rest)) + (loop rest (cdr rest))) + (else + (if (pair? prev) + (begin + (set-cdr! prev '()) + lst) + '()))))) + +(define (drop-while pred lst) + "Drop the longest initial prefix of LST whose elements all satisfy the +predicate PRED." + (check-arg procedure? pred drop-while) + (let loop ((lst lst)) + (cond ((null? lst) + '()) + ((pred (car lst)) + (loop (cdr lst))) + (else lst)))) + +(define (span pred lst) + "Return two values, the longest initial prefix of LST whose elements +all satisfy the predicate PRED, and the remainder of LST." + (check-arg procedure? pred span) + (let lp ((lst lst) (rl '())) + (if (and (not (null? lst)) + (pred (car lst))) + (lp (cdr lst) (cons (car lst) rl)) + (values (reverse! rl) lst)))) + +(define (span! pred list) + "Linear-update variant of `span'." + (check-arg procedure? pred span!) + (let loop ((prev #f) + (rest list)) + (cond ((null? rest) + (values list '())) + ((pred (car rest)) + (loop rest (cdr rest))) + (else + (if (pair? prev) + (begin + (set-cdr! prev '()) + (values list rest)) + (values '() list)))))) + +(define (break pred clist) + "Return two values, the longest initial prefix of LST whose elements +all fail the predicate PRED, and the remainder of LST." + (check-arg procedure? pred break) + (let lp ((clist clist) (rl '())) + (if (or (null? clist) + (pred (car clist))) + (values (reverse! rl) clist) + (lp (cdr clist) (cons (car clist) rl))))) + +(define (break! pred list) + "Linear-update variant of `break'." + (check-arg procedure? pred break!) + (let loop ((l list) + (prev #f)) + (cond ((null? l) + (values list '())) + ((pred (car l)) + (if (pair? prev) + (begin + (set-cdr! prev '()) + (values list l)) + (values '() list))) + (else + (loop (cdr l) l))))) + +(define (any pred ls . lists) + (check-arg procedure? pred any) + (if (null? lists) + (any1 pred ls) + (let lp ((lists (cons ls lists))) + (cond ((any1 null? lists) + #f) + ((any1 null? (map cdr lists)) + (apply pred (map car lists))) + (else + (or (apply pred (map car lists)) (lp (map 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) + (check-arg procedure? pred every) + (if (null? lists) + (every1 pred ls) + (let lp ((lists (cons ls lists))) + (cond ((any1 null? lists) + #t) + ((any1 null? (map cdr lists)) + (apply pred (map car lists))) + (else + (and (apply pred (map car lists)) (lp (map 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))))))) + +(define (list-index pred clist1 . rest) + "Return the index of the first set of elements, one from each of +CLIST1 ... CLISTN, that satisfies PRED." + (check-arg procedure? pred list-index) + (if (null? rest) + (let lp ((l clist1) (i 0)) + (if (null? l) + #f + (if (pred (car l)) + i + (lp (cdr l) (+ i 1))))) + (let lp ((lists (cons clist1 rest)) (i 0)) + (cond ((any1 null? lists) + #f) + ((apply pred (map car lists)) i) + (else + (lp (map cdr lists) (+ i 1))))))) + +;;; Association lists + +(define alist-cons acons) + +(define (alist-copy alist) + "Return a copy of ALIST, copying both the pairs comprising the list +and those making the associations." + (let lp ((a alist) + (rl '())) + (if (null? a) + (reverse! rl) + (lp (cdr a) (alist-cons (caar a) (cdar a) rl))))) + +(define* (alist-delete key alist #:optional (k= equal?)) + (check-arg procedure? k= alist-delete) + (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 #:optional (k= equal?)) + (alist-delete key alist k=)) ; XXX:optimize + +;;; Delete / assoc / member + +(define* (member x ls #:optional (= equal?)) + (cond + ;; This might be performance-sensitive, so punt on the check here, + ;; relying on memq/memv to check that = is a procedure. + ((eq? = eq?) (memq x ls)) + ((eq? = eqv?) (memv x ls)) + (else + (check-arg procedure? = member) + (find-tail (lambda (y) (= x y)) ls)))) + +;;; Set operations on lists + +(define (lset<= = . rest) + (check-arg procedure? = lset<=) + (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) + (check-arg procedure? = lset<=) + (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))))))) + +;; It's not quite clear if duplicates among the `rest' elements are meant to +;; be cast out. The spec says `=' is called as (= lstelem restelem), +;; suggesting perhaps not, but the reference implementation shows the "list" +;; at each stage as including those elements already added. The latter +;; corresponds to what's described for lset-union, so that's what's done. +;; +(define (lset-adjoin = list . rest) + "Add to LIST any of the elements of REST not already in the list. +These elements are `cons'ed onto the start of LIST (so the return shares +a common tail with LIST), but the order they're added is unspecified. + +The given `=' procedure is used for comparing elements, called +as `(@var{=} listelem elem)', i.e., the second argument is one of the +given REST parameters." + ;; If `=' is `eq?' or `eqv?', users won't be able to tell which arg is + ;; first, so we can pass the raw procedure through to `member', + ;; allowing `memq' / `memv' to be selected. + (define pred + (if (or (eq? = eq?) (eq? = eqv?)) + = + (begin + (check-arg procedure? = lset-adjoin) + (lambda (x y) (= y x))))) + + (let lp ((ans list) (rest rest)) + (if (null? rest) + ans + (lp (if (member (car rest) ans pred) + ans + (cons (car rest) ans)) + (cdr rest))))) + +(define (lset-union = . rest) + ;; Likewise, allow memq / memv to be used if possible. + (define pred + (if (or (eq? = eq?) (eq? = eqv?)) + = + (begin + (check-arg procedure? = lset-union) + (lambda (x y) (= y x))))) + + (fold (lambda (lis ans) ; Compute ANS + LIS. + (cond ((null? lis) ans) ; Don't copy any lists + ((null? ans) lis) ; if we don't have to. + ((eq? lis ans) ans) + (else + (fold (lambda (elt ans) + (if (member elt ans pred) + ans + (cons elt ans))) + ans lis)))) + '() + rest)) + +(define (lset-intersection = list1 . rest) + (check-arg procedure? = lset-intersection) + (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) + (check-arg procedure? = lset-difference) + (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) + (check-arg procedure? = lset-xor) + (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) + (check-arg procedure? = lset-diff+intersection) + (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) + (check-arg procedure? = lset-union!) + (apply lset-union = rest)) ; XXX:optimize + +(define (lset-intersection! = list1 . rest) + (check-arg procedure? = lset-intersection!) + (apply lset-intersection = list1 rest)) ; XXX:optimize + +(define (lset-xor! = . rest) + (check-arg procedure? = lset-xor!) + (apply lset-xor = rest)) ; XXX:optimize + +(define (lset-diff+intersection! = list1 . rest) + (check-arg procedure? = lset-diff+intersection!) + (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..533d9f769 --- /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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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..22bda21a2 --- /dev/null +++ b/module/srfi/srfi-11.scm @@ -0,0 +1,146 @@ +;;; srfi-11.scm --- let-values and let*-values + +;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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) + :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)))))) + +;; We could really use quasisyntax here... +(define-syntax let-values + (lambda (x) + (syntax-case x () + ((_ ((binds exp)) b0 b1 ...) + (syntax (call-with-values (lambda () exp) + (lambda binds b0 b1 ...)))) + ((_ (clause ...) b0 b1 ...) + (let lp ((clauses (syntax (clause ...))) + (ids '()) + (tmps '())) + (if (null? clauses) + (with-syntax (((id ...) ids) + ((tmp ...) tmps)) + (syntax (let ((id tmp) ...) + b0 b1 ...))) + (syntax-case (car clauses) () + (((var ...) exp) + (with-syntax (((new-tmp ...) (generate-temporaries + (syntax (var ...)))) + ((id ...) ids) + ((tmp ...) tmps)) + (with-syntax ((inner (lp (cdr clauses) + (syntax (var ... id ...)) + (syntax (new-tmp ... tmp ...))))) + (syntax (call-with-values (lambda () exp) + (lambda (new-tmp ...) inner)))))) + ((vars exp) + (with-syntax ((((new-tmp . new-var) ...) + (let lp ((vars (syntax vars))) + (syntax-case vars () + ((id . rest) + (acons (syntax id) + (car + (generate-temporaries (syntax (id)))) + (lp (syntax rest)))) + (id (acons (syntax id) + (car + (generate-temporaries (syntax (id)))) + '()))))) + ((id ...) ids) + ((tmp ...) tmps)) + (with-syntax ((inner (lp (cdr clauses) + (syntax (new-var ... id ...)) + (syntax (new-tmp ... tmp ...)))) + (args (let lp ((tmps (syntax (new-tmp ...)))) + (syntax-case tmps () + ((id) (syntax id)) + ((id . rest) (cons (syntax id) + (lp (syntax rest)))))))) + (syntax (call-with-values (lambda () exp) + (lambda args inner))))))))))))) + +;;;;;;;;;;;;;; +;; 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 ...) + (let () 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 ...)))))) + +;;; srfi-11.scm ends here diff --git a/module/srfi/srfi-111.scm b/module/srfi/srfi-111.scm new file mode 100644 index 000000000..3d3cd896b --- /dev/null +++ b/module/srfi/srfi-111.scm @@ -0,0 +1,37 @@ +;;; srfi-111.scm -- SRFI 111 Boxes + +;; Copyright (C) 2014 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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-111) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:export (box box? unbox set-box!)) + +(cond-expand-provide (current-module) '(srfi-111)) + +(define-record-type <box> + (box value) + box? + (value unbox set-box!)) + +(set-record-type-printer! <box> + (lambda (box port) + (display "#<box " port) + (display (number->string (object-address box) 16) port) + (display " value: ") + (write (unbox box) port) + (display ">" port))) diff --git a/module/srfi/srfi-13.scm b/module/srfi/srfi-13.scm new file mode 100644 index 000000000..a2d64cba3 --- /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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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..ecc21e52e --- /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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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..d103ce979 --- /dev/null +++ b/module/srfi/srfi-16.scm @@ -0,0 +1,51 @@ +;;; srfi-16.scm --- case-lambda + +;; Copyright (C) 2001, 2002, 2006, 2009, 2014 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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) + #:re-export (case-lambda)) + +;; Case-lambda is now provided by core psyntax. diff --git a/module/srfi/srfi-17.scm b/module/srfi/srfi-17.scm new file mode 100644 index 000000000..a14c5c33b --- /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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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..7177e0690 --- /dev/null +++ b/module/srfi/srfi-18.scm @@ -0,0 +1,382 @@ +;;; srfi-18.scm --- Multithreading support + +;; Copyright (C) 2008, 2009, 2010, 2012, 2014, 2018 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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 ((ice-9 threads) #:prefix threads:) + #:use-module (ice-9 match) + #:use-module (srfi srfi-9) + #:use-module ((srfi srfi-34) #:prefix srfi-34:) + #:use-module ((srfi srfi-35) #:select (define-condition-type + &error + condition)) + #:export (;; Threads + make-thread + thread-name + thread-specific + thread-specific-set! + thread-start! + thread-yield! + thread-sleep! + thread-terminate! + thread-join! + + ;; Mutexes + make-mutex + mutex + mutex-name + mutex-specific + mutex-specific-set! + mutex-state + mutex-lock! + mutex-unlock! + + ;; Condition variables + make-condition-variable + condition-variable-name + condition-variable-specific + condition-variable-specific-set! + condition-variable-signal! + condition-variable-broadcast! + + ;; Time + current-time + time? + time->seconds + seconds->time + + current-exception-handler + with-exception-handler + join-timeout-exception? + abandoned-mutex-exception? + terminated-thread-exception? + uncaught-exception? + uncaught-exception-reason) + #:re-export ((srfi-34:raise . raise)) + #:replace (current-time + current-thread + thread? + make-thread + make-mutex + mutex? + make-condition-variable + condition-variable?)) + +(unless (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-condition-type &abandoned-mutex-exception &error + abandoned-mutex-exception?) +(define-condition-type &join-timeout-exception &error + join-timeout-exception?) +(define-condition-type &terminated-thread-exception &error + terminated-thread-exception?) +(define-condition-type &uncaught-exception &error + uncaught-exception? + (reason uncaught-exception-reason)) + +(define-record-type <mutex> + (%make-mutex prim name specific owner abandoned?) + mutex? + (prim mutex-prim) + (name mutex-name) + (specific mutex-specific mutex-specific-set!) + (owner mutex-owner set-mutex-owner!) + (abandoned? mutex-abandoned? set-mutex-abandoned?!)) + +(define-record-type <condition-variable> + (%make-condition-variable prim name specific) + condition-variable? + (prim condition-variable-prim) + (name condition-variable-name) + (specific condition-variable-specific condition-variable-specific-set!)) + +(define-record-type <thread> + (%make-thread prim name specific start-conds exception) + thread? + (prim thread-prim set-thread-prim!) + (name thread-name) + (specific thread-specific thread-specific-set!) + (start-conds thread-start-conds set-thread-start-conds!) + (exception thread-exception set-thread-exception!)) + +(define current-thread (make-parameter (%make-thread #f #f #f #f #f))) +(define thread-mutexes (make-parameter #f)) + +(define (timeout->absolute-time timeout) + "Return an absolute time in seconds corresponding to TIMEOUT. TIMEOUT +can be any value authorized by SRFI-18: a number (relative time), a time +object (absolute point in time), or #f." + (cond ((number? timeout) ;seconds relative to now + (+ ((@ (guile) current-time)) timeout)) + ((time? timeout) ;absolute point in time + (time->seconds timeout)) + (else timeout))) ;pair or #f + +;; EXCEPTIONS + +;; All threads created by SRFI-18 have an initial handler installed that +;; will squirrel away an uncaught exception to allow it to bubble out to +;; joining threads. However for the main thread and other threads not +;; created by SRFI-18, just let the exception bubble up by passing on +;; doing anything with the exception. +(define (exception-handler-for-foreign-threads obj) + (values)) + +(define current-exception-handler + (make-parameter exception-handler-for-foreign-threads)) + +(define (with-exception-handler handler thunk) + (check-arg-type procedure? handler "with-exception-handler") + (check-arg-type thunk? thunk "with-exception-handler") + (srfi-34:with-exception-handler + (let ((prev-handler (current-exception-handler))) + (lambda (obj) + (parameterize ((current-exception-handler prev-handler)) + (handler obj)))) + (lambda () + (parameterize ((current-exception-handler handler)) + (thunk))))) + +;; 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 (with-thread-mutex-cleanup thunk) + (let ((mutexes (make-weak-key-hash-table))) + (dynamic-wind + values + (lambda () + (parameterize ((thread-mutexes mutexes)) + (thunk))) + (lambda () + (let ((thread (current-thread))) + (hash-for-each (lambda (mutex _) + (when (eq? (mutex-owner mutex) thread) + (abandon-mutex! mutex))) + mutexes)))))) + +(define* (make-thread thunk #:optional name) + (let* ((sm (make-mutex 'start-mutex)) + (sc (make-condition-variable 'start-condition-variable)) + (thread (%make-thread #f name #f (cons sm sc) #f))) + (mutex-lock! sm) + (let ((prim (threads:call-with-new-thread + (lambda () + (catch #t + (lambda () + (parameterize ((current-thread thread)) + (with-thread-mutex-cleanup + (lambda () + (mutex-lock! sm) + (condition-variable-signal! sc) + (mutex-unlock! sm sc) + (thunk))))) + (lambda (key . args) + (set-thread-exception! + thread + (condition (&uncaught-exception + (reason + (match (cons key args) + (('srfi-34 obj) obj) + (obj obj)))))))))))) + (set-thread-prim! thread prim) + (mutex-unlock! sm sc) + thread))) + +(define (thread-start! thread) + (match (thread-start-conds thread) + ((smutex . scond) + (set-thread-start-conds! thread #f) + (mutex-lock! smutex) + (condition-variable-signal! scond) + (mutex-unlock! smutex)) + (#f #f)) + thread) + +(define (thread-yield!) (threads:yield) *unspecified*) + +(define (thread-sleep! timeout) + (let* ((t (cond ((time? timeout) (- (time->seconds timeout) + (time->seconds (current-time)))) + ((number? timeout) timeout) + (else (scm-error 'wrong-type-arg "thread-sleep!" + "Wrong type argument: ~S" + (list timeout) + '())))) + (secs (inexact->exact (truncate t))) + (usecs (inexact->exact (truncate (* (- t secs) 1000000))))) + (when (> secs 0) (sleep secs)) + (when (> usecs 0) (usleep usecs)) + *unspecified*)) + +;; Whereas SRFI-34 leaves the continuation of a call to an exception +;; handler unspecified, SRFI-18 has this to say: +;; +;; When one of the primitives defined in this SRFI raises an exception +;; defined in this SRFI, the exception handler is called with the same +;; continuation as the primitive (i.e. it is a tail call to the +;; exception handler). +;; +;; Therefore arrange for exceptions thrown by SRFI-18 primitives to run +;; handlers with the continuation of the primitive call, for those +;; primitives that throw exceptions. + +(define (with-exception-handlers-here thunk) + (let ((tag (make-prompt-tag))) + (call-with-prompt tag + (lambda () + (with-exception-handler (lambda (exn) (abort-to-prompt tag exn)) + thunk)) + (lambda (k exn) + ((current-exception-handler) exn))))) + +;; A unique value. +(define %cancel-sentinel (list 'cancelled)) +(define (thread-terminate! thread) + (threads:cancel-thread (thread-prim thread) %cancel-sentinel) + *unspecified*) + +;; A unique value. +(define %timeout-sentinel (list 1)) +(define* (thread-join! thread #:optional (timeout %timeout-sentinel) + (timeoutval %timeout-sentinel)) + (let ((t (thread-prim thread))) + (with-exception-handlers-here + (lambda () + (let* ((v (if (eq? timeout %timeout-sentinel) + (threads:join-thread t) + (threads:join-thread t timeout %timeout-sentinel)))) + (cond + ((eq? v %timeout-sentinel) + (if (eq? timeoutval %timeout-sentinel) + (srfi-34:raise (condition (&join-timeout-exception))) + timeoutval)) + ((eq? v %cancel-sentinel) + (srfi-34:raise (condition (&terminated-thread-exception)))) + ((thread-exception thread) => srfi-34:raise) + (else v))))))) + +;; MUTEXES + +(define* (make-mutex #:optional name) + (%make-mutex (threads:make-mutex 'allow-external-unlock) name #f #f #f)) + +(define (mutex-state mutex) + (cond + ((mutex-abandoned? mutex) 'abandoned) + ((mutex-owner mutex)) + ((> (threads:mutex-level (mutex-prim mutex)) 0) 'not-owned) + (else 'not-abandoned))) + +(define (abandon-mutex! mutex) + (set-mutex-abandoned?! mutex #t) + (threads:unlock-mutex (mutex-prim mutex))) + +(define* (mutex-lock! mutex #:optional timeout (thread (current-thread))) + (let ((mutexes (thread-mutexes))) + (when mutexes + (hashq-set! mutexes mutex #t))) + (with-exception-handlers-here + (lambda () + (cond + ((threads:lock-mutex (mutex-prim mutex) + (timeout->absolute-time timeout)) + (set-mutex-owner! mutex thread) + (when (mutex-abandoned? mutex) + (set-mutex-abandoned?! mutex #f) + (srfi-34:raise + (condition (&abandoned-mutex-exception)))) + #t) + (else #f))))) + +(define %unlock-sentinel (list 'unlock)) +(define* (mutex-unlock! mutex #:optional (cond-var %unlock-sentinel) + (timeout %unlock-sentinel)) + (let ((timeout (timeout->absolute-time timeout))) + (when (mutex-owner mutex) + (set-mutex-owner! mutex #f) + (cond + ((eq? cond-var %unlock-sentinel) + (threads:unlock-mutex (mutex-prim mutex))) + ((eq? timeout %unlock-sentinel) + (threads:wait-condition-variable (condition-variable-prim cond-var) + (mutex-prim mutex)) + (threads:unlock-mutex (mutex-prim mutex))) + ((threads:wait-condition-variable (condition-variable-prim cond-var) + (mutex-prim mutex) + timeout) + (threads:unlock-mutex (mutex-prim mutex))) + (else #f))))) + +;; CONDITION VARIABLES +;; These functions are all pass-thrus to the existing Guile implementations. + +(define* (make-condition-variable #:optional name) + (%make-condition-variable (threads:make-condition-variable) name #f)) + +(define (condition-variable-signal! cond) + (threads:signal-condition-variable (condition-variable-prim cond)) + *unspecified*) + +(define (condition-variable-broadcast! cond) + (threads:broadcast-condition-variable (condition-variable-prim 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 diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm new file mode 100644 index 000000000..b1c5f9e78 --- /dev/null +++ b/module/srfi/srfi-19.scm @@ -0,0 +1,1460 @@ +;;; srfi-19.scm --- Time/Date Library + +;; Copyright (C) 2001-2003, 2005-2011, 2014, 2016-2018 +;; 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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 +;; (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) + :autoload (ice-9 rdelim) (read-line) + :use-module (ice-9 i18n) + :replace (current-time) + :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 + 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->julian-day + time-monotonic->modified-julian-day + 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 + +;; See date->string +(define locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y") +(define locale-short-date-format "~m/~d/~y") +(define locale-time-format "~H:~M:~S") +(define iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z") + +;;-- Miscellaneous Constants. +;;-- only the tai-epoch-in-jd might need changing if +;; a different epoch is used. + +(define nano 1000000000) ; nanoseconds in a second +(define sid 86400) ; seconds in a day +(define sihd 43200) ; seconds in a half day +(define tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch' + +;; FIXME: should this be something other than misc-error? +(define (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 above +;; format and creates the leap second table +;; it also calls the almost standard, but not R5 procedures read-line +;; & open-input-string +;; ie (set! leap-second-table (read-tai-utc-date "tai-utc.dat")) + +(define (read-tai-utc-data filename) + (define (convert-jd jd) + (* (- (inexact->exact jd) tai-epoch-in-jd) 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 leap-second-table + '((1435708800 . 36) + (1341100800 . 35) + (1230768000 . 34) + (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! leap-second-table (read-tai-utc-data filename))) + + +(define (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 sid)) 0 + (lsd 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 (split-real r) + (if (integer? r) + (values (inexact->exact r) 0) + (let ((l (truncate r))) + (values (inexact->exact l) (- r l))))) + +(define (time-normalize! t) + (if (>= (abs (time-nanosecond t)) 1000000000) + (receive (int frac) + (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) + (time-normalize! (make-time-unnormalized type nanosecond second))) + +;;; current-time + +;;; specific time getters. + +(define (current-time-utc) + ;; Resolution is microseconds. + (let ((tod (gettimeofday))) + (make-time time-utc (* (cdr tod) 1000) (car tod)))) + +(define (current-time-tai) + ;; Resolution is microseconds. + (let* ((tod (gettimeofday)) + (sec (car tod)) + (usec (cdr tod))) + (make-time time-tai + (* usec 1000) + (+ (car tod) (leap-second-delta sec))))) + +;;(define (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 (current-time-monotonic) + ;; Guile monotonic and TAI times are the same. + (let ((tai (current-time-tai))) + (make-time time-monotonic + (time-nanosecond tai) + (time-second tai)))) + +(define (current-time-thread) + (time-error 'current-time 'unsupported-clock-type 'time-thread)) + +(define ns-per-guile-tick (/ 1000000000 internal-time-units-per-second)) + +(define (current-time-process) + (let ((run-time (get-internal-run-time))) + (make-time + time-process + (* (remainder run-time internal-time-units-per-second) + ns-per-guile-tick) + (quotient run-time internal-time-units-per-second)))) + +;;(define (current-time-gc) +;; (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) (current-time-tai)) + ((eq? clock-type time-utc) (current-time-utc)) + ((eq? clock-type time-monotonic) (current-time-monotonic)) + ((eq? clock-type time-thread) (current-time-thread)) + ((eq? clock-type time-process) (current-time-process)) + ;; ((eq? clock-type time-gc) (current-time-gc)) + (else (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) ns-per-guile-tick) + ;; ((eq? clock-type time-thread) 1000) + ;; ((eq? clock-type time-gc) 10000) + (else (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) + (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)) + (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) + (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)) + (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) + (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)) + (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) + (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)) + (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) + (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)) + (time-error 'time-monotonic->time-utc + '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)) + (time-error 'time-monotonic->time-utc! + 'incompatible-time-types time-in)) + (set-time-type! time-in time-tai) + (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc)) + +(define (time-monotonic->time-tai time-in) + (if (not (eq? (time-type time-in) time-monotonic)) + (time-error 'time-monotonic->time-tai + '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)) + (time-error 'time-monotonic->time-tai! + '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)) + (time-error 'time-utc->time-monotonic + '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)) + (time-error 'time-utc->time-monotonic! + '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)) + (time-error 'time-tai->time-monotonic + '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)) + (time-error 'time-tai->time-monotonic! + '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 (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 (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) 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 (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 (time->julian-day-number seconds tz-offset) + (+ (/ (+ seconds tz-offset sihd) + sid) + tai-epoch-in-jd)) + +(define (leap-second? second) + (and (assoc second leap-second-table) #t)) + +(define (time-utc->date time . tz-offset) + (if (not (eq? (time-type time) time-utc)) + (time-error 'time->date 'incompatible-time-types time)) + (let* ((offset (if (null? tz-offset) + (local-tz-offset time) + (car tz-offset))) + (leap-second? (leap-second? (+ offset (time-second time)))) + (jdn (time->julian-day-number (if leap-second? + (- (time-second time) 1) + (time-second time)) + offset))) + + (call-with-values (lambda () (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)) + (time-error 'time->date 'incompatible-time-types time)) + (let* ((offset (if (null? tz-offset) + (local-tz-offset (time-tai->time-utc time)) + (car tz-offset))) + (seconds (- (time-second time) + (leap-second-delta (time-second time)))) + (leap-second? (leap-second? (+ offset seconds))) + (jdn (time->julian-day-number (if leap-second? + (- seconds 1) + seconds) + offset))) + (call-with-values (lambda () (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)) + (time-error 'time->date 'incompatible-time-types time)) + (let* ((offset (if (null? tz-offset) + (local-tz-offset (time-monotonic->time-utc time)) + (car tz-offset))) + (seconds (- (time-second time) + (leap-second-delta (time-second time)))) + (leap-second? (leap-second? (+ offset seconds))) + (jdn (time->julian-day-number (if leap-second? + (- seconds 1) + seconds) + offset))) + (call-with-values (lambda () (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 (- (encode-julian-day-number (date-day date) + (date-month date) + (date-year date)) + 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 (leap-year? year) + (or (= (modulo year 400) 0) + (and (= (modulo year 4) 0) (not (= (modulo year 100) 0))))) + +;; 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 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 (year-day day month year) + (let ((days-pr (assoc month month-assoc))) + (if (not days-pr) + (time-error 'date-year-day 'invalid-month-specification month)) + (if (and (leap-year? year) (> month 2)) + (+ day (cdr days-pr) 1) + (+ day (cdr days-pr))))) + +(define (date-year-day date) + (year-day (date-day date) (date-month date) (date-year date))) + +;; from calendar faq +(define (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) + (week-day (date-day date) (date-month date) (date-year date))) + +(define (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 + (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) + (local-tz-offset time) + (car tz-offset))))) + +;; given a 'two digit' number, find the year within 50 years +/- +(define (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))) + (+ (encode-julian-day-number day month year) + (- 1/2) + (+ (/ (+ (- offset) + (* hour 60 60) + (* minute 60) + second + (/ nanosecond nano)) + 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)) + (time-error 'time->date 'incompatible-time-types time)) + (+ (/ (+ (time-second time) (/ (time-nanosecond time) nano)) + sid) + 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)) + (time-error 'time->date 'incompatible-time-types time)) + (+ (/ (+ (- (time-second time) + (leap-second-delta (time-second time))) + (/ (time-nanosecond time) nano)) + sid) + 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)) + (time-error 'time->date 'incompatible-time-types time)) + (+ (/ (+ (- (time-second time) + (leap-second-delta (time-second time))) + (/ (time-nanosecond time) nano)) + sid) + 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 (* sid (- jdn tai-epoch-in-jd)))) + (receive (seconds parts) + (split-real secs) + (make-time time-utc + (* parts 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) + (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 (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 (last-n-digits i n) + (abs (remainder i (expt 10 n)))) + +(define (locale-abbr-weekday n) (locale-day-short (+ 1 n))) +(define (locale-long-weekday n) (locale-day (+ 1 n))) +(define locale-abbr-month locale-month-short) +(define locale-long-month locale-month) + +(define (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 (locale-abbr-weekday->index string) + (date-reverse-lookup string locale-day-short 7 string=?)) + +(define (locale-long-weekday->index string) + (date-reverse-lookup string locale-day 7 string=?)) + +(define (locale-abbr-month->index string) + (date-reverse-lookup string locale-abbr-month 12 string=?)) + +(define (locale-long-month->index string) + (date-reverse-lookup string 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 (locale-print-time-zone date port) + (tz-printer (date-zone-offset date) port)) + +(define (locale-am-string/pm hr) + (if (> hr 11) (locale-pm-string) (locale-am-string))) + +(define (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 (padding hours #\0 2) port) + (display (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 directives + (list + (cons #\~ (lambda (date pad-with port) + (display #\~ port))) + (cons #\a (lambda (date pad-with port) + (display (locale-abbr-weekday (date-week-day date)) + port))) + (cons #\A (lambda (date pad-with port) + (display (locale-long-weekday (date-week-day date)) + port))) + (cons #\b (lambda (date pad-with port) + (display (locale-abbr-month (date-month date)) + port))) + (cons #\B (lambda (date pad-with port) + (display (locale-long-month (date-month date)) + port))) + (cons #\c (lambda (date pad-with port) + (display (date->string date locale-date-time-format) port))) + (cons #\d (lambda (date pad-with port) + (display (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 (padding (date-day date) + #\Space 2) + port))) + (cons #\f (lambda (date pad-with port) + (receive (s ns) (floor/ (+ (* (date-second date) nano) + (date-nanosecond date)) + nano) + (display (number->string s) port) + (display (locale-decimal-point) port) + (let ((str (padding ns #\0 9))) + (display (substring str 0 1) port) + (display (string-trim-right str #\0 1) port))))) + (cons #\h (lambda (date pad-with port) + (display (date->string date "~b") port))) + (cons #\H (lambda (date pad-with port) + (display (padding (date-hour date) + pad-with 2) + port))) + (cons #\I (lambda (date pad-with port) + (let ((hr (date-hour date))) + (if (> hr 12) + (display (padding (- hr 12) + pad-with 2) + port) + (display (padding hr + pad-with 2) + port))))) + (cons #\j (lambda (date pad-with port) + (display (padding (date-year-day date) + pad-with 3) + port))) + (cons #\k (lambda (date pad-with port) + (display (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 (padding hr #\Space 2) + port)))) + (cons #\m (lambda (date pad-with port) + (display (padding (date-month date) + pad-with 2) + port))) + (cons #\M (lambda (date pad-with port) + (display (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 (padding (date-nanosecond date) + pad-with 9) + port))) + (cons #\p (lambda (date pad-with port) + (display (locale-am-string/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) + nano) + (display (padding (+ (date-second date) 1) + pad-with 2) + port) + (display (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 (> (days-before-first-week date 0) 0) + (display (padding (+ (date-week-number date 0) 1) + #\0 2) port) + (display (padding (date-week-number date 0) + #\0 2) port)))) + (cons #\V (lambda (date pad-with port) + (display (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 locale-short-date-format) port))) + (cons #\X (lambda (date pad-with port) + (display (date->string date locale-time-format) port))) + (cons #\W (lambda (date pad-with port) + (if (> (days-before-first-week date 1) 0) + (display (padding (+ (date-week-number date 1) 1) + #\0 2) port) + (display (padding (date-week-number date 1) + #\0 2) port)))) + (cons #\y (lambda (date pad-with port) + (display (padding (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) + (tz-printer (date-zone-offset date) port))) + (cons #\Z (lambda (date pad-with port) + (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 "~H:~M:~S~z") port))) + (cons #\3 (lambda (date pad-with port) + (display (date->string date "~H:~M:~S") port))) + (cons #\4 (lambda (date pad-with port) + (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port))) + (cons #\5 (lambda (date pad-with port) + (display (date->string date "~Y-~m-~dT~H:~M:~S") port))))) + + +(define (get-formatter char) + (let ((associated (assoc char directives))) + (if associated (cdr associated) #f))) + +(define (date-printer date index format-string str-len port) + (if (< index str-len) + (let ((current-char (string-ref format-string index))) + (if (not (char=? current-char #\~)) + (begin + (display current-char port) + (date-printer date (+ index 1) format-string str-len port)) + (if (= (+ index 1) str-len) ; bad format string. + (time-error '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. + (time-error 'date-printer + 'bad-date-format-string + format-string) + (let ((formatter (get-formatter + (string-ref format-string + (+ index 2))))) + (if (not formatter) + (time-error 'date-printer + 'bad-date-format-string + format-string) + (begin + (formatter date #f port) + (date-printer date + (+ index 3) + format-string + str-len + port)))))) + + ((char=? pad-char? #\_) + (if (= (+ index 2) str-len) ; bad format string. + (time-error 'date-printer + 'bad-date-format-string + format-string) + (let ((formatter (get-formatter + (string-ref format-string + (+ index 2))))) + (if (not formatter) + (time-error 'date-printer + 'bad-date-format-string + format-string) + (begin + (formatter date #\Space port) + (date-printer date + (+ index 3) + format-string + str-len + port)))))) + (else + (let ((formatter (get-formatter + (string-ref format-string + (+ index 1))))) + (if (not formatter) + (time-error 'date-printer + 'bad-date-format-string + format-string) + (begin + (formatter date #\0 port) + (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)))) + (date-printer date 0 fmt-str (string-length fmt-str) str-port) + (get-output-string str-port))) + +(define (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 (time-error 'char->int 'bad-date-template-string + (list "Non-integer character" ch))))) + +;; read an integer upto n characters long on port; upto -> #f is any length +(define (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) (char->int (read-char port))) + (+ nchars 1)))))) + +(define (make-integer-reader upto) + (lambda (port) + (integer-reader upto port))) + +;; read *exactly* n characters and convert to integer; could be padded +(define (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) + (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) (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 + (time-error 'string->date 'bad-date-template-string + "Non-numeric characters in integer read."))))) + (accum-int port 0 0))) + + +(define (make-integer-exact-reader n) + (lambda (port) + (integer-reader-exact n port))) + +(define (zone-reader port) + (let ((offset 0) + (positive? #f)) + (let ((ch (read-char port))) + (if (eof-object? ch) + (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 + (time-error 'string->date 'bad-date-template-string + (list "Invalid time zone +/-" ch)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (* (char->int ch) + 10 60 60))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (+ offset (* (char->int ch) + 60 60)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (+ offset (* (char->int ch) + 10 60)))) + (let ((ch (read-char port))) + (if (eof-object? ch) + (time-error 'string->date 'bad-date-template-string + (list "Invalid time zone number" ch))) + (set! offset (+ offset (* (char->int ch) + 60)))) + (if positive? offset (- offset))))))) + +;; looking at a char, read the char string, run thru indexer, return index +(define (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 (time-error 'string->date + 'bad-date-template-string + (list "Invalid string for " indexer))))) + +(define (make-locale-reader indexer) + (lambda (port) + (locale-reader port indexer))) + +(define (make-char-id-reader char) + (lambda (port) + (if (char=? char (read-char port)) + char + (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. an optional action procedure, that takes the value (from 3.) and +;; some object (here, always the date) and (probably) side-effects it. +;; If no action is required, as with ~A, this element may be #f. + +(define read-directives + (let ((ireader4 (make-integer-reader 4)) + (ireader2 (make-integer-reader 2)) + (eireader2 (make-integer-exact-reader 2)) + (locale-reader-abbr-weekday (make-locale-reader + locale-abbr-weekday->index)) + (locale-reader-long-weekday (make-locale-reader + locale-long-weekday->index)) + (locale-reader-abbr-month (make-locale-reader + locale-abbr-month->index)) + (locale-reader-long-month (make-locale-reader + locale-long-month->index)) + (char-fail (lambda (ch) #t))) + + (list + (list #\~ char-fail (make-char-id-reader #\~) #f) + (list #\a char-alphabetic? locale-reader-abbr-weekday #f) + (list #\A char-alphabetic? locale-reader-long-weekday #f) + (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 (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 #\-))) + zone-reader (lambda (val object) + (set-date-zone-offset! object val)))))) + +(define (priv:string->date date index format-string str-len port template-string) + (define (skip-until port skipper) + (let ((ch (peek-char port))) + (if (eof-object? ch) + (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) + (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))) + (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) + (time-error 'string->date + 'bad-date-format-string template-string) + (let* ((format-char (string-ref format-string (+ index 1))) + (format-info (assoc format-char read-directives))) + (if (not format-info) + (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) + (time-error 'string->date + 'bad-date-format-string + template-string) + (if actor (actor val date)))) + (priv:string->date date + (+ index 2) + format-string + str-len + port + template-string)))))))))) + +(define (string->date input-string template-string) + (define (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 + (local-tz-offset + (make-time time-utc 0 0))) + (set-date-zone-offset! newdate + (local-tz-offset + (date->time-utc newdate))))) + (if (date-ok? newdate) + newdate + (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..c09323fbb --- /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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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..4a9f4413a --- /dev/null +++ b/module/srfi/srfi-26.scm @@ -0,0 +1,66 @@ +;;; srfi-26.scm --- specializing parameters without currying. + +;; Copyright (C) 2002, 2006, 2010 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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-syntax cut + (lambda (stx) + (syntax-case stx () + ((cut slot0 slot1+ ...) + (let loop ((slots #'(slot0 slot1+ ...)) + (params '()) + (args '())) + (if (null? slots) + #`(lambda #,(reverse params) #,(reverse args)) + (let ((s (car slots)) + (rest (cdr slots))) + (with-syntax (((var) (generate-temporaries '(var)))) + (syntax-case s (<> <...>) + (<> + (loop rest (cons #'var params) (cons #'var args))) + (<...> + (if (pair? rest) + (error "<...> not on the end of cut expression")) + #`(lambda #,(append (reverse params) #'var) + (apply #,@(reverse (cons #'var args))))) + (else + (loop rest params (cons s args)))))))))))) + +(define-syntax cute + (lambda (stx) + (syntax-case stx () + ((cute slots ...) + (let loop ((slots #'(slots ...)) + (bindings '()) + (arguments '())) + (define (process-hole) + (loop (cdr slots) bindings (cons (car slots) arguments))) + (if (null? slots) + #`(let #,bindings + (cut #,@(reverse arguments))) + (syntax-case (car slots) (<> <...>) + (<> (process-hole)) + (<...> (process-hole)) + (expr + (with-syntax (((t) (generate-temporaries '(t)))) + (loop (cdr slots) + (cons #'(t expr) bindings) + (cons #'t arguments))))))))))) diff --git a/module/srfi/srfi-27.scm b/module/srfi/srfi-27.scm new file mode 100644 index 000000000..0794a437d --- /dev/null +++ b/module/srfi/srfi-27.scm @@ -0,0 +1,96 @@ +;;; srfi-27.scm --- Sources of Random Bits + +;; Copyright (C) 2010 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 3 of the License, or (at your option) any later version. + +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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, see +;; <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module is fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-27) + #:export (random-integer + random-real + default-random-source + make-random-source + random-source? + random-source-state-ref + random-source-state-set! + random-source-randomize! + random-source-pseudo-randomize! + random-source-make-integers + random-source-make-reals) + #:use-module (srfi srfi-9)) + +(cond-expand-provide (current-module) '(srfi-27)) + +(define-record-type :random-source + (%make-random-source state) + random-source? + (state random-source-state set-random-source-state!)) + +(define (make-random-source) + (%make-random-source (seed->random-state 0))) + +(define (random-source-state-ref s) + (random-state->datum (random-source-state s))) + +(define (random-source-state-set! s state) + (set-random-source-state! s (datum->random-state state))) + +(define (random-source-randomize! s) + (let ((time (gettimeofday))) + (set-random-source-state! s (seed->random-state + (+ (* (car time) 1e6) (cdr time)))))) + +(define (random-source-pseudo-randomize! s i j) + (set-random-source-state! s (seed->random-state (i+j->seed i j)))) + +(define (i+j->seed i j) + (logior (ash (spread i 2) 1) + (spread j 2))) + +(define (spread n amount) + (let loop ((result 0) (n n) (shift 0)) + (if (zero? n) + result + (loop (logior result + (ash (logand n 1) shift)) + (ash n -1) + (+ shift amount))))) + +(define (random-source-make-integers s) + (lambda (n) + (random n (random-source-state s)))) + +(define random-source-make-reals + (case-lambda + ((s) + (lambda () + (let loop () + (let ((x (random:uniform (random-source-state s)))) + (if (zero? x) + (loop) + x))))) + ((s unit) + (or (and (real? unit) (< 0 unit 1)) + (error "unit must be real between 0 and 1" unit)) + (random-source-make-reals s)))) + +(define default-random-source (make-random-source)) +(define random-integer (random-source-make-integers default-random-source)) +(define random-real (random-source-make-reals default-random-source)) diff --git a/module/srfi/srfi-28.scm b/module/srfi/srfi-28.scm new file mode 100644 index 000000000..7fc73eb7e --- /dev/null +++ b/module/srfi/srfi-28.scm @@ -0,0 +1,34 @@ +;;; srfi-28.scm --- Basic Format Strings + +;; Copyright (C) 2014 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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 provides a wrapper for simple-format that always outputs +;; to a string. +;; +;; This module is documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-28) + #:replace (format)) + +(define (format message . args) + (apply simple-format #f message args)) + +(cond-expand-provide (current-module) '(srfi-28)) diff --git a/module/srfi/srfi-31.scm b/module/srfi/srfi-31.scm new file mode 100644 index 000000000..f11aa8419 --- /dev/null +++ b/module/srfi/srfi-31.scm @@ -0,0 +1,35 @@ +;;; srfi-31.scm --- special form for recursive evaluation + +;; Copyright (C) 2004, 2006, 2012 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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 (rec)) + +(cond-expand-provide (current-module) '(srfi-31)) + +(define-syntax rec + (syntax-rules () + "Return the given object, defined in a lexical environment where +NAME is bound to itself." + ((_ (name . formals) body ...) ; procedure + (letrec ((name (lambda formals body ...))) + name)) + ((_ name expr) ; arbitrary object + (letrec ((name expr)) + name)))) diff --git a/module/srfi/srfi-34.scm b/module/srfi/srfi-34.scm new file mode 100644 index 000000000..183f0ae23 --- /dev/null +++ b/module/srfi/srfi-34.scm @@ -0,0 +1,84 @@ +;;; srfi-34.scm --- Exception handling for programs + +;; Copyright (C) 2003, 2006, 2008, 2010 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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) + #:replace (raise) + #:export-syntax (guard)) + +(cond-expand-provide (current-module) '(srfi-34)) + +(define throw-key 'srfi-34) + +(define (with-exception-handler handler thunk) + "Returns the result(s) of invoking THUNK. HANDLER must be a +procedure that accepts one argument. It is installed as the current +exception handler for the dynamic extent (as determined by +dynamic-wind) of the invocation of THUNK." + (with-throw-handler throw-key + thunk + (lambda (key obj) + (handler obj)))) + +(define (raise obj) + "Invokes the current exception handler on OBJ. The handler is +called in the dynamic environment of the call to raise, except that +the current exception handler is that in place for the call to +with-exception-handler that installed the handler being called. The +handler's continuation is otherwise unspecified." + (throw throw-key obj)) + +(define-syntax guard + (syntax-rules (else) + "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." + ((guard (var clause ... (else e e* ...)) body body* ...) + (catch throw-key + (lambda () body body* ...) + (lambda (key var) + (cond clause ... + (else e e* ...))))) + ((guard (var clause clause* ...) body body* ...) + (catch throw-key + (lambda () body body* ...) + (lambda (key var) + (cond clause clause* ... + (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..626026d74 --- /dev/null +++ b/module/srfi/srfi-35.scm @@ -0,0 +1,350 @@ +;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*- + +;; Copyright (C) 2007-2011, 2017 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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. + ;; user fields: id, parent, all-field-names + (let ((s (make-vtable (string-append standard-vtable-fields "pwpwpw") + (lambda (ct port) + (format port "#<condition-type ~a ~a>" + (condition-type-id ct) + (number->string (object-address ct) + 16)))))) + (set-struct-vtable-name! s 'condition-type) + s)) + +(define (%make-condition-type layout id parent all-fields) + (let ((struct (make-struct/no-tail %condition-type-vtable + (make-struct-layout layout) ;; layout + print-condition ;; printer + id parent all-fields))) + + ;; Hack to associate STRUCT with a name, providing a better name for + ;; GOOPS classes as returned by `class-of' et al. + (set-struct-vtable-name! struct (cond ((symbol? id) id) + ((string? id) (string->symbol id)) + (else (string->symbol "")))) + struct)) + +(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 (+ vtable-offset-user 0)))) + +(define (condition-type-parent ct) + (and (condition-type? ct) + (struct-ref ct (+ vtable-offset-user 1)))) + +(define (condition-type-all-fields ct) + (and (condition-type? ct) + (struct-ref ct (+ vtable-offset-user 2)))) + + +(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 '("pw"))) + (if (null? field-names) + (string-concatenate/shared layout) + (loop (cdr field-names) + (cons "pw" layout))))) + +(define (print-condition c port) + ;; Print condition C to PORT in a way similar to how records print: + ;; #<condition TYPE [FIELD: VALUE ...] ADDRESS>. + (define (field-values) + (let* ((type (struct-vtable c)) + (strings (fold (lambda (field result) + (cons (format #f "~A: ~S" field + (condition-ref c field)) + result)) + '() + (condition-type-all-fields type)))) + (string-join (reverse strings) " "))) + + (format port "#<condition ~a [~a] ~a>" + (condition-type-id (condition-type c)) + (field-values) + (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-condition-type layout + 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-condition-type layout + id + parents ;; list of parents! + 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/no-tail type 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-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...) + (begin + (define name + (make-condition-type 'name parent '(field-name ...))) + (define (pred c) + (condition-has-type? c name)) + (define (field-accessor c) + (condition-ref c 'field-name)) + ...)) + +(define-syntax-rule (compound-condition (type ...) (field ...)) + ;; Create a compound condition using `make-compound-condition-type'. + (condition ((make-compound-condition-type '%compound `(,type ...)) + field ...))) + +(define-syntax condition-instantiation + ;; Build the `(make-condition type ...)' call. + (syntax-rules () + ((_ type (out ...)) + (make-condition type out ...)) + ((_ type (out ...) (field-name field-value) rest ...) + (condition-instantiation type (out ... 'field-name field-value) rest ...)))) + +(define-syntax condition + (syntax-rules () + ((_ (type field ...)) + (condition-instantiation type () field ...)) + ((_ (type field ...) ...) + (compound-condition (type ...) (field ... ...))))) + + +;;; +;;; Standard condition types. +;;; + +(define &condition + ;; The root condition type. + (make-struct/no-tail %condition-type-vtable + (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?) + +;;; 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..c34b0d083 --- /dev/null +++ b/module/srfi/srfi-37.scm @@ -0,0 +1,234 @@ +;;; srfi-37.scm --- args-fold + +;; Copyright (C) 2007, 2008, 2013 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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)) + ((pair? args) + (set! args (cdr args)) + #f) + (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 (string-null? arg) + (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-38.scm b/module/srfi/srfi-38.scm new file mode 100644 index 000000000..34cf22ef7 --- /dev/null +++ b/module/srfi/srfi-38.scm @@ -0,0 +1,207 @@ +;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) Ray Dillinger 2003. All Rights Reserved. +;; +;; Contains code based upon Alex Shinn's public-domain implementation of +;; `read-with-shared-structure' found in Chicken's SRFI 38 egg. + +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(define-module (srfi srfi-38) + #:export (write-with-shared-structure + read-with-shared-structure) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-69) + #:use-module (system vm trap-state)) + +(cond-expand-provide (current-module) '(srfi-38)) + +;; A printer that shows all sharing of substructures. Uses the Common +;; Lisp print-circle notation: #n# refers to a previous substructure +;; labeled with #n=. Takes O(n^2) time. + +;; Code attributed to Al Petrofsky, modified by Ray Dillinger. + +;; Modified in 2010 by Andreas Rottmann to use SRFI 69 hashtables, +;; making the time O(n), and adding some of Guile's data types to the +;; `interesting' objects. + +(define* (write-with-shared-structure obj + #:optional + (outport (current-output-port)) + (optarg #f)) + + ;; We only track duplicates of pairs, vectors, strings, bytevectors, + ;; structs (which subsume R6RS and SRFI-9 records), ports and (native) + ;; hash-tables. We ignore zero-length vectors and strings because + ;; r5rs doesn't guarantee that eq? treats them sanely (and they aren't + ;; very interesting anyway). + + (define (interesting? obj) + (or (pair? obj) + (and (vector? obj) (not (zero? (vector-length obj)))) + (and (string? obj) (not (zero? (string-length obj)))) + (bytevector? obj) + (struct? obj) + (port? obj) + (hash-table? obj))) + + ;; (write-obj OBJ STATE): + ;; + ;; STATE is a hashtable which has an entry for each interesting part + ;; of OBJ. The associated value will be: + ;; + ;; -- a number if the part has been given one, + ;; -- #t if the part will need to be assigned a number but has not been yet, + ;; -- #f if the part will not need a number. + ;; The entry `counter' in STATE should be the most recently + ;; assigned number. + ;; + ;; Mutates STATE for any parts that had numbers assigned. + (define (write-obj obj state) + (define (write-interesting) + (cond ((pair? obj) + (display "(" outport) + (write-obj (car obj) state) + (let write-cdr ((obj (cdr obj))) + (cond ((and (pair? obj) (not (hash-table-ref state obj))) + (display " " outport) + (write-obj (car obj) state) + (write-cdr (cdr obj))) + ((null? obj) + (display ")" outport)) + (else + (display " . " outport) + (write-obj obj state) + (display ")" outport))))) + ((vector? obj) + (display "#(" outport) + (let ((len (vector-length obj))) + (write-obj (vector-ref obj 0) state) + (let write-vec ((i 1)) + (cond ((= i len) (display ")" outport)) + (else (display " " outport) + (write-obj (vector-ref obj i) state) + (write-vec (+ i 1))))))) + ;; else it's a string + (else (write obj outport)))) + (cond ((interesting? obj) + (let ((val (hash-table-ref state obj))) + (cond ((not val) (write-interesting)) + ((number? val) + (begin (display "#" outport) + (write val outport) + (display "#" outport))) + (else + (let ((n (+ 1 (hash-table-ref state 'counter)))) + (display "#" outport) + (write n outport) + (display "=" outport) + (hash-table-set! state 'counter n) + (hash-table-set! state obj n) + (write-interesting)))))) + (else + (write obj outport)))) + + ;; Scan computes the initial value of the hash table, which maps each + ;; interesting part of the object to #t if it occurs multiple times, + ;; #f if only once. + (define (scan obj state) + (cond ((not (interesting? obj))) + ((hash-table-exists? state obj) + (hash-table-set! state obj #t)) + (else + (hash-table-set! state obj #f) + (cond ((pair? obj) + (scan (car obj) state) + (scan (cdr obj) state)) + ((vector? obj) + (let ((len (vector-length obj))) + (do ((i 0 (+ 1 i))) + ((= i len)) + (scan (vector-ref obj i) state)))))))) + + (let ((state (make-hash-table eq?))) + (scan obj state) + (hash-table-set! state 'counter 0) + (write-obj obj state))) + +;; A reader that understands the output of the above writer. This has +;; been written by Andreas Rottmann to re-use Guile's built-in reader, +;; with inspiration from Alex Shinn's public-domain implementation of +;; `read-with-shared-structure' found in Chicken's SRFI 38 egg. + +(define* (read-with-shared-structure #:optional (port (current-input-port))) + (let ((parts-table (make-hash-table eqv?))) + + ;; reads chars that match PRED and returns them as a string. + (define (read-some-chars pred initial) + (let iter ((chars initial)) + (let ((c (peek-char port))) + (if (or (eof-object? c) (not (pred c))) + (list->string (reverse chars)) + (iter (cons (read-char port) chars)))))) + + (define (read-hash c port) + (let* ((n (string->number (read-some-chars char-numeric? (list c)))) + (c (read-char port)) + (thunk (hash-table-ref/default parts-table n #f))) + (case c + ((#\=) + (if thunk + (error "Double declaration of part " n)) + (let* ((cell (list #f)) + (thunk (lambda () (car cell)))) + (hash-table-set! parts-table n thunk) + (let ((obj (read port))) + (set-car! cell obj) + obj))) + ((#\#) + (or thunk + (error "Use of undeclared part " n))) + (else + (error "Malformed shared part specifier"))))) + + (with-fluid* %read-hash-procedures (fluid-ref %read-hash-procedures) + (lambda () + (for-each (lambda (digit) + (read-hash-extend digit read-hash)) + '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + (let ((result (read port))) + (if (< 0 (hash-table-size parts-table)) + (patch! result)) + result))))) + +(define (hole? x) (procedure? x)) +(define (fill-hole x) (if (hole? x) (fill-hole (x)) x)) + +(define (patch! x) + (cond + ((pair? x) + (if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch! (car x))) + (if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch! (cdr x)))) + ((vector? x) + (do ((i (- (vector-length x) 1) (- i 1))) + ((< i 0)) + (let ((elt (vector-ref x i))) + (if (hole? elt) + (vector-set! x i (fill-hole elt)) + (patch! elt))))))) diff --git a/module/srfi/srfi-39.scm b/module/srfi/srfi-39.scm new file mode 100644 index 000000000..661ab0fbe --- /dev/null +++ b/module/srfi/srfi-39.scm @@ -0,0 +1,55 @@ +;;; srfi-39.scm --- Parameter objects + +;; Copyright (C) 2004, 2005, 2006, 2008, 2011 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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) + ;; helper procedure not in srfi-39. + #:export (with-parameters*) + #:re-export (make-parameter + parameterize + current-input-port current-output-port current-error-port)) + +(cond-expand-provide (current-module) '(srfi-39)) + +(define (with-parameters* params values thunk) + (let more ((params params) + (values values) + (fluids '()) ;; fluids from each of PARAMS + (convs '())) ;; VALUES with conversion proc applied + (if (null? params) + (with-fluids* fluids convs thunk) + (more (cdr params) (cdr values) + (cons (parameter-fluid (car params)) fluids) + (cons ((parameter-converter (car params)) (car values)) convs))))) diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm new file mode 100644 index 000000000..b2e6f4928 --- /dev/null +++ b/module/srfi/srfi-4.scm @@ -0,0 +1,118 @@ +;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes + +;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010, +;; 2012, 2014 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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) + #:use-module (rnrs bytevectors) + #: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)) + +(cond-expand-provide (current-module) '(srfi-4)) + +;; Need quasisyntax to do this effectively using syntax-case +(define-macro (define-bytevector-type tag infix size) + `(begin + (define (,(symbol-append tag 'vector?) obj) + (and (bytevector? obj) (eq? (array-type obj) ',tag))) + (define (,(symbol-append 'make- tag 'vector) len . fill) + (apply make-srfi-4-vector ',tag len fill)) + (define (,(symbol-append tag 'vector-length) v) + (let ((len (/ (bytevector-length v) ,size))) + (if (integer? len) + len + (error "fractional length" v ',tag ,size)))) + (define (,(symbol-append tag 'vector) . elts) + (,(symbol-append 'list-> tag 'vector) elts)) + (define (,(symbol-append 'list-> tag 'vector) elts) + (let* ((len (length elts)) + (v (,(symbol-append 'make- tag 'vector) len))) + (let lp ((i 0) (elts elts)) + (if (and (< i len) (pair? elts)) + (begin + (,(symbol-append tag 'vector-set!) v i (car elts)) + (lp (1+ i) (cdr elts))) + v)))) + (define (,(symbol-append tag 'vector->list) v) + (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '())) + (if (< i 0) + elts + (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts))))) + (define (,(symbol-append tag 'vector-ref) v i) + (,(symbol-append 'bytevector- infix '-ref) v (* i ,size))) + (define (,(symbol-append tag 'vector-set!) v i x) + (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x)) + (define (,(symbol-append tag 'vector-set!) v i x) + (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x)))) + +(define-bytevector-type u8 u8 1) +(define-bytevector-type s8 s8 1) +(define-bytevector-type u16 u16-native 2) +(define-bytevector-type s16 s16-native 2) +(define-bytevector-type u32 u32-native 4) +(define-bytevector-type s32 s32-native 4) +(define-bytevector-type u64 u64-native 8) +(define-bytevector-type s64 s64-native 8) +(define-bytevector-type f32 ieee-single-native 4) +(define-bytevector-type f64 ieee-double-native 8) diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm new file mode 100644 index 000000000..42bbf33c5 --- /dev/null +++ b/module/srfi/srfi-4/gnu.scm @@ -0,0 +1,80 @@ +;;; Extensions to SRFI-4 + +;; Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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: + +;; Extensions to SRFI-4. Fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-4 gnu) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-4) + #:export (;; Complex numbers with 32- and 64-bit components. + c32vector? make-c32vector c32vector c32vector-length c32vector-ref + c32vector-set! c32vector->list list->c32vector + + c64vector? make-c64vector c64vector c64vector-length c64vector-ref + c64vector-set! c64vector->list list->c64vector + + make-srfi-4-vector + + ;; Somewhat polymorphic conversions. + any->u8vector any->s8vector any->u16vector any->s16vector + any->u32vector any->s32vector any->u64vector any->s64vector + any->f32vector any->f64vector any->c32vector any->c64vector)) + + +(define make-srfi-4-vector (@@ (srfi srfi-4) make-srfi-4-vector)) + +(define (bytevector-c32-native-ref v i) + (make-rectangular (bytevector-ieee-single-native-ref v i) + (bytevector-ieee-single-native-ref v (+ i 4)))) +(define (bytevector-c32-native-set! v i x) + (bytevector-ieee-single-native-set! v i (real-part x)) + (bytevector-ieee-single-native-set! v (+ i 4) (imag-part x))) +(define (bytevector-c64-native-ref v i) + (make-rectangular (bytevector-ieee-double-native-ref v i) + (bytevector-ieee-double-native-ref v (+ i 8)))) +(define (bytevector-c64-native-set! v i x) + (bytevector-ieee-double-native-set! v i (real-part x)) + (bytevector-ieee-double-native-set! v (+ i 8) (imag-part x))) + +((@@ (srfi srfi-4) define-bytevector-type) c32 c32-native 8) +((@@ (srfi srfi-4) define-bytevector-type) c64 c64-native 16) + +(define-macro (define-any->vector . tags) + `(begin + ,@(map (lambda (tag) + `(define (,(symbol-append 'any-> tag 'vector) obj) + (cond ((,(symbol-append tag 'vector?) obj) obj) + ((pair? obj) (,(symbol-append 'list-> tag 'vector) obj)) + ((and (array? obj) (eqv? 1 (array-rank obj))) + (let* ((len (array-length obj)) + (v (,(symbol-append 'make- tag 'vector) len))) + (let lp ((i 0)) + (if (< i len) + (begin + (,(symbol-append tag 'vector-set!) + v i (array-ref obj i)) + (lp (1+ i))) + v)))) + (else (scm-error 'wrong-type-arg #f "" '() (list obj)))))) + tags))) + +(define-any->vector u8 s8 u16 s16 u32 s32 u64 s64 f32 f64 c32 c64) diff --git a/module/srfi/srfi-41.scm b/module/srfi/srfi-41.scm new file mode 100644 index 000000000..3589b359d --- /dev/null +++ b/module/srfi/srfi-41.scm @@ -0,0 +1,505 @@ +;;; srfi-41.scm -- SRFI 41 streams + +;; Copyright (c) 2007 Philip L. Bewig +;; Copyright (c) 2011, 2012, 2013 Free Software Foundation, Inc. + +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES, OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF, OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(define-module (srfi srfi-41) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-26) + #:use-module (ice-9 match) + #:export (stream-null stream-cons stream? stream-null? stream-pair? + stream-car stream-cdr stream-lambda define-stream + list->stream port->stream stream stream->list stream-append + stream-concat stream-constant stream-drop stream-drop-while + stream-filter stream-fold stream-for-each stream-from + stream-iterate stream-length stream-let stream-map + stream-match stream-of stream-range stream-ref stream-reverse + stream-scan stream-take stream-take-while stream-unfold + stream-unfolds stream-zip)) + +(cond-expand-provide (current-module) '(srfi-41)) + +;;; Private supporting functions and macros. + +(define-syntax-rule (must pred obj func msg args ...) + (let ((item obj)) + (unless (pred item) + (throw 'wrong-type-arg func msg (list args ...) (list item))))) + +(define-syntax-rule (must-not pred obj func msg args ...) + (let ((item obj)) + (when (pred item) + (throw 'wrong-type-arg func msg (list args ...) (list item))))) + +(define-syntax-rule (must-every pred objs func msg args ...) + (let ((flunk (remove pred objs))) + (unless (null? flunk) + (throw 'wrong-type-arg func msg (list args ...) flunk)))) + +(define-syntax-rule (first-value expr) + (receive (first . _) expr + first)) + +(define-syntax-rule (second-value expr) + (receive (first second . _) expr + second)) + +(define-syntax-rule (third-value expr) + (receive (first second third . _) expr + third)) + +(define-syntax define-syntax* + (syntax-rules () + ((_ (name . args) body ...) + (define-syntax name (lambda* args body ...))) + ((_ name syntax) + (define-syntax name syntax)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Here we include a copy of the code of srfi-45.scm (but with renamed +;; identifiers), in order to create a new promise type that's disjoint +;; from the promises created by srfi-45. Ideally this should be done +;; using a 'make-promise-type' macro that instantiates a copy of this +;; code, but a psyntax bug in Guile 2.0 prevents this from working +;; properly: <http://bugs.gnu.org/13995>. So for now, we duplicate the +;; code. + +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2003 André van Tonder. All Rights Reserved. + +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(define-record-type stream-promise (make-stream-promise val) stream-promise? + (val stream-promise-val stream-promise-val-set!)) + +(define-record-type stream-value (make-stream-value tag proc) stream-value? + (tag stream-value-tag stream-value-tag-set!) + (proc stream-value-proc stream-value-proc-set!)) + +(define-syntax-rule (stream-lazy exp) + (make-stream-promise (make-stream-value 'lazy (lambda () exp)))) + +(define (stream-eager x) + (make-stream-promise (make-stream-value 'eager x))) + +(define-syntax-rule (stream-delay exp) + (stream-lazy (stream-eager exp))) + +(define (stream-force promise) + (let ((content (stream-promise-val promise))) + (case (stream-value-tag content) + ((eager) (stream-value-proc content)) + ((lazy) (let* ((promise* ((stream-value-proc content))) + (content (stream-promise-val promise))) + (if (not (eqv? (stream-value-tag content) 'eager)) + (begin (stream-value-tag-set! content + (stream-value-tag (stream-promise-val promise*))) + (stream-value-proc-set! content + (stream-value-proc (stream-promise-val promise*))) + (stream-promise-val-set! promise* content))) + (stream-force promise)))))) + +;; +;; End of the copy of the code from srfi-45.scm +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; Primitive stream functions and macros: (streams primitive) + +(define stream? stream-promise?) + +(define %stream-null (cons 'stream 'null)) +(define stream-null (stream-eager %stream-null)) + +(define (stream-null? obj) + (and (stream-promise? obj) + (eqv? (stream-force obj) %stream-null))) + +(define-record-type stream-pare (make-stream-pare kar kdr) stream-pare? + (kar stream-kar) + (kdr stream-kdr)) + +(define (stream-pair? obj) + (and (stream-promise? obj) (stream-pare? (stream-force obj)))) + +(define-syntax-rule (stream-cons obj strm) + (stream-eager (make-stream-pare (stream-delay obj) (stream-lazy strm)))) + +(define (stream-car strm) + (must stream? strm 'stream-car "non-stream") + (let ((pare (stream-force strm))) + (must stream-pare? pare 'stream-car "null stream") + (stream-force (stream-kar pare)))) + +(define (stream-cdr strm) + (must stream? strm 'stream-cdr "non-stream") + (let ((pare (stream-force strm))) + (must stream-pare? pare 'stream-cdr "null stream") + (stream-kdr pare))) + +(define-syntax-rule (stream-lambda formals body0 body1 ...) + (lambda formals (stream-lazy (begin body0 body1 ...)))) + +(define* (stream-promise-visit promise #:key on-eager on-lazy) + (define content (stream-promise-val promise)) + (case (stream-value-tag content) + ((eager) (on-eager (stream-value-proc content))) + ((lazy) (on-lazy (stream-value-proc content))))) + +(set-record-type-printer! stream-promise + (lambda (strm port) + (display "#<stream" port) + (let loop ((strm strm)) + (stream-promise-visit strm + #:on-eager (lambda (pare) + (cond ((eq? pare %stream-null) + (write-char #\> port)) + (else + (write-char #\space port) + (stream-promise-visit (stream-kar pare) + #:on-eager (cut write <> port) + #:on-lazy (lambda (_) (write-char #\? port))) + (loop (stream-kdr pare))))) + #:on-lazy (lambda (_) (display " ...>" port)))))) + +;;; Derived stream functions and macros: (streams derived) + +(define-syntax-rule (define-stream (name . formal) body0 body1 ...) + (define name (stream-lambda formal body0 body1 ...))) + +(define-syntax-rule (stream-let tag ((name val) ...) body1 body2 ...) + ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...)) + +(define (list->stream objs) + (define (list? x) + (or (proper-list? x) (circular-list? x))) + (must list? objs 'list->stream "non-list argument") + (stream-let recur ((objs objs)) + (if (null? objs) stream-null + (stream-cons (car objs) (recur (cdr objs)))))) + +(define* (port->stream #:optional (port (current-input-port))) + (must input-port? port 'port->stream "non-input-port argument") + (stream-let recur () + (let ((c (read-char port))) + (if (eof-object? c) stream-null + (stream-cons c (recur)))))) + +(define-syntax stream + (syntax-rules () + ((_) stream-null) + ((_ x y ...) (stream-cons x (stream y ...))))) + +;; Common helper for the various eager-folding functions, such as +;; stream-fold, stream-drop, stream->list, stream-length, etc. +(define-inlinable (stream-fold-aux proc base strm limit) + (do ((val base (and proc (proc val (stream-car strm)))) + (strm strm (stream-cdr strm)) + (limit limit (and limit (1- limit)))) + ((or (and limit (zero? limit)) (stream-null? strm)) + (values val strm limit)))) + +(define stream->list + (case-lambda + ((strm) (stream->list #f strm)) + ((n strm) + (must stream? strm 'stream->list "non-stream argument") + (when n + (must integer? n 'stream->list "non-integer count") + (must exact? n 'stream->list "inexact count") + (must-not negative? n 'stream->list "negative count")) + (reverse! (first-value (stream-fold-aux xcons '() strm n)))))) + +(define (stream-append . strms) + (must-every stream? strms 'stream-append "non-stream argument") + (stream-let recur ((strms strms)) + (if (null? strms) stream-null + (let ((strm (car strms))) + (if (stream-null? strm) (recur (cdr strms)) + (stream-cons (stream-car strm) + (recur (cons (stream-cdr strm) (cdr strms))))))))) + +(define (stream-concat strms) + (must stream? strms 'stream-concat "non-stream argument") + (stream-let recur ((strms strms)) + (if (stream-null? strms) stream-null + (let ((strm (stream-car strms))) + (must stream? strm 'stream-concat "non-stream object in input stream") + (if (stream-null? strm) (recur (stream-cdr strms)) + (stream-cons (stream-car strm) + (recur (stream-cons (stream-cdr strm) + (stream-cdr strms))))))))) + +(define stream-constant + (case-lambda + (() stream-null) + (objs (list->stream (apply circular-list objs))))) + +(define-syntax* (stream-do x) + (define (end x) + (syntax-case x () + (() #'(if #f #f)) + ((result) #'result) + ((result ...) #'(begin result ...)))) + (define (var-step v s) + (syntax-case s () + (() v) + ((e) #'e) + (_ (syntax-violation 'stream-do "bad step expression" x s)))) + + (syntax-case x () + ((_ ((var init . step) ...) + (test result ...) + expr ...) + (with-syntax ((result (end #'(result ...))) + ((step ...) (map var-step #'(var ...) #'(step ...)))) + #'(stream-let loop ((var init) ...) + (if test result + (begin + expr ... + (loop step ...)))))))) + +(define (stream-drop n strm) + (must integer? n 'stream-drop "non-integer argument") + (must exact? n 'stream-drop "inexact argument") + (must-not negative? n 'stream-drop "negative argument") + (must stream? strm 'stream-drop "non-stream argument") + (second-value (stream-fold-aux #f #f strm n))) + +(define (stream-drop-while pred? strm) + (must procedure? pred? 'stream-drop-while "non-procedural argument") + (must stream? strm 'stream-drop-while "non-stream argument") + (stream-do ((strm strm (stream-cdr strm))) + ((or (stream-null? strm) (not (pred? (stream-car strm)))) strm))) + +(define (stream-filter pred? strm) + (must procedure? pred? 'stream-filter "non-procedural argument") + (must stream? strm 'stream-filter "non-stream argument") + (stream-let recur ((strm strm)) + (cond ((stream-null? strm) stream-null) + ((pred? (stream-car strm)) + (stream-cons (stream-car strm) (recur (stream-cdr strm)))) + (else (recur (stream-cdr strm)))))) + +(define (stream-fold proc base strm) + (must procedure? proc 'stream-fold "non-procedural argument") + (must stream? strm 'stream-fold "non-stream argument") + (first-value (stream-fold-aux proc base strm #f))) + +(define stream-for-each + (case-lambda + ((proc strm) + (must procedure? proc 'stream-for-each "non-procedural argument") + (must stream? strm 'stream-for-each "non-stream argument") + (do ((strm strm (stream-cdr strm))) + ((stream-null? strm)) + (proc (stream-car strm)))) + ((proc strm . rest) + (let ((strms (cons strm rest))) + (must procedure? proc 'stream-for-each "non-procedural argument") + (must-every stream? strms 'stream-for-each "non-stream argument") + (do ((strms strms (map stream-cdr strms))) + ((any stream-null? strms)) + (apply proc (map stream-car strms))))))) + +(define* (stream-from first #:optional (step 1)) + (must number? first 'stream-from "non-numeric starting number") + (must number? step 'stream-from "non-numeric step size") + (stream-let recur ((first first)) + (stream-cons first (recur (+ first step))))) + +(define (stream-iterate proc base) + (must procedure? proc 'stream-iterate "non-procedural argument") + (stream-let recur ((base base)) + (stream-cons base (recur (proc base))))) + +(define (stream-length strm) + (must stream? strm 'stream-length "non-stream argument") + (- -1 (third-value (stream-fold-aux #f #f strm -1)))) + +(define stream-map + (case-lambda + ((proc strm) + (must procedure? proc 'stream-map "non-procedural argument") + (must stream? strm 'stream-map "non-stream argument") + (stream-let recur ((strm strm)) + (if (stream-null? strm) stream-null + (stream-cons (proc (stream-car strm)) + (recur (stream-cdr strm)))))) + ((proc strm . rest) + (let ((strms (cons strm rest))) + (must procedure? proc 'stream-map "non-procedural argument") + (must-every stream? strms 'stream-map "non-stream argument") + (stream-let recur ((strms strms)) + (if (any stream-null? strms) stream-null + (stream-cons (apply proc (map stream-car strms)) + (recur (map stream-cdr strms))))))))) + +(define-syntax* (stream-match x) + (define (make-matcher x) + (syntax-case x () + (() #'(? stream-null?)) + (rest (identifier? #'rest) #'rest) + ((var . rest) (identifier? #'var) + (with-syntax ((next (make-matcher #'rest))) + #'(? (negate stream-null?) + (= stream-car var) + (= stream-cdr next)))))) + (define (make-guarded x fail) + (syntax-case (list x fail) () + (((expr) _) #'expr) + (((guard expr) fail) #'(if guard expr (fail))))) + + (syntax-case x () + ((_ strm-expr (pat . expr) ...) + (with-syntax (((fail ...) (generate-temporaries #'(pat ...)))) + (with-syntax (((matcher ...) (map make-matcher #'(pat ...))) + ((expr ...) (map make-guarded #'(expr ...) #'(fail ...)))) + #'(let ((strm strm-expr)) + (must stream? strm 'stream-match "non-stream argument") + (match strm (matcher (=> fail) expr) ...))))))) + +(define-syntax-rule (stream-of expr rest ...) + (stream-of-aux expr stream-null rest ...)) + +(define-syntax stream-of-aux + (syntax-rules (in is) + ((_ expr base) + (stream-cons expr base)) + ((_ expr base (var in stream) rest ...) + (stream-let recur ((strm stream)) + (if (stream-null? strm) base + (let ((var (stream-car strm))) + (stream-of-aux expr (recur (stream-cdr strm)) rest ...))))) + ((_ expr base (var is exp) rest ...) + (let ((var exp)) (stream-of-aux expr base rest ...))) + ((_ expr base pred? rest ...) + (if pred? (stream-of-aux expr base rest ...) base)))) + +(define* (stream-range first past #:optional step) + (must number? first 'stream-range "non-numeric starting number") + (must number? past 'stream-range "non-numeric ending number") + (when step + (must number? step 'stream-range "non-numeric step size")) + (let* ((step (or step (if (< first past) 1 -1))) + (lt? (if (< 0 step) < >))) + (stream-let recur ((first first)) + (if (lt? first past) + (stream-cons first (recur (+ first step))) + stream-null)))) + +(define (stream-ref strm n) + (must stream? strm 'stream-ref "non-stream argument") + (must integer? n 'stream-ref "non-integer argument") + (must exact? n 'stream-ref "inexact argument") + (must-not negative? n 'stream-ref "negative argument") + (let ((res (stream-drop n strm))) + (must-not stream-null? res 'stream-ref "beyond end of stream") + (stream-car res))) + +(define (stream-reverse strm) + (must stream? strm 'stream-reverse "non-stream argument") + (stream-do ((strm strm (stream-cdr strm)) + (rev stream-null (stream-cons (stream-car strm) rev))) + ((stream-null? strm) rev))) + +(define (stream-scan proc base strm) + (must procedure? proc 'stream-scan "non-procedural argument") + (must stream? strm 'stream-scan "non-stream argument") + (stream-let recur ((base base) (strm strm)) + (if (stream-null? strm) (stream base) + (stream-cons base (recur (proc base (stream-car strm)) + (stream-cdr strm)))))) + +(define (stream-take n strm) + (must stream? strm 'stream-take "non-stream argument") + (must integer? n 'stream-take "non-integer argument") + (must exact? n 'stream-take "inexact argument") + (must-not negative? n 'stream-take "negative argument") + (stream-let recur ((n n) (strm strm)) + (if (or (zero? n) (stream-null? strm)) stream-null + (stream-cons (stream-car strm) (recur (1- n) (stream-cdr strm)))))) + +(define (stream-take-while pred? strm) + (must procedure? pred? 'stream-take-while "non-procedural argument") + (must stream? strm 'stream-take-while "non-stream argument") + (stream-let recur ((strm strm)) + (cond ((stream-null? strm) stream-null) + ((pred? (stream-car strm)) + (stream-cons (stream-car strm) (recur (stream-cdr strm)))) + (else stream-null)))) + +(define (stream-unfold mapper pred? generator base) + (must procedure? mapper 'stream-unfold "non-procedural mapper") + (must procedure? pred? 'stream-unfold "non-procedural pred?") + (must procedure? generator 'stream-unfold "non-procedural generator") + (stream-let recur ((base base)) + (if (pred? base) + (stream-cons (mapper base) (recur (generator base))) + stream-null))) + +(define (stream-unfolds gen seed) + (define-stream (generator-stream seed) + (receive (next . items) (gen seed) + (stream-cons (list->vector items) (generator-stream next)))) + (define-stream (make-result-stream genstrm index) + (define head (vector-ref (stream-car genstrm) index)) + (define-stream (tail) (make-result-stream (stream-cdr genstrm) index)) + (match head + (() stream-null) + (#f (tail)) + ((item) (stream-cons item (tail))) + ((? list? items) (stream-append (list->stream items) (tail))))) + + (must procedure? gen 'stream-unfolds "non-procedural argument") + (let ((genstrm (generator-stream seed))) + (apply values (list-tabulate (vector-length (stream-car genstrm)) + (cut make-result-stream genstrm <>))))) + +(define (stream-zip strm . rest) + (let ((strms (cons strm rest))) + (must-every stream? strms 'stream-zip "non-stream argument") + (stream-let recur ((strms strms)) + (if (any stream-null? strms) stream-null + (stream-cons (map stream-car strms) (recur (map stream-cdr strms))))))) diff --git a/module/srfi/srfi-42.scm b/module/srfi/srfi-42.scm new file mode 100644 index 000000000..c826f6f9e --- /dev/null +++ b/module/srfi/srfi-42.scm @@ -0,0 +1,66 @@ +;;; srfi-42.scm --- Eager comprehensions + +;; Copyright (C) 2010 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 3 of the License, or (at your option) any later version. + +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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, see +;; <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module is not yet documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-42) + #:export (: + :-dispatch-ref + :-dispatch-set! + :char-range + :dispatched + :do + :generator-proc + :integers + :let + :list + :parallel + :port + :range + :real-range + :string + :until + :vector + :while + any?-ec + append-ec + dispatch-union + do-ec + every?-ec + first-ec + fold-ec + fold3-ec + last-ec + list-ec + make-initial-:-dispatch + max-ec + min-ec + product-ec + string-append-ec + string-ec + sum-ec + vector-ec + vector-of-length-ec)) + +(cond-expand-provide (current-module) '(srfi-42)) + +(include-from-path "srfi/srfi-42/ec.scm") diff --git a/module/srfi/srfi-42/ec.scm b/module/srfi/srfi-42/ec.scm new file mode 100644 index 000000000..bc0616ec3 --- /dev/null +++ b/module/srfi/srfi-42/ec.scm @@ -0,0 +1,1053 @@ +; <PLAINTEXT> +; Eager Comprehensions in [outer..inner|expr]-Convention +; ====================================================== +; +; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007 +; Scheme R5RS (incl. macros), SRFI-23 (error). +; +; Loading the implementation into Scheme48 0.57: +; ,open srfi-23 +; ,load ec.scm +; +; Loading the implementation into PLT/DrScheme 317: +; ; File > Open ... "ec.scm", click Execute +; +; Loading the implementation into SCM 5d7: +; (require 'macro) (require 'record) +; (load "ec.scm") +; +; Implementation comments: +; * All local (not exported) identifiers are named ec-<something>. +; * This implementation focuses on portability, performance, +; readability, and simplicity roughly in this order. Design +; decisions related to performance are taken for Scheme48. +; * Alternative implementations, Comments and Warnings are +; mentioned after the definition with a heading. + + +; ========================================================================== +; The fundamental comprehension do-ec +; ========================================================================== +; +; All eager comprehensions are reduced into do-ec and +; all generators are reduced to :do. +; +; We use the following short names for syntactic variables +; q - qualifier +; cc - current continuation, thing to call at the end; +; the CPS is (m (cc ...) arg ...) -> (cc ... expr ...) +; cmd - an expression being evaluated for its side-effects +; expr - an expression +; gen - a generator of an eager comprehension +; ob - outer binding +; oc - outer command +; lb - loop binding +; ne1? - not-end1? (before the payload) +; ib - inner binding +; ic - inner command +; ne2? - not-end2? (after the payload) +; ls - loop step +; etc - more arguments of mixed type + + +; (do-ec q ... cmd) +; handles nested, if/not/and/or, begin, :let, and calls generator +; macros in CPS to transform them into fully decorated :do. +; The code generation for a :do is delegated to do-ec:do. + +(define-syntax do-ec + (syntax-rules (nested if not and or begin :do let) + + ; explicit nesting -> implicit nesting + ((do-ec (nested q ...) etc ...) + (do-ec q ... etc ...) ) + + ; implicit nesting -> fold do-ec + ((do-ec q1 q2 etc1 etc ...) + (do-ec q1 (do-ec q2 etc1 etc ...)) ) + + ; no qualifiers at all -> evaluate cmd once + ((do-ec cmd) + (begin cmd (if #f #f)) ) + +; now (do-ec q cmd) remains + + ; filter -> make conditional + ((do-ec (if test) cmd) + (if test (do-ec cmd)) ) + ((do-ec (not test) cmd) + (if (not test) (do-ec cmd)) ) + ((do-ec (and test ...) cmd) + (if (and test ...) (do-ec cmd)) ) + ((do-ec (or test ...) cmd) + (if (or test ...) (do-ec cmd)) ) + + ; begin -> make a sequence + ((do-ec (begin etc ...) cmd) + (begin etc ... (do-ec cmd)) ) + + ; fully decorated :do-generator -> delegate to do-ec:do + ((do-ec (:do olet lbs ne1? ilet ne2? lss) cmd) + (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) ) + +; anything else -> call generator-macro in CPS; reentry at (*) + + ((do-ec (g arg1 arg ...) cmd) + (g (do-ec:do cmd) arg1 arg ...) ))) + + +; (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) +; generates code for a single fully decorated :do-generator +; with cmd as payload, taking care of special cases. + +(define-syntax do-ec:do + (syntax-rules (:do let) + + ; reentry point (*) -> generate code + ((do-ec:do cmd + (:do (let obs oc ...) + lbs + ne1? + (let ibs ic ...) + ne2? + (ls ...) )) + (ec-simplify + (let obs + oc ... + (let loop lbs + (ec-simplify + (if ne1? + (ec-simplify + (let ibs + ic ... + cmd + (ec-simplify + (if ne2? + (loop ls ...) )))))))))) )) + + +; (ec-simplify <expression>) +; generates potentially more efficient code for <expression>. +; The macro handles if, (begin <command>*), and (let () <command>*) +; and takes care of special cases. + +(define-syntax ec-simplify + (syntax-rules (if not let begin) + +; one- and two-sided if + + ; literal <test> + ((ec-simplify (if #t consequent)) + consequent ) + ((ec-simplify (if #f consequent)) + (if #f #f) ) + ((ec-simplify (if #t consequent alternate)) + consequent ) + ((ec-simplify (if #f consequent alternate)) + alternate ) + + ; (not (not <test>)) + ((ec-simplify (if (not (not test)) consequent)) + (ec-simplify (if test consequent)) ) + ((ec-simplify (if (not (not test)) consequent alternate)) + (ec-simplify (if test consequent alternate)) ) + +; (let () <command>*) + + ; empty <binding spec>* + ((ec-simplify (let () command ...)) + (ec-simplify (begin command ...)) ) + +; begin + + ; flatten use helper (ec-simplify 1 done to-do) + ((ec-simplify (begin command ...)) + (ec-simplify 1 () (command ...)) ) + ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...)) + (ec-simplify 1 done (to-do1 ... to-do2 ...)) ) + ((ec-simplify 1 (done ...) (to-do1 to-do ...)) + (ec-simplify 1 (done ... to-do1) (to-do ...)) ) + + ; exit helper + ((ec-simplify 1 () ()) + (if #f #f) ) + ((ec-simplify 1 (command) ()) + command ) + ((ec-simplify 1 (command1 command ...) ()) + (begin command1 command ...) ) + +; anything else + + ((ec-simplify expression) + expression ))) + + +; ========================================================================== +; The special generators :do, :let, :parallel, :while, and :until +; ========================================================================== + +(define-syntax :do + (syntax-rules () + + ; full decorated -> continue with cc, reentry at (*) + ((:do (cc ...) olet lbs ne1? ilet ne2? lss) + (cc ... (:do olet lbs ne1? ilet ne2? lss)) ) + + ; short form -> fill in default values + ((:do cc lbs ne1? lss) + (:do cc (let ()) lbs ne1? (let ()) #t lss) ))) + + +(define-syntax :let + (syntax-rules (index) + ((:let cc var (index i) expression) + (:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) ) + ((:let cc var expression) + (:do cc (let ((var expression))) () #t (let ()) #f ()) ))) + + +(define-syntax :parallel + (syntax-rules (:do) + ((:parallel cc) + cc ) + ((:parallel cc (g arg1 arg ...) gen ...) + (g (:parallel-1 cc (gen ...)) arg1 arg ...) ))) + +; (:parallel-1 cc (to-do ...) result [ next ] ) +; iterates over to-do by converting the first generator into +; the :do-generator next and merging next into result. + +(define-syntax :parallel-1 ; used as + (syntax-rules (:do let) + + ; process next element of to-do, reentry at (**) + ((:parallel-1 cc ((g arg1 arg ...) gen ...) result) + (g (:parallel-1 cc (gen ...) result) arg1 arg ...) ) + + ; reentry point (**) -> merge next into result + ((:parallel-1 + cc + gens + (:do (let (ob1 ...) oc1 ...) + (lb1 ...) + ne1?1 + (let (ib1 ...) ic1 ...) + ne2?1 + (ls1 ...) ) + (:do (let (ob2 ...) oc2 ...) + (lb2 ...) + ne1?2 + (let (ib2 ...) ic2 ...) + ne2?2 + (ls2 ...) )) + (:parallel-1 + cc + gens + (:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...) + (lb1 ... lb2 ...) + (and ne1?1 ne1?2) + (let (ib1 ... ib2 ...) ic1 ... ic2 ...) + (and ne2?1 ne2?2) + (ls1 ... ls2 ...) ))) + + ; no more gens -> continue with cc, reentry at (*) + ((:parallel-1 (cc ...) () result) + (cc ... result) ))) + +(define-syntax :while + (syntax-rules () + ((:while cc (g arg1 arg ...) test) + (g (:while-1 cc test) arg1 arg ...) ))) + +; (:while-1 cc test (:do ...)) +; modifies the fully decorated :do-generator such that it +; runs while test is a true value. +; The original implementation just replaced ne1? by +; (and ne1? test) as follows: +; +; (define-syntax :while-1 +; (syntax-rules (:do) +; ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss)) +; (:do cc olet lbs (and ne1? test) ilet ne2? lss) ))) +; +; Bug #1: +; Unfortunately, this code is wrong because ne1? may depend +; in the inner bindings introduced in ilet, but ne1? is evaluated +; outside of the inner bindings. (Refer to the specification of +; :do to see the structure.) +; The problem manifests itself (as sunnan@handgranat.org +; observed, 25-Apr-2005) when the :list-generator is modified: +; +; (do-ec (:while (:list x '(1 2)) (= x 1)) (display x)). +; +; In order to generate proper code, we introduce temporary +; variables saving the values of the inner bindings. The inner +; bindings are executed in a new ne1?, which also evaluates ne1? +; outside the scope of the inner bindings, then the inner commands +; are executed (possibly changing the variables), and then the +; values of the inner bindings are saved and (and ne1? test) is +; returned. In the new ilet, the inner variables are bound and +; initialized and their values are restored. So we construct: +; +; (let (ob .. (ib-tmp #f) ...) +; oc ... +; (let loop (lb ...) +; (if (let (ne1?-value ne1?) +; (let ((ib-var ib-rhs) ...) +; ic ... +; (set! ib-tmp ib-var) ...) +; (and ne1?-value test)) +; (let ((ib-var ib-tmp) ...) +; /payload/ +; (if ne2? +; (loop ls ...) ))))) +; +; Bug #2: +; Unfortunately, the above expansion is still incorrect (as Jens-Axel +; Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even +; if ne1?-value is #f, indicating that the loop has ended. +; The problem manifests itself in the following example: +; +; (do-ec (:while (:list x '(1)) #t) (display x)) +; +; Which iterates :list beyond exhausting the list '(1). +; +; For the fix, we follow Jens-Axel's approach of guarding the evaluation +; of ib-rhs with a check on ne1?-value. + +(define-syntax :while-1 + (syntax-rules (:do let) + ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss)) + (:while-2 cc test () () () (:do olet lbs ne1? ilet ne2? lss))))) + +(define-syntax :while-2 + (syntax-rules (:do let) + ((:while-2 cc + test + (ib-let ...) + (ib-save ...) + (ib-restore ...) + (:do olet + lbs + ne1? + (let ((ib-var ib-rhs) ib ...) ic ...) + ne2? + lss)) + (:while-2 cc + test + (ib-let ... (ib-tmp #f)) + (ib-save ... (ib-var ib-rhs)) + (ib-restore ... (ib-var ib-tmp)) + (:do olet + lbs + ne1? + (let (ib ...) ic ... (set! ib-tmp ib-var)) + ne2? + lss))) + ((:while-2 cc + test + (ib-let ...) + (ib-save ...) + (ib-restore ...) + (:do (let (ob ...) oc ...) lbs ne1? (let () ic ...) ne2? lss)) + (:do cc + (let (ob ... ib-let ...) oc ...) + lbs + (let ((ne1?-value ne1?)) + (and ne1?-value + (let (ib-save ...) + ic ... + test))) + (let (ib-restore ...)) + ne2? + lss)))) + + +(define-syntax :until + (syntax-rules () + ((:until cc (g arg1 arg ...) test) + (g (:until-1 cc test) arg1 arg ...) ))) + +(define-syntax :until-1 + (syntax-rules (:do) + ((:until-1 cc test (:do olet lbs ne1? ilet ne2? lss)) + (:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) ))) + + +; ========================================================================== +; The typed generators :list :string :vector etc. +; ========================================================================== + +(define-syntax :list + (syntax-rules (index) + ((:list cc var (index i) arg ...) + (:parallel cc (:list var arg ...) (:integers i)) ) + ((:list cc var arg1 arg2 arg ...) + (:list cc var (append arg1 arg2 arg ...)) ) + ((:list cc var arg) + (:do cc + (let ()) + ((t arg)) + (not (null? t)) + (let ((var (car t)))) + #t + ((cdr t)) )))) + + +(define-syntax :string + (syntax-rules (index) + ((:string cc var (index i) arg) + (:do cc + (let ((str arg) (len 0)) + (set! len (string-length str))) + ((i 0)) + (< i len) + (let ((var (string-ref str i)))) + #t + ((+ i 1)) )) + ((:string cc var (index i) arg1 arg2 arg ...) + (:string cc var (index i) (string-append arg1 arg2 arg ...)) ) + ((:string cc var arg1 arg ...) + (:string cc var (index i) arg1 arg ...) ))) + +; Alternative: An implementation in the style of :vector can also +; be used for :string. However, it is less interesting as the +; overhead of string-append is much less than for 'vector-append'. + + +(define-syntax :vector + (syntax-rules (index) + ((:vector cc var arg) + (:vector cc var (index i) arg) ) + ((:vector cc var (index i) arg) + (:do cc + (let ((vec arg) (len 0)) + (set! len (vector-length vec))) + ((i 0)) + (< i len) + (let ((var (vector-ref vec i)))) + #t + ((+ i 1)) )) + + ((:vector cc var (index i) arg1 arg2 arg ...) + (:parallel cc (:vector cc var arg1 arg2 arg ...) (:integers i)) ) + ((:vector cc var arg1 arg2 arg ...) + (:do cc + (let ((vec #f) + (len 0) + (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) )) + ((k 0)) + (if (< k len) + #t + (if (null? vecs) + #f + (begin (set! vec (car vecs)) + (set! vecs (cdr vecs)) + (set! len (vector-length vec)) + (set! k 0) + #t ))) + (let ((var (vector-ref vec k)))) + #t + ((+ k 1)) )))) + +(define (ec-:vector-filter vecs) + (if (null? vecs) + '() + (if (zero? (vector-length (car vecs))) + (ec-:vector-filter (cdr vecs)) + (cons (car vecs) (ec-:vector-filter (cdr vecs))) ))) + +; Alternative: A simpler implementation for :vector uses vector->list +; append and :list in the multi-argument case. Please refer to the +; 'design.scm' for more details. + + +(define-syntax :integers + (syntax-rules (index) + ((:integers cc var (index i)) + (:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) ) + ((:integers cc var) + (:do cc ((var 0)) #t ((+ var 1))) ))) + + +(define-syntax :range + (syntax-rules (index) + + ; handle index variable and add optional args + ((:range cc var (index i) arg1 arg ...) + (:parallel cc (:range var arg1 arg ...) (:integers i)) ) + ((:range cc var arg1) + (:range cc var 0 arg1 1) ) + ((:range cc var arg1 arg2) + (:range cc var arg1 arg2 1) ) + +; special cases (partially evaluated by hand from general case) + + ((:range cc var 0 arg2 1) + (:do cc + (let ((b arg2)) + (if (not (and (integer? b) (exact? b))) + (error + "arguments of :range are not exact integer " + "(use :real-range?)" 0 b 1 ))) + ((var 0)) + (< var b) + (let ()) + #t + ((+ var 1)) )) + + ((:range cc var 0 arg2 -1) + (:do cc + (let ((b arg2)) + (if (not (and (integer? b) (exact? b))) + (error + "arguments of :range are not exact integer " + "(use :real-range?)" 0 b 1 ))) + ((var 0)) + (> var b) + (let ()) + #t + ((- var 1)) )) + + ((:range cc var arg1 arg2 1) + (:do cc + (let ((a arg1) (b arg2)) + (if (not (and (integer? a) (exact? a) + (integer? b) (exact? b) )) + (error + "arguments of :range are not exact integer " + "(use :real-range?)" a b 1 )) ) + ((var a)) + (< var b) + (let ()) + #t + ((+ var 1)) )) + + ((:range cc var arg1 arg2 -1) + (:do cc + (let ((a arg1) (b arg2) (s -1) (stop 0)) + (if (not (and (integer? a) (exact? a) + (integer? b) (exact? b) )) + (error + "arguments of :range are not exact integer " + "(use :real-range?)" a b -1 )) ) + ((var a)) + (> var b) + (let ()) + #t + ((- var 1)) )) + +; the general case + + ((:range cc var arg1 arg2 arg3) + (:do cc + (let ((a arg1) (b arg2) (s arg3) (stop 0)) + (if (not (and (integer? a) (exact? a) + (integer? b) (exact? b) + (integer? s) (exact? s) )) + (error + "arguments of :range are not exact integer " + "(use :real-range?)" a b s )) + (if (zero? s) + (error "step size must not be zero in :range") ) + (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) ) + ((var a)) + (not (= var stop)) + (let ()) + #t + ((+ var s)) )))) + +; Comment: The macro :range inserts some code to make sure the values +; are exact integers. This overhead has proven very helpful for +; saving users from themselves. + + +(define-syntax :real-range + (syntax-rules (index) + + ; add optional args and index variable + ((:real-range cc var arg1) + (:real-range cc var (index i) 0 arg1 1) ) + ((:real-range cc var (index i) arg1) + (:real-range cc var (index i) 0 arg1 1) ) + ((:real-range cc var arg1 arg2) + (:real-range cc var (index i) arg1 arg2 1) ) + ((:real-range cc var (index i) arg1 arg2) + (:real-range cc var (index i) arg1 arg2 1) ) + ((:real-range cc var arg1 arg2 arg3) + (:real-range cc var (index i) arg1 arg2 arg3) ) + + ; the fully qualified case + ((:real-range cc var (index i) arg1 arg2 arg3) + (:do cc + (let ((a arg1) (b arg2) (s arg3) (istop 0)) + (if (not (and (real? a) (real? b) (real? s))) + (error "arguments of :real-range are not real" a b s) ) + (if (and (exact? a) (or (not (exact? b)) (not (exact? s)))) + (set! a (exact->inexact a)) ) + (set! istop (/ (- b a) s)) ) + ((i 0)) + (< i istop) + (let ((var (+ a (* s i))))) + #t + ((+ i 1)) )))) + +; Comment: The macro :real-range adapts the exactness of the start +; value in case any of the other values is inexact. This is a +; precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0). + + +(define-syntax :char-range + (syntax-rules (index) + ((:char-range cc var (index i) arg1 arg2) + (:parallel cc (:char-range var arg1 arg2) (:integers i)) ) + ((:char-range cc var arg1 arg2) + (:do cc + (let ((imax (char->integer arg2)))) + ((i (char->integer arg1))) + (<= i imax) + (let ((var (integer->char i)))) + #t + ((+ i 1)) )))) + +; Warning: There is no R5RS-way to implement the :char-range generator +; because the integers obtained by char->integer are not necessarily +; consecutive. We simply assume this anyhow for illustration. + + +(define-syntax :port + (syntax-rules (index) + ((:port cc var (index i) arg1 arg ...) + (:parallel cc (:port var arg1 arg ...) (:integers i)) ) + ((:port cc var arg) + (:port cc var arg read) ) + ((:port cc var arg1 arg2) + (:do cc + (let ((port arg1) (read-proc arg2))) + ((var (read-proc port))) + (not (eof-object? var)) + (let ()) + #t + ((read-proc port)) )))) + + +; ========================================================================== +; The typed generator :dispatched and utilities for constructing dispatchers +; ========================================================================== + +(define-syntax :dispatched + (syntax-rules (index) + ((:dispatched cc var (index i) dispatch arg1 arg ...) + (:parallel cc + (:integers i) + (:dispatched var dispatch arg1 arg ...) )) + ((:dispatched cc var dispatch arg1 arg ...) + (:do cc + (let ((d dispatch) + (args (list arg1 arg ...)) + (g #f) + (empty (list #f)) ) + (set! g (d args)) + (if (not (procedure? g)) + (error "unrecognized arguments in dispatching" + args + (d '()) ))) + ((var (g empty))) + (not (eq? var empty)) + (let ()) + #t + ((g empty)) )))) + +; Comment: The unique object empty is created as a newly allocated +; non-empty list. It is compared using eq? which distinguishes +; the object from any other object, according to R5RS 6.1. + + +(define-syntax :generator-proc + (syntax-rules (:do let) + + ; call g with a variable, reentry at (**) + ((:generator-proc (g arg ...)) + (g (:generator-proc var) var arg ...) ) + + ; reentry point (**) -> make the code from a single :do + ((:generator-proc + var + (:do (let obs oc ...) + ((lv li) ...) + ne1? + (let ((i v) ...) ic ...) + ne2? + (ls ...)) ) + (ec-simplify + (let obs + oc ... + (let ((lv li) ... (ne2 #t)) + (ec-simplify + (let ((i #f) ...) ; v not yet valid + (lambda (empty) + (if (and ne1? ne2) + (ec-simplify + (begin + (set! i v) ... + ic ... + (let ((value var)) + (ec-simplify + (if ne2? + (ec-simplify + (begin (set! lv ls) ...) ) + (set! ne2 #f) )) + value ))) + empty )))))))) + + ; silence warnings of some macro expanders + ((:generator-proc var) + (error "illegal macro call") ))) + + +(define (dispatch-union d1 d2) + (lambda (args) + (let ((g1 (d1 args)) (g2 (d2 args))) + (if g1 + (if g2 + (if (null? args) + (append (if (list? g1) g1 (list g1)) + (if (list? g2) g2 (list g2)) ) + (error "dispatching conflict" args (d1 '()) (d2 '())) ) + g1 ) + (if g2 g2 #f) )))) + + +; ========================================================================== +; The dispatching generator : +; ========================================================================== + +(define (make-initial-:-dispatch) + (lambda (args) + (case (length args) + ((0) 'SRFI42) + ((1) (let ((a1 (car args))) + (cond + ((list? a1) + (:generator-proc (:list a1)) ) + ((string? a1) + (:generator-proc (:string a1)) ) + ((vector? a1) + (:generator-proc (:vector a1)) ) + ((and (integer? a1) (exact? a1)) + (:generator-proc (:range a1)) ) + ((real? a1) + (:generator-proc (:real-range a1)) ) + ((input-port? a1) + (:generator-proc (:port a1)) ) + (else + #f )))) + ((2) (let ((a1 (car args)) (a2 (cadr args))) + (cond + ((and (list? a1) (list? a2)) + (:generator-proc (:list a1 a2)) ) + ((and (string? a1) (string? a1)) + (:generator-proc (:string a1 a2)) ) + ((and (vector? a1) (vector? a2)) + (:generator-proc (:vector a1 a2)) ) + ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2)) + (:generator-proc (:range a1 a2)) ) + ((and (real? a1) (real? a2)) + (:generator-proc (:real-range a1 a2)) ) + ((and (char? a1) (char? a2)) + (:generator-proc (:char-range a1 a2)) ) + ((and (input-port? a1) (procedure? a2)) + (:generator-proc (:port a1 a2)) ) + (else + #f )))) + ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args))) + (cond + ((and (list? a1) (list? a2) (list? a3)) + (:generator-proc (:list a1 a2 a3)) ) + ((and (string? a1) (string? a1) (string? a3)) + (:generator-proc (:string a1 a2 a3)) ) + ((and (vector? a1) (vector? a2) (vector? a3)) + (:generator-proc (:vector a1 a2 a3)) ) + ((and (integer? a1) (exact? a1) + (integer? a2) (exact? a2) + (integer? a3) (exact? a3)) + (:generator-proc (:range a1 a2 a3)) ) + ((and (real? a1) (real? a2) (real? a3)) + (:generator-proc (:real-range a1 a2 a3)) ) + (else + #f )))) + (else + (letrec ((every? + (lambda (pred args) + (if (null? args) + #t + (and (pred (car args)) + (every? pred (cdr args)) ))))) + (cond + ((every? list? args) + (:generator-proc (:list (apply append args))) ) + ((every? string? args) + (:generator-proc (:string (apply string-append args))) ) + ((every? vector? args) + (:generator-proc (:list (apply append (map vector->list args)))) ) + (else + #f ))))))) + +(define :-dispatch + (make-initial-:-dispatch) ) + +(define (:-dispatch-ref) + :-dispatch ) + +(define (:-dispatch-set! dispatch) + (if (not (procedure? dispatch)) + (error "not a procedure" dispatch) ) + (set! :-dispatch dispatch) ) + +(define-syntax : + (syntax-rules (index) + ((: cc var (index i) arg1 arg ...) + (:dispatched cc var (index i) :-dispatch arg1 arg ...) ) + ((: cc var arg1 arg ...) + (:dispatched cc var :-dispatch arg1 arg ...) ))) + + +; ========================================================================== +; The utility comprehensions fold-ec, fold3-ec +; ========================================================================== + +(define-syntax fold3-ec + (syntax-rules (nested) + ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...) + (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) ) + ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...) + (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) ) + ((fold3-ec x0 expression f1 f2) + (fold3-ec x0 (nested) expression f1 f2) ) + + ((fold3-ec x0 qualifier expression f1 f2) + (let ((result #f) (empty #t)) + (do-ec qualifier + (let ((value expression)) ; don't duplicate + (if empty + (begin (set! result (f1 value)) + (set! empty #f) ) + (set! result (f2 value result)) ))) + (if empty x0 result) )))) + + +(define-syntax fold-ec + (syntax-rules (nested) + ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...) + (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) ) + ((fold-ec x0 q1 q2 etc1 etc2 etc ...) + (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) ) + ((fold-ec x0 expression f2) + (fold-ec x0 (nested) expression f2) ) + + ((fold-ec x0 qualifier expression f2) + (let ((result x0)) + (do-ec qualifier (set! result (f2 expression result))) + result )))) + + +; ========================================================================== +; The comprehensions list-ec string-ec vector-ec etc. +; ========================================================================== + +(define-syntax list-ec + (syntax-rules () + ((list-ec etc1 etc ...) + (reverse (fold-ec '() etc1 etc ... cons)) ))) + +; Alternative: Reverse can safely be replaced by reverse! if you have it. +; +; Alternative: It is possible to construct the result in the correct order +; using set-cdr! to add at the tail. This removes the overhead of copying +; at the end, at the cost of more book-keeping. + + +(define-syntax append-ec + (syntax-rules () + ((append-ec etc1 etc ...) + (apply append (list-ec etc1 etc ...)) ))) + +(define-syntax string-ec + (syntax-rules () + ((string-ec etc1 etc ...) + (list->string (list-ec etc1 etc ...)) ))) + +; Alternative: For very long strings, the intermediate list may be a +; problem. A more space-aware implementation collect the characters +; in an intermediate list and when this list becomes too large it is +; converted into an intermediate string. At the end, the intermediate +; strings are concatenated with string-append. + + +(define-syntax string-append-ec + (syntax-rules () + ((string-append-ec etc1 etc ...) + (apply string-append (list-ec etc1 etc ...)) ))) + +(define-syntax vector-ec + (syntax-rules () + ((vector-ec etc1 etc ...) + (list->vector (list-ec etc1 etc ...)) ))) + +; Comment: A similar approach as for string-ec can be used for vector-ec. +; However, the space overhead for the intermediate list is much lower +; than for string-ec and as there is no vector-append, the intermediate +; vectors must be copied explicitly. + +(define-syntax vector-of-length-ec + (syntax-rules (nested) + ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...) + (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) ) + ((vector-of-length-ec k q1 q2 etc1 etc ...) + (vector-of-length-ec k (nested q1 q2) etc1 etc ...) ) + ((vector-of-length-ec k expression) + (vector-of-length-ec k (nested) expression) ) + + ((vector-of-length-ec k qualifier expression) + (let ((len k)) + (let ((vec (make-vector len)) + (i 0) ) + (do-ec qualifier + (if (< i len) + (begin (vector-set! vec i expression) + (set! i (+ i 1)) ) + (error "vector is too short for the comprehension") )) + (if (= i len) + vec + (error "vector is too long for the comprehension") )))))) + + +(define-syntax sum-ec + (syntax-rules () + ((sum-ec etc1 etc ...) + (fold-ec (+) etc1 etc ... +) ))) + +(define-syntax product-ec + (syntax-rules () + ((product-ec etc1 etc ...) + (fold-ec (*) etc1 etc ... *) ))) + +(define-syntax min-ec + (syntax-rules () + ((min-ec etc1 etc ...) + (fold3-ec (min) etc1 etc ... min min) ))) + +(define-syntax max-ec + (syntax-rules () + ((max-ec etc1 etc ...) + (fold3-ec (max) etc1 etc ... max max) ))) + +(define-syntax last-ec + (syntax-rules (nested) + ((last-ec default (nested q1 ...) q etc1 etc ...) + (last-ec default (nested q1 ... q) etc1 etc ...) ) + ((last-ec default q1 q2 etc1 etc ...) + (last-ec default (nested q1 q2) etc1 etc ...) ) + ((last-ec default expression) + (last-ec default (nested) expression) ) + + ((last-ec default qualifier expression) + (let ((result default)) + (do-ec qualifier (set! result expression)) + result )))) + + +; ========================================================================== +; The fundamental early-stopping comprehension first-ec +; ========================================================================== + +(define-syntax first-ec + (syntax-rules (nested) + ((first-ec default (nested q1 ...) q etc1 etc ...) + (first-ec default (nested q1 ... q) etc1 etc ...) ) + ((first-ec default q1 q2 etc1 etc ...) + (first-ec default (nested q1 q2) etc1 etc ...) ) + ((first-ec default expression) + (first-ec default (nested) expression) ) + + ((first-ec default qualifier expression) + (let ((result default) (stop #f)) + (ec-guarded-do-ec + stop + (nested qualifier) + (begin (set! result expression) + (set! stop #t) )) + result )))) + +; (ec-guarded-do-ec stop (nested q ...) cmd) +; constructs (do-ec q ... cmd) where the generators gen in q ... are +; replaced by (:until gen stop). + +(define-syntax ec-guarded-do-ec + (syntax-rules (nested if not and or begin) + + ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd) + (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) ) + + ((ec-guarded-do-ec stop (nested (if test) q ...) cmd) + (if test (ec-guarded-do-ec stop (nested q ...) cmd)) ) + ((ec-guarded-do-ec stop (nested (not test) q ...) cmd) + (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) ) + ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd) + (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) ) + ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd) + (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) ) + + ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd) + (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) ) + + ((ec-guarded-do-ec stop (nested gen q ...) cmd) + (do-ec + (:until gen stop) + (ec-guarded-do-ec stop (nested q ...) cmd) )) + + ((ec-guarded-do-ec stop (nested) cmd) + (do-ec cmd) ))) + +; Alternative: Instead of modifying the generator with :until, it is +; possible to use call-with-current-continuation: +; +; (define-synatx first-ec +; ...same as above... +; ((first-ec default qualifier expression) +; (call-with-current-continuation +; (lambda (cc) +; (do-ec qualifier (cc expression)) +; default ))) )) +; +; This is much simpler but not necessarily as efficient. + + +; ========================================================================== +; The early-stopping comprehensions any?-ec every?-ec +; ========================================================================== + +(define-syntax any?-ec + (syntax-rules (nested) + ((any?-ec (nested q1 ...) q etc1 etc ...) + (any?-ec (nested q1 ... q) etc1 etc ...) ) + ((any?-ec q1 q2 etc1 etc ...) + (any?-ec (nested q1 q2) etc1 etc ...) ) + ((any?-ec expression) + (any?-ec (nested) expression) ) + + ((any?-ec qualifier expression) + (first-ec #f qualifier (if expression) #t) ))) + +(define-syntax every?-ec + (syntax-rules (nested) + ((every?-ec (nested q1 ...) q etc1 etc ...) + (every?-ec (nested q1 ... q) etc1 etc ...) ) + ((every?-ec q1 q2 etc1 etc ...) + (every?-ec (nested q1 q2) etc1 etc ...) ) + ((every?-ec expression) + (every?-ec (nested) expression) ) + + ((every?-ec qualifier expression) + (first-ec #t qualifier (if (not expression)) #f) ))) + diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm new file mode 100644 index 000000000..e1bf19e9d --- /dev/null +++ b/module/srfi/srfi-43.scm @@ -0,0 +1,1081 @@ +;;; srfi-43.scm -- SRFI 43 Vector library + +;; Copyright (C) 2014, 2018 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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: Mark H Weaver <mhw@netris.org> + +(define-module (srfi srfi-43) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-8) + #:re-export (make-vector vector vector? vector-ref vector-set! + vector-length) + #:replace (vector-copy vector-fill! list->vector vector->list) + #:export (vector-empty? vector= vector-unfold vector-unfold-right + vector-reverse-copy + vector-append vector-concatenate + vector-fold vector-fold-right + vector-map vector-map! + vector-for-each vector-count + vector-index vector-index-right + vector-skip vector-skip-right + vector-binary-search + vector-any vector-every + vector-swap! vector-reverse! + vector-copy! vector-reverse-copy! + reverse-vector->list + reverse-list->vector)) + +(cond-expand-provide (current-module) '(srfi-43)) + +(define-syntax error-from + (lambda (stx) + (syntax-case stx (quote) + ((_ 'who msg arg ...) + #`(error #,(string-append (symbol->string (syntax->datum #'who)) + ": " + (syntax->datum #'msg)) + arg ...))))) + +(define-syntax-rule (assert-nonneg-exact-integer k who) + (unless (and (exact-integer? k) + (not (negative? k))) + (error-from who "expected non-negative exact integer, got" k))) + +(define-syntax-rule (assert-procedure f who) + (unless (procedure? f) + (error-from who "expected procedure, got" f))) + +(define-syntax-rule (assert-vector v who) + (unless (vector? v) + (error-from who "expected vector, got" v))) + +(define-syntax-rule (assert-valid-index i len who) + (unless (and (exact-integer? i) + (<= 0 i len)) + (error-from who "invalid index" i))) + +(define-syntax-rule (assert-valid-start start len who) + (unless (and (exact-integer? start) + (<= 0 start len)) + (error-from who "invalid start index" start))) + +(define-syntax-rule (assert-valid-range start end len who) + (unless (and (exact-integer? start) + (exact-integer? end) + (<= 0 start end len)) + (error-from who "invalid index range" start end))) + +(define-syntax-rule (assert-vectors vs who) + (let loop ((vs vs)) + (unless (null? vs) + (assert-vector (car vs) who) + (loop (cdr vs))))) + +;; Return the length of the shortest vector in VS. +;; VS must have at least one element. +(define (min-length vs) + (let loop ((vs (cdr vs)) + (result (vector-length (car vs)))) + (if (null? vs) + result + (loop (cdr vs) (min result (vector-length (car vs))))))) + +;; Return a list of the Ith elements of the vectors in VS. +(define (vectors-ref vs i) + (let loop ((vs vs) (xs '())) + (if (null? vs) + (reverse! xs) + (loop (cdr vs) (cons (vector-ref (car vs) i) + xs))))) + +(define vector-unfold + (case-lambda + "(vector-unfold f length initial-seed ...) -> vector + +The fundamental vector constructor. Create a vector whose length is +LENGTH and iterates across each index k from 0 up to LENGTH - 1, +applying F at each iteration to the current index and current seeds, in +that order, to receive n + 1 values: the element to put in the kth slot +of the new vector, and n new seeds for the next iteration. It is an +error for the number of seeds to vary between iterations." + ((f len) + (assert-procedure f 'vector-unfold) + (assert-nonneg-exact-integer len 'vector-unfold) + (let ((v (make-vector len))) + (let loop ((i 0)) + (unless (= i len) + (vector-set! v i (f i)) + (loop (+ i 1)))) + v)) + ((f len seed) + (assert-procedure f 'vector-unfold) + (assert-nonneg-exact-integer len 'vector-unfold) + (let ((v (make-vector len))) + (let loop ((i 0) (seed seed)) + (unless (= i len) + (receive (x seed) (f i seed) + (vector-set! v i x) + (loop (+ i 1) seed)))) + v)) + ((f len seed1 seed2) + (assert-procedure f 'vector-unfold) + (assert-nonneg-exact-integer len 'vector-unfold) + (let ((v (make-vector len))) + (let loop ((i 0) (seed1 seed1) (seed2 seed2)) + (unless (= i len) + (receive (x seed1 seed2) (f i seed1 seed2) + (vector-set! v i x) + (loop (+ i 1) seed1 seed2)))) + v)) + ((f len . seeds) + (assert-procedure f 'vector-unfold) + (assert-nonneg-exact-integer len 'vector-unfold) + (let ((v (make-vector len))) + (let loop ((i 0) (seeds seeds)) + (unless (= i len) + (receive (x . seeds) (apply f i seeds) + (vector-set! v i x) + (loop (+ i 1) seeds)))) + v)))) + +(define vector-unfold-right + (case-lambda + "(vector-unfold-right f length initial-seed ...) -> vector + +The fundamental vector constructor. Create a vector whose length is +LENGTH and iterates across each index k from LENGTH - 1 down to 0, +applying F at each iteration to the current index and current seeds, in +that order, to receive n + 1 values: the element to put in the kth slot +of the new vector, and n new seeds for the next iteration. It is an +error for the number of seeds to vary between iterations." + ((f len) + (assert-procedure f 'vector-unfold-right) + (assert-nonneg-exact-integer len 'vector-unfold-right) + (let ((v (make-vector len))) + (let loop ((i (- len 1))) + (unless (negative? i) + (vector-set! v i (f i)) + (loop (- i 1)))) + v)) + ((f len seed) + (assert-procedure f 'vector-unfold-right) + (assert-nonneg-exact-integer len 'vector-unfold-right) + (let ((v (make-vector len))) + (let loop ((i (- len 1)) (seed seed)) + (unless (negative? i) + (receive (x seed) (f i seed) + (vector-set! v i x) + (loop (- i 1) seed)))) + v)) + ((f len seed1 seed2) + (assert-procedure f 'vector-unfold-right) + (assert-nonneg-exact-integer len 'vector-unfold-right) + (let ((v (make-vector len))) + (let loop ((i (- len 1)) (seed1 seed1) (seed2 seed2)) + (unless (negative? i) + (receive (x seed1 seed2) (f i seed1 seed2) + (vector-set! v i x) + (loop (- i 1) seed1 seed2)))) + v)) + ((f len . seeds) + (assert-procedure f 'vector-unfold-right) + (assert-nonneg-exact-integer len 'vector-unfold-right) + (let ((v (make-vector len))) + (let loop ((i (- len 1)) (seeds seeds)) + (unless (negative? i) + (receive (x . seeds) (apply f i seeds) + (vector-set! v i x) + (loop (- i 1) seeds)))) + v)))) + +(define guile-vector-copy (@ (guile) vector-copy)) + +;; TODO: Enhance Guile core 'vector-copy' to do this. +(define vector-copy + (case-lambda* + "(vector-copy vec [start [end [fill]]]) -> vector + +Allocate a new vector whose length is END - START and fills it with +elements from vec, taking elements from vec starting at index START +and stopping at index END. START defaults to 0 and END defaults to +the value of (vector-length VEC). If END extends beyond the length of +VEC, the slots in the new vector that obviously cannot be filled by +elements from VEC are filled with FILL, whose default value is +unspecified." + ((v) (guile-vector-copy v)) + ((v start) + (assert-vector v 'vector-copy) + (let ((len (vector-length v))) + (assert-valid-start start len 'vector-copy) + (let ((result (make-vector (- len start)))) + (vector-move-left! v start len result 0) + result))) + ((v start end #:optional (fill *unspecified*)) + (assert-vector v 'vector-copy) + (let ((len (vector-length v))) + (unless (and (exact-integer? start) + (exact-integer? end) + (<= 0 start end)) + (error-from 'vector-copy "invalid index range" start end)) + (let ((result (make-vector (- end start) fill))) + (vector-move-left! v start (min end len) result 0) + result))))) + +(define vector-reverse-copy + (let () + (define (%vector-reverse-copy vec start end) + (let* ((len (- end start)) + (result (make-vector len))) + (let loop ((i 0) (j (- end 1))) + (unless (= i len) + (vector-set! result i (vector-ref vec j)) + (loop (+ i 1) (- j 1)))) + result)) + (case-lambda + "(vector-reverse-copy vec [start [end]]) -> vector + +Allocate a new vector whose length is END - START and fills it with +elements from vec, taking elements from vec in reverse order starting +at index START and stopping at index END. START defaults to 0 and END +defaults to the value of (vector-length VEC)." + ((vec) + (assert-vector vec 'vector-reverse-copy) + (%vector-reverse-copy vec 0 (vector-length vec))) + ((vec start) + (assert-vector vec 'vector-reverse-copy) + (let ((len (vector-length vec))) + (assert-valid-start start len 'vector-reverse-copy) + (%vector-reverse-copy vec start len))) + ((vec start end) + (assert-vector vec 'vector-reverse-copy) + (let ((len (vector-length vec))) + (assert-valid-range start end len 'vector-reverse-copy) + (%vector-reverse-copy vec start end)))))) + +(define (%vector-concatenate vs) + (let* ((result-len (let loop ((vs vs) (len 0)) + (if (null? vs) + len + (loop (cdr vs) (+ len (vector-length (car vs))))))) + (result (make-vector result-len))) + (let loop ((vs vs) (pos 0)) + (unless (null? vs) + (let* ((v (car vs)) + (len (vector-length v))) + (vector-move-left! v 0 len result pos) + (loop (cdr vs) (+ pos len))))) + result)) + +(define vector-append + (case-lambda + "(vector-append vec ...) -> vector + +Return a newly allocated vector that contains all elements in order +from the subsequent locations in VEC ..." + (() (vector)) + ((v) + (assert-vector v 'vector-append) + (guile-vector-copy v)) + ((v1 v2) + (assert-vector v1 'vector-append) + (assert-vector v2 'vector-append) + (let ((len1 (vector-length v1)) + (len2 (vector-length v2))) + (let ((result (make-vector (+ len1 len2)))) + (vector-move-left! v1 0 len1 result 0) + (vector-move-left! v2 0 len2 result len1) + result))) + (vs + (assert-vectors vs 'vector-append) + (%vector-concatenate vs)))) + +(define (vector-concatenate vs) + "(vector-concatenate list-of-vectors) -> vector + +Append each vector in LIST-OF-VECTORS. Equivalent to: + (apply vector-append LIST-OF-VECTORS)" + (assert-vectors vs 'vector-concatenate) + (%vector-concatenate vs)) + +(define (vector-empty? vec) + "(vector-empty? vec) -> boolean + +Return true if VEC is empty, i.e. its length is 0, and false if not." + (assert-vector vec 'vector-empty?) + (zero? (vector-length vec))) + +(define vector= + (let () + (define (all-of-length? len vs) + (or (null? vs) + (and (= len (vector-length (car vs))) + (all-of-length? len (cdr vs))))) + (define (=up-to? i elt=? v1 v2) + (or (negative? i) + (let ((x1 (vector-ref v1 i)) + (x2 (vector-ref v2 i))) + (and (or (eq? x1 x2) (elt=? x1 x2)) + (=up-to? (- i 1) elt=? v1 v2))))) + (case-lambda + "(vector= elt=? vec ...) -> boolean + +Return true if the vectors VEC ... have equal lengths and equal +elements according to ELT=?. ELT=? is always applied to two +arguments. Element comparison must be consistent with eq?, in the +following sense: if (eq? a b) returns true, then (elt=? a b) must also +return true. The order in which comparisons are performed is +unspecified." + ((elt=?) + (assert-procedure elt=? 'vector=) + #t) + ((elt=? v) + (assert-procedure elt=? 'vector=) + (assert-vector v 'vector=) + #t) + ((elt=? v1 v2) + (assert-procedure elt=? 'vector=) + (assert-vector v1 'vector=) + (assert-vector v2 'vector=) + (let ((len (vector-length v1))) + (and (= len (vector-length v2)) + (=up-to? (- len 1) elt=? v1 v2)))) + ((elt=? v1 . vs) + (assert-procedure elt=? 'vector=) + (assert-vector v1 'vector=) + (assert-vectors vs 'vector=) + (let ((len (vector-length v1))) + (and (all-of-length? len vs) + (let loop ((vs vs)) + (or (null? vs) + (and (=up-to? (- len 1) elt=? v1 (car vs)) + (loop (cdr vs))))))))))) + +(define vector-fold + (case-lambda + "(vector-fold kons knil vec1 vec2 ...) -> value + +The fundamental vector iterator. KONS is iterated over each index in +all of the vectors, stopping at the end of the shortest; KONS is +applied as (KONS i state (vector-ref VEC1 i) (vector-ref VEC2 i) ...) +where STATE is the current state value, and I is the current index. +The current state value begins with KNIL, and becomes whatever KONS +returned at the respective iteration. The iteration is strictly +left-to-right." + ((kcons knil v) + (assert-procedure kcons 'vector-fold) + (assert-vector v 'vector-fold) + (let ((len (vector-length v))) + (let loop ((i 0) (state knil)) + (if (= i len) + state + (loop (+ i 1) (kcons i state (vector-ref v i))))))) + ((kcons knil v1 v2) + (assert-procedure kcons 'vector-fold) + (assert-vector v1 'vector-fold) + (assert-vector v2 'vector-fold) + (let ((len (min (vector-length v1) (vector-length v2)))) + (let loop ((i 0) (state knil)) + (if (= i len) + state + (loop (+ i 1) + (kcons i state (vector-ref v1 i) (vector-ref v2 i))))))) + ((kcons knil . vs) + (assert-procedure kcons 'vector-fold) + (assert-vectors vs 'vector-fold) + (let ((len (min-length vs))) + (let loop ((i 0) (state knil)) + (if (= i len) + state + (loop (+ i 1) (apply kcons i state (vectors-ref vs i))))))))) + +(define vector-fold-right + (case-lambda + "(vector-fold-right kons knil vec1 vec2 ...) -> value + +The fundamental vector iterator. KONS is iterated over each index in +all of the vectors, starting at the end of the shortest; KONS is +applied as (KONS i state (vector-ref VEC1 i) (vector-ref VEC2 i) ...) +where STATE is the current state value, and I is the current index. +The current state value begins with KNIL, and becomes whatever KONS +returned at the respective iteration. The iteration is strictly +right-to-left." + ((kcons knil v) + (assert-procedure kcons 'vector-fold-right) + (assert-vector v 'vector-fold-right) + (let ((len (vector-length v))) + (let loop ((i (- len 1)) (state knil)) + (if (negative? i) + state + (loop (- i 1) (kcons i state (vector-ref v i))))))) + ((kcons knil v1 v2) + (assert-procedure kcons 'vector-fold-right) + (assert-vector v1 'vector-fold-right) + (assert-vector v2 'vector-fold-right) + (let ((len (min (vector-length v1) (vector-length v2)))) + (let loop ((i (- len 1)) (state knil)) + (if (negative? i) + state + (loop (- i 1) + (kcons i state (vector-ref v1 i) (vector-ref v2 i))))))) + ((kcons knil . vs) + (assert-procedure kcons 'vector-fold-right) + (assert-vectors vs 'vector-fold-right) + (let ((len (min-length vs))) + (let loop ((i (- len 1)) (state knil)) + (if (negative? i) + state + (loop (- i 1) (apply kcons i state (vectors-ref vs i))))))))) + +(define vector-map + (case-lambda + "(vector-map f vec2 vec2 ...) -> vector + +Return a new vector of the shortest size of the vector arguments. +Each element at index i of the new vector is mapped from the old +vectors by (F i (vector-ref VEC1 i) (vector-ref VEC2 i) ...). The +dynamic order of application of F is unspecified." + ((f v) + (assert-procedure f 'vector-map) + (assert-vector v 'vector-map) + (let* ((len (vector-length v)) + (result (make-vector len))) + (let loop ((i 0)) + (unless (= i len) + (vector-set! result i (f i (vector-ref v i))) + (loop (+ i 1)))) + result)) + ((f v1 v2) + (assert-procedure f 'vector-map) + (assert-vector v1 'vector-map) + (assert-vector v2 'vector-map) + (let* ((len (min (vector-length v1) (vector-length v2))) + (result (make-vector len))) + (let loop ((i 0)) + (unless (= i len) + (vector-set! result i (f i (vector-ref v1 i) (vector-ref v2 i))) + (loop (+ i 1)))) + result)) + ((f . vs) + (assert-procedure f 'vector-map) + (assert-vectors vs 'vector-map) + (let* ((len (min-length vs)) + (result (make-vector len))) + (let loop ((i 0)) + (unless (= i len) + (vector-set! result i (apply f i (vectors-ref vs i))) + (loop (+ i 1)))) + result)))) + +(define vector-map! + (case-lambda + "(vector-map! f vec2 vec2 ...) -> unspecified + +Similar to vector-map, but rather than mapping the new elements into a +new vector, the new mapped elements are destructively inserted into +VEC1. The dynamic order of application of F is unspecified." + ((f v) + (assert-procedure f 'vector-map!) + (assert-vector v 'vector-map!) + (let ((len (vector-length v))) + (let loop ((i 0)) + (unless (= i len) + (vector-set! v i (f i (vector-ref v i))) + (loop (+ i 1)))))) + ((f v1 v2) + (assert-procedure f 'vector-map!) + (assert-vector v1 'vector-map!) + (assert-vector v2 'vector-map!) + (let ((len (min (vector-length v1) (vector-length v2)))) + (let loop ((i 0)) + (unless (= i len) + (vector-set! v1 i (f i (vector-ref v1 i) (vector-ref v2 i))) + (loop (+ i 1)))))) + ((f . vs) + (assert-procedure f 'vector-map!) + (assert-vectors vs 'vector-map!) + (let ((len (min-length vs)) + (v1 (car vs))) + (let loop ((i 0)) + (unless (= i len) + (vector-set! v1 i (apply f i (vectors-ref vs i))) + (loop (+ i 1)))))))) + +(define vector-for-each + (case-lambda + "(vector-for-each f vec1 vec2 ...) -> unspecified + +Call (F i VEC1[i] VEC2[i] ...) for each index i less than the length +of the shortest vector passed. The iteration is strictly +left-to-right." + ((f v) + (assert-procedure f 'vector-for-each) + (assert-vector v 'vector-for-each) + (let ((len (vector-length v))) + (let loop ((i 0)) + (unless (= i len) + (f i (vector-ref v i)) + (loop (+ i 1)))))) + ((f v1 v2) + (assert-procedure f 'vector-for-each) + (assert-vector v1 'vector-for-each) + (assert-vector v2 'vector-for-each) + (let ((len (min (vector-length v1) + (vector-length v2)))) + (let loop ((i 0)) + (unless (= i len) + (f i (vector-ref v1 i) (vector-ref v2 i)) + (loop (+ i 1)))))) + ((f . vs) + (assert-procedure f 'vector-for-each) + (assert-vectors vs 'vector-for-each) + (let ((len (min-length vs))) + (let loop ((i 0)) + (unless (= i len) + (apply f i (vectors-ref vs i)) + (loop (+ i 1)))))))) + +(define vector-count + (case-lambda + "(vector-count pred? vec1 vec2 ...) -> exact nonnegative integer + +Count the number of indices i for which (PRED? VEC1[i] VEC2[i] ...) +returns true, where i is less than the length of the shortest vector +passed." + ((pred? v) + (assert-procedure pred? 'vector-count) + (assert-vector v 'vector-count) + (let ((len (vector-length v))) + (let loop ((i 0) (count 0)) + (cond ((= i len) count) + ((pred? i (vector-ref v i)) + (loop (+ i 1) (+ count 1))) + (else + (loop (+ i 1) count)))))) + ((pred? v1 v2) + (assert-procedure pred? 'vector-count) + (assert-vector v1 'vector-count) + (assert-vector v2 'vector-count) + (let ((len (min (vector-length v1) + (vector-length v2)))) + (let loop ((i 0) (count 0)) + (cond ((= i len) count) + ((pred? i (vector-ref v1 i) (vector-ref v2 i)) + (loop (+ i 1) (+ count 1))) + (else + (loop (+ i 1) count)))))) + ((pred? . vs) + (assert-procedure pred? 'vector-count) + (assert-vectors vs 'vector-count) + (let ((len (min-length vs))) + (let loop ((i 0) (count 0)) + (cond ((= i len) count) + ((apply pred? i (vectors-ref vs i)) + (loop (+ i 1) (+ count 1))) + (else + (loop (+ i 1) count)))))))) + +(define vector-index + (case-lambda + "(vector-index pred? vec1 vec2 ...) -> exact nonnegative integer or #f + +Find and return the index of the first elements in VEC1 VEC2 ... that +satisfy PRED?. If no matching element is found by the end of the +shortest vector, return #f." + ((pred? v) + (assert-procedure pred? 'vector-index) + (assert-vector v 'vector-index) + (let ((len (vector-length v))) + (let loop ((i 0)) + (and (< i len) + (if (pred? (vector-ref v i)) + i + (loop (+ i 1))))))) + ((pred? v1 v2) + (assert-procedure pred? 'vector-index) + (assert-vector v1 'vector-index) + (assert-vector v2 'vector-index) + (let ((len (min (vector-length v1) + (vector-length v2)))) + (let loop ((i 0)) + (and (< i len) + (if (pred? (vector-ref v1 i) + (vector-ref v2 i)) + i + (loop (+ i 1))))))) + ((pred? . vs) + (assert-procedure pred? 'vector-index) + (assert-vectors vs 'vector-index) + (let ((len (min-length vs))) + (let loop ((i 0)) + (and (< i len) + (if (apply pred? (vectors-ref vs i)) + i + (loop (+ i 1))))))))) + +(define vector-index-right + (case-lambda + "(vector-index-right pred? vec1 vec2 ...) -> exact nonnegative integer or #f + +Find and return the index of the last elements in VEC1 VEC2 ... that +satisfy PRED?, searching from right-to-left. If no matching element +is found before the end of the shortest vector, return #f." + ((pred? v) + (assert-procedure pred? 'vector-index-right) + (assert-vector v 'vector-index-right) + (let ((len (vector-length v))) + (let loop ((i (- len 1))) + (and (>= i 0) + (if (pred? (vector-ref v i)) + i + (loop (- i 1))))))) + ((pred? v1 v2) + (assert-procedure pred? 'vector-index-right) + (assert-vector v1 'vector-index-right) + (assert-vector v2 'vector-index-right) + (let ((len (min (vector-length v1) + (vector-length v2)))) + (let loop ((i (- len 1))) + (and (>= i 0) + (if (pred? (vector-ref v1 i) + (vector-ref v2 i)) + i + (loop (- i 1))))))) + ((pred? . vs) + (assert-procedure pred? 'vector-index-right) + (assert-vectors vs 'vector-index-right) + (let ((len (min-length vs))) + (let loop ((i (- len 1))) + (and (>= i 0) + (if (apply pred? (vectors-ref vs i)) + i + (loop (- i 1))))))))) + +(define vector-skip + (case-lambda + "(vector-skip pred? vec1 vec2 ...) -> exact nonnegative integer or #f + +Find and return the index of the first elements in VEC1 VEC2 ... that +do not satisfy PRED?. If no matching element is found by the end of +the shortest vector, return #f." + ((pred? v) + (assert-procedure pred? 'vector-skip) + (assert-vector v 'vector-skip) + (let ((len (vector-length v))) + (let loop ((i 0)) + (and (< i len) + (if (pred? (vector-ref v i)) + (loop (+ i 1)) + i))))) + ((pred? v1 v2) + (assert-procedure pred? 'vector-skip) + (assert-vector v1 'vector-skip) + (assert-vector v2 'vector-skip) + (let ((len (min (vector-length v1) + (vector-length v2)))) + (let loop ((i 0)) + (and (< i len) + (if (pred? (vector-ref v1 i) + (vector-ref v2 i)) + (loop (+ i 1)) + i))))) + ((pred? . vs) + (assert-procedure pred? 'vector-skip) + (assert-vectors vs 'vector-skip) + (let ((len (min-length vs))) + (let loop ((i 0)) + (and (< i len) + (if (apply pred? (vectors-ref vs i)) + (loop (+ i 1)) + i))))))) + +(define vector-skip-right + (case-lambda + "(vector-skip-right pred? vec1 vec2 ...) -> exact nonnegative integer or #f + +Find and return the index of the last elements in VEC1 VEC2 ... that +do not satisfy PRED?, searching from right-to-left. If no matching +element is found before the end of the shortest vector, return #f." + ((pred? v) + (assert-procedure pred? 'vector-skip-right) + (assert-vector v 'vector-skip-right) + (let ((len (vector-length v))) + (let loop ((i (- len 1))) + (and (not (negative? i)) + (if (pred? (vector-ref v i)) + (loop (- i 1)) + i))))) + ((pred? v1 v2) + (assert-procedure pred? 'vector-skip-right) + (assert-vector v1 'vector-skip-right) + (assert-vector v2 'vector-skip-right) + (let ((len (min (vector-length v1) + (vector-length v2)))) + (let loop ((i (- len 1))) + (and (not (negative? i)) + (if (pred? (vector-ref v1 i) + (vector-ref v2 i)) + (loop (- i 1)) + i))))) + ((pred? . vs) + (assert-procedure pred? 'vector-skip-right) + (assert-vectors vs 'vector-skip-right) + (let ((len (min-length vs))) + (let loop ((i (- len 1))) + (and (not (negative? i)) + (if (apply pred? (vectors-ref vs i)) + (loop (- i 1)) + i))))))) + +(define vector-binary-search + (let () + (define (%vector-binary-search vec value cmp start end) + (let loop ((lo start) (hi end)) + (and (< lo hi) + (let* ((i (quotient (+ lo hi) 2)) + (x (vector-ref vec i)) + (c (cmp x value))) + (cond ((zero? c) i) + ((positive? c) (loop lo i)) + ((negative? c) (loop (+ i 1) hi))))))) + (case-lambda + "(vector-binary-search vec value cmp [start [end]]) -> exact nonnegative integer or #f + +Find and return an index of VEC between START and END whose value is +VALUE using a binary search. If no matching element is found, return +#f. The default START is 0 and the default END is the length of VEC. +CMP must be a procedure of two arguments such that (CMP A B) returns +a negative integer if A < B, a positive integer if A > B, or zero if +A = B. The elements of VEC must be sorted in non-decreasing order +according to CMP." + ((vec value cmp) + (assert-vector vec 'vector-binary-search) + (assert-procedure cmp 'vector-binary-search) + (%vector-binary-search vec value cmp 0 (vector-length vec))) + + ((vec value cmp start) + (assert-vector vec 'vector-binary-search) + (let ((len (vector-length vec))) + (assert-valid-start start len 'vector-binary-search) + (%vector-binary-search vec value cmp start len))) + + ((vec value cmp start end) + (assert-vector vec 'vector-binary-search) + (let ((len (vector-length vec))) + (assert-valid-range start end len 'vector-binary-search) + (%vector-binary-search vec value cmp start end)))))) + +(define vector-any + (case-lambda + "(vector-any pred? vec1 vec2 ...) -> value or #f + +Find the first parallel set of elements from VEC1 VEC2 ... for which +PRED? returns a true value. If such a parallel set of elements +exists, vector-any returns the value that PRED? returned for that set +of elements. The iteration is strictly left-to-right." + ((pred? v) + (assert-procedure pred? 'vector-any) + (assert-vector v 'vector-any) + (let ((len (vector-length v))) + (let loop ((i 0)) + (and (< i len) + (or (pred? (vector-ref v i)) + (loop (+ i 1))))))) + ((pred? v1 v2) + (assert-procedure pred? 'vector-any) + (assert-vector v1 'vector-any) + (assert-vector v2 'vector-any) + (let ((len (min (vector-length v1) + (vector-length v2)))) + (let loop ((i 0)) + (and (< i len) + (or (pred? (vector-ref v1 i) + (vector-ref v2 i)) + (loop (+ i 1))))))) + ((pred? . vs) + (assert-procedure pred? 'vector-any) + (assert-vectors vs 'vector-any) + (let ((len (min-length vs))) + (let loop ((i 0)) + (and (< i len) + (or (apply pred? (vectors-ref vs i)) + (loop (+ i 1))))))))) + +(define vector-every + (case-lambda + "(vector-every pred? vec1 vec2 ...) -> value or #f + +If, for every index i less than the length of the shortest vector +argument, the set of elements VEC1[i] VEC2[i] ... satisfies PRED?, +vector-every returns the value that PRED? returned for the last set of +elements, at the last index of the shortest vector. The iteration is +strictly left-to-right." + ((pred? v) + (assert-procedure pred? 'vector-every) + (assert-vector v 'vector-every) + (let ((len (vector-length v))) + (or (zero? len) + (let loop ((i 0)) + (let ((val (pred? (vector-ref v i))) + (next-i (+ i 1))) + (if (or (not val) (= next-i len)) + val + (loop next-i))))))) + ((pred? v1 v2) + (assert-procedure pred? 'vector-every) + (assert-vector v1 'vector-every) + (assert-vector v2 'vector-every) + (let ((len (min (vector-length v1) + (vector-length v2)))) + (or (zero? len) + (let loop ((i 0)) + (let ((val (pred? (vector-ref v1 i) + (vector-ref v2 i))) + (next-i (+ i 1))) + (if (or (not val) (= next-i len)) + val + (loop next-i))))))) + ((pred? . vs) + (assert-procedure pred? 'vector-every) + (assert-vectors vs 'vector-every) + (let ((len (min-length vs))) + (or (zero? len) + (let loop ((i 0)) + (let ((val (apply pred? (vectors-ref vs i))) + (next-i (+ i 1))) + (if (or (not val) (= next-i len)) + val + (loop next-i))))))))) + +(define (vector-swap! vec i j) + "(vector-swap! vec i j) -> unspecified + +Swap the values of the locations in VEC at I and J." + (assert-vector vec 'vector-swap!) + (let ((len (vector-length vec))) + (assert-valid-index i len 'vector-swap!) + (assert-valid-index j len 'vector-swap!) + (let ((tmp (vector-ref vec i))) + (vector-set! vec i (vector-ref vec j)) + (vector-set! vec j tmp)))) + +;; TODO: Enhance Guile core 'vector-fill!' to do this. +(define vector-fill! + (let () + (define guile-vector-fill! + (@ (guile) vector-fill!)) + (define (%vector-fill! vec fill start end) + (let loop ((i start)) + (when (< i end) + (vector-set! vec i fill) + (loop (+ i 1))))) + (case-lambda + "(vector-fill! vec fill [start [end]]) -> unspecified + +Assign the value of every location in VEC between START and END to +FILL. START defaults to 0 and END defaults to the length of VEC." + ((vec fill) + (guile-vector-fill! vec fill)) + ((vec fill start) + (assert-vector vec 'vector-fill!) + (let ((len (vector-length vec))) + (assert-valid-start start len 'vector-fill!) + (%vector-fill! vec fill start len))) + ((vec fill start end) + (assert-vector vec 'vector-fill!) + (let ((len (vector-length vec))) + (assert-valid-range start end len 'vector-fill!) + (%vector-fill! vec fill start end)))))) + +(define (%vector-reverse! vec start end) + (let loop ((i start) (j (- end 1))) + (when (< i j) + (let ((tmp (vector-ref vec i))) + (vector-set! vec i (vector-ref vec j)) + (vector-set! vec j tmp) + (loop (+ i 1) (- j 1)))))) + +(define vector-reverse! + (case-lambda + "(vector-reverse! vec [start [end]]) -> unspecified + +Destructively reverse the contents of VEC between START and END. +START defaults to 0 and END defaults to the length of VEC." + ((vec) + (assert-vector vec 'vector-reverse!) + (%vector-reverse! vec 0 (vector-length vec))) + ((vec start) + (assert-vector vec 'vector-reverse!) + (let ((len (vector-length vec))) + (assert-valid-start start len 'vector-reverse!) + (%vector-reverse! vec start len))) + ((vec start end) + (assert-vector vec 'vector-reverse!) + (let ((len (vector-length vec))) + (assert-valid-range start end len 'vector-reverse!) + (%vector-reverse! vec start end))))) + +(define-syntax-rule (define-vector-copier! copy! docstring inner-proc) + (define copy! + (let ((%copy! inner-proc)) + (case-lambda + docstring + ((target tstart source) + (assert-vector target 'copy!) + (assert-vector source 'copy!) + (let ((tlen (vector-length target)) + (slen (vector-length source))) + (assert-valid-start tstart tlen 'copy!) + (unless (>= tlen (+ tstart slen)) + (error-from 'copy! "would write past end of target")) + (%copy! target tstart source 0 slen))) + + ((target tstart source sstart) + (assert-vector target 'copy!) + (assert-vector source 'copy!) + (let ((tlen (vector-length target)) + (slen (vector-length source))) + (assert-valid-start tstart tlen 'copy!) + (assert-valid-start sstart slen 'copy!) + (unless (>= tlen (+ tstart (- slen sstart))) + (error-from 'copy! "would write past end of target")) + (%copy! target tstart source sstart slen))) + + ((target tstart source sstart send) + (assert-vector target 'copy!) + (assert-vector source 'copy!) + (let ((tlen (vector-length target)) + (slen (vector-length source))) + (assert-valid-start tstart tlen 'copy!) + (assert-valid-range sstart send slen 'copy!) + (unless (>= tlen (+ tstart (- send sstart))) + (error-from 'copy! "would write past end of target")) + (%copy! target tstart source sstart send))))))) + +(define-vector-copier! vector-copy! + "(vector-copy! target tstart source [sstart [send]]) -> unspecified + +Copy a block of elements from SOURCE to TARGET, both of which must be +vectors, starting in TARGET at TSTART and starting in SOURCE at +SSTART, ending when SEND - SSTART elements have been copied. It is an +error for TARGET to have a length less than TSTART + (SEND - SSTART). +SSTART defaults to 0 and SEND defaults to the length of SOURCE." + (lambda (target tstart source sstart send) + (if (< tstart sstart) + (vector-move-left! source sstart send target tstart) + (vector-move-right! source sstart send target tstart)))) + +(define-vector-copier! vector-reverse-copy! + "(vector-reverse-copy! target tstart source [sstart [send]]) -> unspecified + +Like vector-copy!, but copy the elements in the reverse order. It is +an error if TARGET and SOURCE are identical vectors and the TARGET and +SOURCE ranges overlap; however, if TSTART = SSTART, +vector-reverse-copy! behaves as (vector-reverse! TARGET TSTART SEND) +would." + (lambda (target tstart source sstart send) + (if (and (eq? target source) (= tstart sstart)) + (%vector-reverse! target sstart send) + (let loop ((i tstart) (j (- send 1))) + (when (>= j sstart) + (vector-set! target i (vector-ref source j)) + (loop (+ i 1) (- j 1))))))) + +(define vector->list + (let () + (define (%vector->list vec start end) + (let loop ((i (- end 1)) + (result '())) + (if (< i start) + result + (loop (- i 1) (cons (vector-ref vec i) result))))) + (case-lambda + "(vector->list vec [start [end]]) -> proper-list + +Return a newly allocated list containing the elements in VEC between +START and END. START defaults to 0 and END defaults to the length of +VEC." + ((vec) + (assert-vector vec 'vector->list) + (%vector->list vec 0 (vector-length vec))) + ((vec start) + (assert-vector vec 'vector->list) + (let ((len (vector-length vec))) + (assert-valid-start start len 'vector->list) + (%vector->list vec start len))) + ((vec start end) + (assert-vector vec 'vector->list) + (let ((len (vector-length vec))) + (assert-valid-range start end len 'vector->list) + (%vector->list vec start end)))))) + +(define reverse-vector->list + (let () + (define (%reverse-vector->list vec start end) + (let loop ((i start) + (result '())) + (if (>= i end) + result + (loop (+ i 1) (cons (vector-ref vec i) result))))) + (case-lambda + "(reverse-vector->list vec [start [end]]) -> proper-list + +Return a newly allocated list containing the elements in VEC between +START and END in reverse order. START defaults to 0 and END defaults +to the length of VEC." + ((vec) + (assert-vector vec 'reverse-vector->list) + (%reverse-vector->list vec 0 (vector-length vec))) + ((vec start) + (assert-vector vec 'reverse-vector->list) + (let ((len (vector-length vec))) + (assert-valid-start start len 'reverse-vector->list) + (%reverse-vector->list vec start len))) + ((vec start end) + (assert-vector vec 'reverse-vector->list) + (let ((len (vector-length vec))) + (assert-valid-range start end len 'reverse-vector->list) + (%reverse-vector->list vec start end)))))) + +;; TODO: change to use 'case-lambda' and improve error checking. +(define* (list->vector lst #:optional (start 0) (end (length lst))) + "(list->vector proper-list [start [end]]) -> vector + +Return a newly allocated vector of the elements from PROPER-LIST with +indices between START and END. START defaults to 0 and END defaults +to the length of PROPER-LIST." + (let* ((len (- end start)) + (result (make-vector len))) + (let loop ((i 0) (lst (drop lst start))) + (if (= i len) + result + (begin (vector-set! result i (car lst)) + (loop (+ i 1) (cdr lst))))))) + +;; TODO: change to use 'case-lambda' and improve error checking. +(define* (reverse-list->vector lst #:optional (start 0) (end (length lst))) + "(reverse-list->vector proper-list [start [end]]) -> vector + +Return a newly allocated vector of the elements from PROPER-LIST with +indices between START and END, in reverse order. START defaults to 0 +and END defaults to the length of PROPER-LIST." + (let* ((len (- end start)) + (result (make-vector len))) + (let loop ((i (- len 1)) (lst (drop lst start))) + (if (negative? i) + result + (begin (vector-set! result i (car lst)) + (loop (- i 1) (cdr lst))))))) diff --git a/module/srfi/srfi-45.scm b/module/srfi/srfi-45.scm new file mode 100644 index 000000000..6f7ba7e04 --- /dev/null +++ b/module/srfi/srfi-45.scm @@ -0,0 +1,93 @@ +;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms + +;; Copyright (C) 2010, 2011, 2013 Free Software Foundation, Inc. +;; Copyright (C) 2003 André van Tonder. All Rights Reserved. + +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: + +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. + +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +;;; Commentary: + +;; This is the code of the reference implementation of SRFI-45, modified +;; to use SRFI-9 and to add 'promise?' to the list of exports. + +;; This module is documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-45) + #:export (delay + lazy + force + eager + promise?) + #:replace (delay force promise?) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-9 gnu)) + +(cond-expand-provide (current-module) '(srfi-45)) + +(define-record-type promise (make-promise val) promise? + (val promise-val promise-val-set!)) + +(define-record-type value (make-value tag proc) value? + (tag value-tag value-tag-set!) + (proc value-proc value-proc-set!)) + +(define-syntax-rule (lazy exp) + (make-promise (make-value 'lazy (lambda () exp)))) + +(define (eager x) + (make-promise (make-value 'eager x))) + +(define-syntax-rule (delay exp) + (lazy (eager exp))) + +(define (force promise) + (let ((content (promise-val promise))) + (case (value-tag content) + ((eager) (value-proc content)) + ((lazy) (let* ((promise* ((value-proc content))) + (content (promise-val promise))) ; * + (if (not (eqv? (value-tag content) 'eager)) ; * + (begin (value-tag-set! content + (value-tag (promise-val promise*))) + (value-proc-set! content + (value-proc (promise-val promise*))) + (promise-val-set! promise* content))) + (force promise)))))) + +;; (*) These two lines re-fetch and check the original promise in case +;; the first line of the let* caused it to be forced. For an example +;; where this happens, see reentrancy test 3 below. + +(define* (promise-visit promise #:key on-eager on-lazy) + (define content (promise-val promise)) + (case (value-tag content) + ((eager) (on-eager (value-proc content))) + ((lazy) (on-lazy (value-proc content))))) + +(set-record-type-printer! promise + (lambda (promise port) + (promise-visit promise + #:on-eager (lambda (value) + (format port "#<promise = ~s>" value)) + #:on-lazy (lambda (proc) + (format port "#<promise => ~s>" proc))))) diff --git a/module/srfi/srfi-6.scm b/module/srfi/srfi-6.scm new file mode 100644 index 000000000..e6f8b438a --- /dev/null +++ b/module/srfi/srfi-6.scm @@ -0,0 +1,29 @@ +;;; srfi-6.scm --- Basic String Ports + +;; Copyright (C) 2001, 2002, 2003, 2006, 2012, +;; 2013 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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)) + +;;; 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..b3ddaada7 --- /dev/null +++ b/module/srfi/srfi-60.scm @@ -0,0 +1,73 @@ +;;; srfi-60.scm --- Integers as Bits + +;; Copyright (C) 2005, 2006, 2010 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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? + 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) + #:replace (bit-count) + #:re-export (logand + logior + logxor + integer-length + logtest + logcount + logbit? + ash)) + +(load-extension (string-append "libguile-" (effective-version)) + "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-64.scm b/module/srfi/srfi-64.scm new file mode 100644 index 000000000..81dcc5dc5 --- /dev/null +++ b/module/srfi/srfi-64.scm @@ -0,0 +1,55 @@ +;;; srfi-64.scm -- SRFI 64 - A Scheme API for test suites. + +;; Copyright (C) 2014 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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-64) + #:export + (test-begin + test-end test-assert test-eqv test-eq test-equal + test-approximate test-assert test-error test-apply test-with-runner + test-match-nth test-match-all test-match-any test-match-name + test-skip test-expect-fail test-read-eval-string + test-runner-group-path test-group test-group-with-cleanup + test-result-ref test-result-set! test-result-clear test-result-remove + test-result-kind test-passed? + test-log-to-file + test-runner? test-runner-reset test-runner-null + test-runner-simple test-runner-current test-runner-factory test-runner-get + test-runner-create test-runner-test-name + test-runner-pass-count test-runner-pass-count! + test-runner-fail-count test-runner-fail-count! + test-runner-xpass-count test-runner-xpass-count! + test-runner-xfail-count test-runner-xfail-count! + test-runner-skip-count test-runner-skip-count! + test-runner-group-stack test-runner-group-stack! + test-runner-on-test-begin test-runner-on-test-begin! + test-runner-on-test-end test-runner-on-test-end! + test-runner-on-group-begin test-runner-on-group-begin! + test-runner-on-group-end test-runner-on-group-end! + test-runner-on-final test-runner-on-final! + test-runner-on-bad-count test-runner-on-bad-count! + test-runner-on-bad-end-name test-runner-on-bad-end-name! + test-result-alist test-result-alist! + test-runner-aux-value test-runner-aux-value! + test-on-group-begin-simple test-on-group-end-simple + test-on-bad-count-simple test-on-bad-end-name-simple + test-on-final-simple test-on-test-end-simple + test-on-final-simple)) + +(cond-expand-provide (current-module) '(srfi-64)) + +(include-from-path "srfi/srfi-64/testing.scm") diff --git a/module/srfi/srfi-64/testing.scm b/module/srfi/srfi-64/testing.scm new file mode 100644 index 000000000..d686662bf --- /dev/null +++ b/module/srfi/srfi-64/testing.scm @@ -0,0 +1,1040 @@ +;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner +;; Added "full" support for Chicken, Gauche, Guile and SISC. +;; Alex Shinn, Copyright (c) 2005. +;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. +;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014. +;; +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(cond-expand + (chicken + (require-extension syntax-case)) + (guile-2 + (use-modules (srfi srfi-9) + ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated + ;; with either Guile's native exceptions or R6RS exceptions. + ;;(srfi srfi-34) (srfi srfi-35) + (srfi srfi-39))) + (guile + (use-modules (ice-9 syncase) (srfi srfi-9) + ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7 + (srfi srfi-39))) + (sisc + (require-extension (srfi 9 34 35 39))) + (kawa + (module-compile-options warn-undefined-variable: #t + warn-invoke-unknown-method: #t) + (provide 'srfi-64) + (provide 'testing) + (require 'srfi-34) + (require 'srfi-35)) + (else () + )) + +(cond-expand + (kawa + (define-syntax %test-export + (syntax-rules () + ((%test-export test-begin . other-names) + (module-export %test-begin . other-names))))) + (else + (define-syntax %test-export + (syntax-rules () + ((%test-export . names) (if #f #f)))))) + +;; List of exported names +(%test-export + test-begin ;; must be listed first, since in Kawa (at least) it is "magic". + test-end test-assert test-eqv test-eq test-equal + test-approximate test-assert test-error test-apply test-with-runner + test-match-nth test-match-all test-match-any test-match-name + test-skip test-expect-fail test-read-eval-string + test-runner-group-path test-group test-group-with-cleanup + test-result-ref test-result-set! test-result-clear test-result-remove + test-result-kind test-passed? + test-log-to-file + ; Misc test-runner functions + test-runner? test-runner-reset test-runner-null + test-runner-simple test-runner-current test-runner-factory test-runner-get + test-runner-create test-runner-test-name + ;; test-runner field setter and getter functions - see %test-record-define: + test-runner-pass-count test-runner-pass-count! + test-runner-fail-count test-runner-fail-count! + test-runner-xpass-count test-runner-xpass-count! + test-runner-xfail-count test-runner-xfail-count! + test-runner-skip-count test-runner-skip-count! + test-runner-group-stack test-runner-group-stack! + test-runner-on-test-begin test-runner-on-test-begin! + test-runner-on-test-end test-runner-on-test-end! + test-runner-on-group-begin test-runner-on-group-begin! + test-runner-on-group-end test-runner-on-group-end! + test-runner-on-final test-runner-on-final! + test-runner-on-bad-count test-runner-on-bad-count! + test-runner-on-bad-end-name test-runner-on-bad-end-name! + test-result-alist test-result-alist! + test-runner-aux-value test-runner-aux-value! + ;; default/simple call-back functions, used in default test-runner, + ;; but can be called to construct more complex ones. + test-on-group-begin-simple test-on-group-end-simple + test-on-bad-count-simple test-on-bad-end-name-simple + test-on-final-simple test-on-test-end-simple + test-on-final-simple) + +(cond-expand + (srfi-9 + (define-syntax %test-record-define + (syntax-rules () + ((%test-record-define alloc runner? (name index setter getter) ...) + (define-record-type test-runner + (alloc) + runner? + (name setter getter) ...))))) + (else + (define %test-runner-cookie (list "test-runner")) + (define-syntax %test-record-define + (syntax-rules () + ((%test-record-define alloc runner? (name index getter setter) ...) + (begin + (define (runner? obj) + (and (vector? obj) + (> (vector-length obj) 1) + (eq (vector-ref obj 0) %test-runner-cookie))) + (define (alloc) + (let ((runner (make-vector 23))) + (vector-set! runner 0 %test-runner-cookie) + runner)) + (begin + (define (getter runner) + (vector-ref runner index)) ...) + (begin + (define (setter runner value) + (vector-set! runner index value)) ...))))))) + +(%test-record-define + %test-runner-alloc test-runner? + ;; Cumulate count of all tests that have passed and were expected to. + (pass-count 1 test-runner-pass-count test-runner-pass-count!) + (fail-count 2 test-runner-fail-count test-runner-fail-count!) + (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!) + (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!) + (skip-count 5 test-runner-skip-count test-runner-skip-count!) + (skip-list 6 %test-runner-skip-list %test-runner-skip-list!) + (fail-list 7 %test-runner-fail-list %test-runner-fail-list!) + ;; Normally #t, except when in a test-apply. + (run-list 8 %test-runner-run-list %test-runner-run-list!) + (skip-save 9 %test-runner-skip-save %test-runner-skip-save!) + (fail-save 10 %test-runner-fail-save %test-runner-fail-save!) + (group-stack 11 test-runner-group-stack test-runner-group-stack!) + (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!) + (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!) + ;; Call-back when entering a group. Takes (runner suite-name count). + (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!) + ;; Call-back when leaving a group. + (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!) + ;; Call-back when leaving the outermost group. + (on-final 16 test-runner-on-final test-runner-on-final!) + ;; Call-back when expected number of tests was wrong. + (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!) + ;; Call-back when name in test=end doesn't match test-begin. + (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!) + ;; Cumulate count of all tests that have been done. + (total-count 19 %test-runner-total-count %test-runner-total-count!) + ;; Stack (list) of (count-at-start . expected-count): + (count-list 20 %test-runner-count-list %test-runner-count-list!) + (result-alist 21 test-result-alist test-result-alist!) + ;; Field can be used by test-runner for any purpose. + ;; test-runner-simple uses it for a log file. + (aux-value 22 test-runner-aux-value test-runner-aux-value!) +) + +(define (test-runner-reset runner) + (test-result-alist! runner '()) + (test-runner-pass-count! runner 0) + (test-runner-fail-count! runner 0) + (test-runner-xpass-count! runner 0) + (test-runner-xfail-count! runner 0) + (test-runner-skip-count! runner 0) + (%test-runner-total-count! runner 0) + (%test-runner-count-list! runner '()) + (%test-runner-run-list! runner #t) + (%test-runner-skip-list! runner '()) + (%test-runner-fail-list! runner '()) + (%test-runner-skip-save! runner '()) + (%test-runner-fail-save! runner '()) + (test-runner-group-stack! runner '())) + +(define (test-runner-group-path runner) + (reverse (test-runner-group-stack runner))) + +(define (%test-null-callback runner) #f) + +(define (test-runner-null) + (let ((runner (%test-runner-alloc))) + (test-runner-reset runner) + (test-runner-on-group-begin! runner (lambda (runner name count) #f)) + (test-runner-on-group-end! runner %test-null-callback) + (test-runner-on-final! runner %test-null-callback) + (test-runner-on-test-begin! runner %test-null-callback) + (test-runner-on-test-end! runner %test-null-callback) + (test-runner-on-bad-count! runner (lambda (runner count expected) #f)) + (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f)) + runner)) + +;; Not part of the specification. FIXME +;; Controls whether a log file is generated. +(define test-log-to-file #t) + +(define (test-runner-simple) + (let ((runner (%test-runner-alloc))) + (test-runner-reset runner) + (test-runner-on-group-begin! runner test-on-group-begin-simple) + (test-runner-on-group-end! runner test-on-group-end-simple) + (test-runner-on-final! runner test-on-final-simple) + (test-runner-on-test-begin! runner test-on-test-begin-simple) + (test-runner-on-test-end! runner test-on-test-end-simple) + (test-runner-on-bad-count! runner test-on-bad-count-simple) + (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) + runner)) + +(cond-expand + (srfi-39 + (define test-runner-current (make-parameter #f)) + (define test-runner-factory (make-parameter test-runner-simple))) + (else + (define %test-runner-current #f) + (define-syntax test-runner-current + (syntax-rules () + ((test-runner-current) + %test-runner-current) + ((test-runner-current runner) + (set! %test-runner-current runner)))) + (define %test-runner-factory test-runner-simple) + (define-syntax test-runner-factory + (syntax-rules () + ((test-runner-factory) + %test-runner-factory) + ((test-runner-factory runner) + (set! %test-runner-factory runner)))))) + +;; A safer wrapper to test-runner-current. +(define (test-runner-get) + (let ((r (test-runner-current))) + (if (not r) + (cond-expand + (srfi-23 (error "test-runner not initialized - test-begin missing?")) + (else #t))) + r)) + +(define (%test-specifier-matches spec runner) + (spec runner)) + +(define (test-runner-create) + ((test-runner-factory))) + +(define (%test-any-specifier-matches list runner) + (let ((result #f)) + (let loop ((l list)) + (cond ((null? l) result) + (else + (if (%test-specifier-matches (car l) runner) + (set! result #t)) + (loop (cdr l))))))) + +;; Returns #f, #t, or 'xfail. +(define (%test-should-execute runner) + (let ((run (%test-runner-run-list runner))) + (cond ((or + (not (or (eqv? run #t) + (%test-any-specifier-matches run runner))) + (%test-any-specifier-matches + (%test-runner-skip-list runner) + runner)) + (test-result-set! runner 'result-kind 'skip) + #f) + ((%test-any-specifier-matches + (%test-runner-fail-list runner) + runner) + (test-result-set! runner 'result-kind 'xfail) + 'xfail) + (else #t)))) + +(define (%test-begin suite-name count) + (if (not (test-runner-current)) + (test-runner-current (test-runner-create))) + (let ((runner (test-runner-current))) + ((test-runner-on-group-begin runner) runner suite-name count) + (%test-runner-skip-save! runner + (cons (%test-runner-skip-list runner) + (%test-runner-skip-save runner))) + (%test-runner-fail-save! runner + (cons (%test-runner-fail-list runner) + (%test-runner-fail-save runner))) + (%test-runner-count-list! runner + (cons (cons (%test-runner-total-count runner) + count) + (%test-runner-count-list runner))) + (test-runner-group-stack! runner (cons suite-name + (test-runner-group-stack runner))))) +(cond-expand + (kawa + ;; Kawa has test-begin built in, implemented as: + ;; (begin + ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64))) + ;; (%test-begin suite-name [count])) + ;; This puts test-begin but only test-begin in the default environment., + ;; which makes normal test suites loadable without non-portable commands. + ) + (else + (define-syntax test-begin + (syntax-rules () + ((test-begin suite-name) + (%test-begin suite-name #f)) + ((test-begin suite-name count) + (%test-begin suite-name count)))))) + +(define (test-on-group-begin-simple runner suite-name count) + (if (null? (test-runner-group-stack runner)) + (begin + (display "%%%% Starting test ") + (display suite-name) + (if test-log-to-file + (let* ((log-file-name + (if (string? test-log-to-file) test-log-to-file + (string-append suite-name ".log"))) + (log-file + (cond-expand (mzscheme + (open-output-file log-file-name 'truncate/replace)) + (else (open-output-file log-file-name))))) + (display "%%%% Starting test " log-file) + (display suite-name log-file) + (newline log-file) + (test-runner-aux-value! runner log-file) + (display " (Writing full log to \"") + (display log-file-name) + (display "\")"))) + (newline))) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (begin + (display "Group begin: " log) + (display suite-name log) + (newline log)))) + #f) + +(define (test-on-group-end-simple runner) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (begin + (display "Group end: " log) + (display (car (test-runner-group-stack runner)) log) + (newline log)))) + #f) + +(define (%test-on-bad-count-write runner count expected-count port) + (display "*** Total number of tests was " port) + (display count port) + (display " but should be " port) + (display expected-count port) + (display ". ***" port) + (newline port) + (display "*** Discrepancy indicates testsuite error or exceptions. ***" port) + (newline port)) + +(define (test-on-bad-count-simple runner count expected-count) + (%test-on-bad-count-write runner count expected-count (current-output-port)) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (%test-on-bad-count-write runner count expected-count log)))) + +(define (test-on-bad-end-name-simple runner begin-name end-name) + (let ((msg (string-append (%test-format-line runner) "test-end " begin-name + " does not match test-begin " end-name))) + (cond-expand + (srfi-23 (error msg)) + (else (display msg) (newline))))) + + +(define (%test-final-report1 value label port) + (if (> value 0) + (begin + (display label port) + (display value port) + (newline port)))) + +(define (%test-final-report-simple runner port) + (%test-final-report1 (test-runner-pass-count runner) + "# of expected passes " port) + (%test-final-report1 (test-runner-xfail-count runner) + "# of expected failures " port) + (%test-final-report1 (test-runner-xpass-count runner) + "# of unexpected successes " port) + (%test-final-report1 (test-runner-fail-count runner) + "# of unexpected failures " port) + (%test-final-report1 (test-runner-skip-count runner) + "# of skipped tests " port)) + +(define (test-on-final-simple runner) + (%test-final-report-simple runner (current-output-port)) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (%test-final-report-simple runner log)))) + +(define (%test-format-line runner) + (let* ((line-info (test-result-alist runner)) + (source-file (assq 'source-file line-info)) + (source-line (assq 'source-line line-info)) + (file (if source-file (cdr source-file) ""))) + (if source-line + (string-append file ":" + (number->string (cdr source-line)) ": ") + ""))) + +(define (%test-end suite-name line-info) + (let* ((r (test-runner-get)) + (groups (test-runner-group-stack r)) + (line (%test-format-line r))) + (test-result-alist! r line-info) + (if (null? groups) + (let ((msg (string-append line "test-end not in a group"))) + (cond-expand + (srfi-23 (error msg)) + (else (display msg) (newline))))) + (if (and suite-name (not (equal? suite-name (car groups)))) + ((test-runner-on-bad-end-name r) r suite-name (car groups))) + (let* ((count-list (%test-runner-count-list r)) + (expected-count (cdar count-list)) + (saved-count (caar count-list)) + (group-count (- (%test-runner-total-count r) saved-count))) + (if (and expected-count + (not (= expected-count group-count))) + ((test-runner-on-bad-count r) r group-count expected-count)) + ((test-runner-on-group-end r) r) + (test-runner-group-stack! r (cdr (test-runner-group-stack r))) + (%test-runner-skip-list! r (car (%test-runner-skip-save r))) + (%test-runner-skip-save! r (cdr (%test-runner-skip-save r))) + (%test-runner-fail-list! r (car (%test-runner-fail-save r))) + (%test-runner-fail-save! r (cdr (%test-runner-fail-save r))) + (%test-runner-count-list! r (cdr count-list)) + (if (null? (test-runner-group-stack r)) + ((test-runner-on-final r) r))))) + +(define-syntax test-group + (syntax-rules () + ((test-group suite-name . body) + (let ((r (test-runner-current))) + ;; Ideally should also set line-number, if available. + (test-result-alist! r (list (cons 'test-name suite-name))) + (if (%test-should-execute r) + (dynamic-wind + (lambda () (test-begin suite-name)) + (lambda () . body) + (lambda () (test-end suite-name)))))))) + +(define-syntax test-group-with-cleanup + (syntax-rules () + ((test-group-with-cleanup suite-name form cleanup-form) + (test-group suite-name + (dynamic-wind + (lambda () #f) + (lambda () form) + (lambda () cleanup-form)))) + ((test-group-with-cleanup suite-name cleanup-form) + (test-group-with-cleanup suite-name #f cleanup-form)) + ((test-group-with-cleanup suite-name form1 form2 form3 . rest) + (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest)))) + +(define (test-on-test-begin-simple runner) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (let* ((results (test-result-alist runner)) + (source-file (assq 'source-file results)) + (source-line (assq 'source-line results)) + (source-form (assq 'source-form results)) + (test-name (assq 'test-name results))) + (display "Test begin:" log) + (newline log) + (if test-name (%test-write-result1 test-name log)) + (if source-file (%test-write-result1 source-file log)) + (if source-line (%test-write-result1 source-line log)) + (if source-form (%test-write-result1 source-form log)))))) + +(define-syntax test-result-ref + (syntax-rules () + ((test-result-ref runner pname) + (test-result-ref runner pname #f)) + ((test-result-ref runner pname default) + (let ((p (assq pname (test-result-alist runner)))) + (if p (cdr p) default))))) + +(define (test-on-test-end-simple runner) + (let ((log (test-runner-aux-value runner)) + (kind (test-result-ref runner 'result-kind))) + (if (memq kind '(fail xpass)) + (let* ((results (test-result-alist runner)) + (source-file (assq 'source-file results)) + (source-line (assq 'source-line results)) + (test-name (assq 'test-name results))) + (if (or source-file source-line) + (begin + (if source-file (display (cdr source-file))) + (display ":") + (if source-line (display (cdr source-line))) + (display ": "))) + (display (if (eq? kind 'xpass) "XPASS" "FAIL")) + (if test-name + (begin + (display " ") + (display (cdr test-name)))) + (newline))) + (if (output-port? log) + (begin + (display "Test end:" log) + (newline log) + (let loop ((list (test-result-alist runner))) + (if (pair? list) + (let ((pair (car list))) + ;; Write out properties not written out by on-test-begin. + (if (not (memq (car pair) + '(test-name source-file source-line source-form))) + (%test-write-result1 pair log)) + (loop (cdr list))))))))) + +(define (%test-write-result1 pair port) + (display " " port) + (display (car pair) port) + (display ": " port) + (write (cdr pair) port) + (newline port)) + +(define (test-result-set! runner pname value) + (let* ((alist (test-result-alist runner)) + (p (assq pname alist))) + (if p + (set-cdr! p value) + (test-result-alist! runner (cons (cons pname value) alist))))) + +(define (test-result-clear runner) + (test-result-alist! runner '())) + +(define (test-result-remove runner pname) + (let* ((alist (test-result-alist runner)) + (p (assq pname alist))) + (if p + (test-result-alist! runner + (let loop ((r alist)) + (if (eq? r p) (cdr r) + (cons (car r) (loop (cdr r))))))))) + +(define (test-result-kind . rest) + (let ((runner (if (pair? rest) (car rest) (test-runner-current)))) + (test-result-ref runner 'result-kind))) + +(define (test-passed? . rest) + (let ((runner (if (pair? rest) (car rest) (test-runner-get)))) + (memq (test-result-ref runner 'result-kind) '(pass xpass)))) + +(define (%test-report-result) + (let* ((r (test-runner-get)) + (result-kind (test-result-kind r))) + (case result-kind + ((pass) + (test-runner-pass-count! r (+ 1 (test-runner-pass-count r)))) + ((fail) + (test-runner-fail-count! r (+ 1 (test-runner-fail-count r)))) + ((xpass) + (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r)))) + ((xfail) + (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r)))) + (else + (test-runner-skip-count! r (+ 1 (test-runner-skip-count r))))) + (%test-runner-total-count! r (+ 1 (%test-runner-total-count r))) + ((test-runner-on-test-end r) r))) + +(cond-expand + (guile + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (catch #t + (lambda () test-expression) + (lambda (key . args) + (test-result-set! (test-runner-current) 'actual-error + (cons key args)) + #f)))))) + (kawa + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (try-catch test-expression + (ex <java.lang.Throwable> + (test-result-set! (test-runner-current) 'actual-error ex) + #f)))))) + (srfi-34 + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (guard (err (else #f)) test-expression))))) + (chicken + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (condition-case test-expression (ex () #f)))))) + (else + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + test-expression))))) + +(cond-expand + ((or kawa mzscheme) + (cond-expand + (mzscheme + (define-for-syntax (%test-syntax-file form) + (let ((source (syntax-source form))) + (cond ((string? source) file) + ((path? source) (path->string source)) + (else #f))))) + (kawa + (define (%test-syntax-file form) + (syntax-source form)))) + (define (%test-source-line2 form) + (let* ((line (syntax-line form)) + (file (%test-syntax-file form)) + (line-pair (if line (list (cons 'source-line line)) '()))) + (cons (cons 'source-form (syntax-object->datum form)) + (if file (cons (cons 'source-file file) line-pair) line-pair))))) + (guile-2 + (define (%test-source-line2 form) + (let* ((src-props (syntax-source form)) + (file (and src-props (assq-ref src-props 'filename))) + (line (and src-props (assq-ref src-props 'line))) + (file-alist (if file + `((source-file . ,file)) + '())) + (line-alist (if line + `((source-line . ,(+ line 1))) + '()))) + (datum->syntax (syntax here) + `((source-form . ,(syntax->datum form)) + ,@file-alist + ,@line-alist))))) + (else + (define (%test-source-line2 form) + '()))) + +(define (%test-on-test-begin r) + (%test-should-execute r) + ((test-runner-on-test-begin r) r) + (not (eq? 'skip (test-result-ref r 'result-kind)))) + +(define (%test-on-test-end r result) + (test-result-set! r 'result-kind + (if (eq? (test-result-ref r 'result-kind) 'xfail) + (if result 'xpass 'xfail) + (if result 'pass 'fail)))) + +(define (test-runner-test-name runner) + (test-result-ref runner 'test-name "")) + +(define-syntax %test-comp2body + (syntax-rules () + ((%test-comp2body r comp expected expr) + (let () + (if (%test-on-test-begin r) + (let ((exp expected)) + (test-result-set! r 'expected-value exp) + (let ((res (%test-evaluate-with-catch expr))) + (test-result-set! r 'actual-value res) + (%test-on-test-end r (comp exp res))))) + (%test-report-result))))) + +(define (%test-approximate= error) + (lambda (value expected) + (let ((rval (real-part value)) + (ival (imag-part value)) + (rexp (real-part expected)) + (iexp (imag-part expected))) + (and (>= rval (- rexp error)) + (>= ival (- iexp error)) + (<= rval (+ rexp error)) + (<= ival (+ iexp error)))))) + +(define-syntax %test-comp1body + (syntax-rules () + ((%test-comp1body r expr) + (let () + (if (%test-on-test-begin r) + (let () + (let ((res (%test-evaluate-with-catch expr))) + (test-result-set! r 'actual-value res) + (%test-on-test-end r res)))) + (%test-report-result))))) + +(cond-expand + ((or kawa mzscheme guile-2) + ;; Should be made to work for any Scheme with syntax-case + ;; However, I haven't gotten the quoting working. FIXME. + (define-syntax test-end + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac suite-name) line) + (syntax + (%test-end suite-name line))) + (((mac) line) + (syntax + (%test-end #f line)))))) + (define-syntax test-assert + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac tname expr) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-comp1body r expr)))) + (((mac expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-comp1body r expr))))))) + (define (%test-comp2 comp x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) () + (((mac tname expected expr) line comp) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-comp2body r comp expected expr)))) + (((mac expected expr) line comp) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-comp2body r comp expected expr)))))) + (define-syntax test-eqv + (lambda (x) (%test-comp2 (syntax eqv?) x))) + (define-syntax test-eq + (lambda (x) (%test-comp2 (syntax eq?) x))) + (define-syntax test-equal + (lambda (x) (%test-comp2 (syntax equal?) x))) + (define-syntax test-approximate ;; FIXME - needed for non-Kawa + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac tname expected expr error) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-comp2body r (%test-approximate= error) expected expr)))) + (((mac expected expr error) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-comp2body r (%test-approximate= error) expected expr)))))))) + (else + (define-syntax test-end + (syntax-rules () + ((test-end) + (%test-end #f '())) + ((test-end suite-name) + (%test-end suite-name '())))) + (define-syntax test-assert + (syntax-rules () + ((test-assert tname test-expression) + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r '((test-name . tname))) + (%test-comp1body r test-expression))) + ((test-assert test-expression) + (let* ((r (test-runner-get))) + (test-result-alist! r '()) + (%test-comp1body r test-expression))))) + (define-syntax %test-comp2 + (syntax-rules () + ((%test-comp2 comp tname expected expr) + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (list (cons 'test-name tname))) + (%test-comp2body r comp expected expr))) + ((%test-comp2 comp expected expr) + (let* ((r (test-runner-get))) + (test-result-alist! r '()) + (%test-comp2body r comp expected expr))))) + (define-syntax test-equal + (syntax-rules () + ((test-equal . rest) + (%test-comp2 equal? . rest)))) + (define-syntax test-eqv + (syntax-rules () + ((test-eqv . rest) + (%test-comp2 eqv? . rest)))) + (define-syntax test-eq + (syntax-rules () + ((test-eq . rest) + (%test-comp2 eq? . rest)))) + (define-syntax test-approximate + (syntax-rules () + ((test-approximate tname expected expr error) + (%test-comp2 (%test-approximate= error) tname expected expr)) + ((test-approximate expected expr error) + (%test-comp2 (%test-approximate= error) expected expr)))))) + +(cond-expand + (guile + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (cond ((%test-on-test-begin r) + (let ((et etype)) + (test-result-set! r 'expected-error et) + (%test-on-test-end r + (catch #t + (lambda () + (test-result-set! r 'actual-value expr) + #f) + (lambda (key . args) + ;; TODO: decide how to specify expected + ;; error types for Guile. + (test-result-set! r 'actual-error + (cons key args)) + #t))) + (%test-report-result)))))))) + (mzscheme + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t))) + (let () + (test-result-set! r 'actual-value expr) + #f))))))) + (chicken + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (condition-case expr (ex () #t))))))) + (kawa + (define-syntax %test-error + (syntax-rules () + ((%test-error r #t expr) + (cond ((%test-on-test-begin r) + (test-result-set! r 'expected-error #t) + (%test-on-test-end r + (try-catch + (let () + (test-result-set! r 'actual-value expr) + #f) + (ex <java.lang.Throwable> + (test-result-set! r 'actual-error ex) + #t))) + (%test-report-result)))) + ((%test-error r etype expr) + (if (%test-on-test-begin r) + (let ((et etype)) + (test-result-set! r 'expected-error et) + (%test-on-test-end r + (try-catch + (let () + (test-result-set! r 'actual-value expr) + #f) + (ex <java.lang.Throwable> + (test-result-set! r 'actual-error ex) + (cond ((and (instance? et <gnu.bytecode.ClassType>) + (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>)) + (instance? ex et)) + (else #t))))) + (%test-report-result))))))) + ((and srfi-34 srfi-35) + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (guard (ex ((condition-type? etype) + (and (condition? ex) (condition-has-type? ex etype))) + ((procedure? etype) + (etype ex)) + ((equal? etype #t) + #t) + (else #t)) + expr #f)))))) + (srfi-34 + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (guard (ex (else #t)) expr #f)))))) + (else + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (begin + ((test-runner-on-test-begin r) r) + (test-result-set! r 'result-kind 'skip) + (%test-report-result))))))) + +(cond-expand + ((or kawa mzscheme guile-2) + + (define-syntax test-error + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac tname etype expr) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-error r etype expr)))) + (((mac etype expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r etype expr)))) + (((mac expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r #t expr)))))))) + (else + (define-syntax test-error + (syntax-rules () + ((test-error name etype expr) + (let ((r (test-runner-get))) + (test-result-alist! r `((test-name . ,name))) + (%test-error r etype expr))) + ((test-error etype expr) + (let ((r (test-runner-get))) + (test-result-alist! r '()) + (%test-error r etype expr))) + ((test-error expr) + (let ((r (test-runner-get))) + (test-result-alist! r '()) + (%test-error r #t expr))))))) + +(define (test-apply first . rest) + (if (test-runner? first) + (test-with-runner first (apply test-apply rest)) + (let ((r (test-runner-current))) + (if r + (let ((run-list (%test-runner-run-list r))) + (cond ((null? rest) + (%test-runner-run-list! r (reverse run-list)) + (first)) ;; actually apply procedure thunk + (else + (%test-runner-run-list! + r + (if (eq? run-list #t) (list first) (cons first run-list))) + (apply test-apply rest) + (%test-runner-run-list! r run-list)))) + (let ((r (test-runner-create))) + (test-with-runner r (apply test-apply first rest)) + ((test-runner-on-final r) r)))))) + +(define-syntax test-with-runner + (syntax-rules () + ((test-with-runner runner form ...) + (let ((saved-runner (test-runner-current))) + (dynamic-wind + (lambda () (test-runner-current runner)) + (lambda () form ...) + (lambda () (test-runner-current saved-runner))))))) + +;;; Predicates + +(define (%test-match-nth n count) + (let ((i 0)) + (lambda (runner) + (set! i (+ i 1)) + (and (>= i n) (< i (+ n count)))))) + +(define-syntax test-match-nth + (syntax-rules () + ((test-match-nth n) + (test-match-nth n 1)) + ((test-match-nth n count) + (%test-match-nth n count)))) + +(define (%test-match-all . pred-list) + (lambda (runner) + (let ((result #t)) + (let loop ((l pred-list)) + (if (null? l) + result + (begin + (if (not ((car l) runner)) + (set! result #f)) + (loop (cdr l)))))))) + +(define-syntax test-match-all + (syntax-rules () + ((test-match-all pred ...) + (%test-match-all (%test-as-specifier pred) ...)))) + +(define (%test-match-any . pred-list) + (lambda (runner) + (let ((result #f)) + (let loop ((l pred-list)) + (if (null? l) + result + (begin + (if ((car l) runner) + (set! result #t)) + (loop (cdr l)))))))) + +(define-syntax test-match-any + (syntax-rules () + ((test-match-any pred ...) + (%test-match-any (%test-as-specifier pred) ...)))) + +;; Coerce to a predicate function: +(define (%test-as-specifier specifier) + (cond ((procedure? specifier) specifier) + ((integer? specifier) (test-match-nth 1 specifier)) + ((string? specifier) (test-match-name specifier)) + (else + (error "not a valid test specifier")))) + +(define-syntax test-skip + (syntax-rules () + ((test-skip pred ...) + (let ((runner (test-runner-get))) + (%test-runner-skip-list! runner + (cons (test-match-all (%test-as-specifier pred) ...) + (%test-runner-skip-list runner))))))) + +(define-syntax test-expect-fail + (syntax-rules () + ((test-expect-fail pred ...) + (let ((runner (test-runner-get))) + (%test-runner-fail-list! runner + (cons (test-match-all (%test-as-specifier pred) ...) + (%test-runner-fail-list runner))))))) + +(define (test-match-name name) + (lambda (runner) + (equal? name (test-runner-test-name runner)))) + +(define (test-read-eval-string string) + (let* ((port (open-input-string string)) + (form (read port))) + (if (eof-object? (read-char port)) + (cond-expand + (guile (eval form (current-module))) + (else (eval form))) + (cond-expand + (srfi-23 (error "(not at eof)")) + (else "error"))))) + diff --git a/module/srfi/srfi-67.scm b/module/srfi/srfi-67.scm new file mode 100644 index 000000000..6d9d4c5ad --- /dev/null +++ b/module/srfi/srfi-67.scm @@ -0,0 +1,88 @@ +;;; srfi-67.scm --- Compare Procedures + +;; Copyright (C) 2010 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 3 of the License, or (at your option) any later version. + +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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, see +;; <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This module is not yet documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-67) + #:export (</<=? + </<? + <=/<=? + <=/<? + <=? + <? + =? + >/>=? + >/>? + >=/>=? + >=/>? + >=? + >? + boolean-compare + chain<=? + chain<? + chain=? + chain>=? + chain>? + char-compare + char-compare-ci + compare-by< + compare-by<= + compare-by=/< + compare-by=/> + compare-by> + compare-by>= + complex-compare + cond-compare + debug-compare + default-compare + if-not=? + if3 + if<=? + if<? + if=? + if>=? + if>? + integer-compare + kth-largest + list-compare + list-compare-as-vector + max-compare + min-compare + not=? + number-compare + pair-compare + pair-compare-car + pair-compare-cdr + pairwise-not=? + rational-compare + real-compare + refine-compare + select-compare + symbol-compare + vector-compare + vector-compare-as-list) + #:replace (string-compare string-compare-ci) + #:use-module (srfi srfi-27)) + +(cond-expand-provide (current-module) '(srfi-67)) + +(include-from-path "srfi/srfi-67/compare.scm") diff --git a/module/srfi/srfi-67/compare.scm b/module/srfi/srfi-67/compare.scm new file mode 100644 index 000000000..767f3dba0 --- /dev/null +++ b/module/srfi/srfi-67/compare.scm @@ -0,0 +1,686 @@ +; Copyright (c) 2011 Free Software Foundation, Inc. +; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard. +; +; Permission is hereby granted, free of charge, to any person obtaining +; a copy of this software and associated documentation files (the +; ``Software''), to deal in the Software without restriction, including +; without limitation the rights to use, copy, modify, merge, publish, +; distribute, sublicense, and/or sell copies of the Software, and to +; permit persons to whom the Software is furnished to do so, subject to +; the following conditions: +; +; The above copyright notice and this permission notice shall be +; included in all copies or substantial portions of the Software. +; +; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, +; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +; +; ----------------------------------------------------------------------- +; +; Compare procedures SRFI (reference implementation) +; Sebastian.Egner@philips.com, Jensaxel@soegaard.net +; history of this file: +; SE, 14-Oct-2004: first version +; SE, 18-Oct-2004: 1st redesign: axioms for 'compare function' +; SE, 29-Oct-2004: 2nd redesign: higher order reverse/map/refine/unite +; SE, 2-Nov-2004: 3rd redesign: macros cond/refine-compare replace h.o.f's +; SE, 10-Nov-2004: (im,re) replaced by (re,im) in complex-compare +; SE, 11-Nov-2004: case-compare by case (not by cond); select-compare added +; SE, 12-Jan-2005: pair-compare-cdr +; SE, 15-Feb-2005: stricter typing for compare-<type>; pairwise-not=? +; SE, 16-Feb-2005: case-compare -> if-compare -> if3; <? </<? chain<? etc. +; JS, 24-Feb-2005: selection-compare added +; SE, 25-Feb-2005: selection-compare -> kth-largest modified; if<? etc. +; JS, 28-Feb-2005: kth-largest modified - is "stable" now +; SE, 28-Feb-2005: simplified pairwise-not=?/kth-largest; min/max debugged +; SE, 07-Apr-2005: compare-based type checks made explicit +; SE, 18-Apr-2005: added (rel? compare) and eq?-test +; SE, 16-May-2005: naming convention changed; compare-by< etc. optional x y + +; ============================================================================= + +; Reference Implementation +; ======================== +; +; in R5RS (including hygienic macros) +; + SRFI-16 (case-lambda) +; + SRFI-23 (error) +; + SRFI-27 (random-integer) + +; Implementation remarks: +; * In general, the emphasis of this implementation is on correctness +; and portability, not on efficiency. +; * Variable arity procedures are expressed in terms of case-lambda +; in the hope that this will produce efficient code for the case +; where the arity is statically known at the call site. +; * In procedures that are required to type-check their arguments, +; we use (compare x x) for executing extra checks. This relies on +; the assumption that eq? is used to catch this case quickly. +; * Care has been taken to reference comparison procedures of R5RS +; only at the time the operations here are being defined. This +; makes it possible to redefine these operations, if need be. +; * For the sake of efficiency, some inlining has been done by hand. +; This is mainly expressed by macros producing defines. +; * Identifiers of the form compare:<something> are private. +; +; Hints for low-level implementation: +; * The basis of this SRFI are the atomic compare procedures, +; i.e. boolean-compare, char-compare, etc. and the conditionals +; if3, if=?, if<? etc., and default-compare. These should make +; optimal use of the available type information. +; * For the sake of speed, the reference implementation does not +; use a LET to save the comparison value c for the ERROR call. +; This can be fixed in a low-level implementation at no cost. +; * Type-checks based on (compare x x) are made explicit by the +; expression (compare:check result compare x ...). +; * Eq? should can used to speed up built-in compare procedures, +; but it can only be used after type-checking at least one of +; the arguments. + +(define (compare:checked result compare . args) + (for-each (lambda (x) (compare x x)) args) + result) + + +; 3-sided conditional + +(define-syntax-rule (if3 c less equal greater) + (case c + ((-1) less) + (( 0) equal) + (( 1) greater) + (else (error "comparison value not in {-1,0,1}")))) + + +; 2-sided conditionals for comparisons + +(define-syntax compare:if-rel? + (syntax-rules () + ((compare:if-rel? c-cases a-cases c consequence) + (compare:if-rel? c-cases a-cases c consequence (if #f #f))) + ((compare:if-rel? c-cases a-cases c consequence alternate) + (case c + (c-cases consequence) + (a-cases alternate) + (else (error "comparison value not in {-1,0,1}")))))) + +(define-syntax-rule (if=? arg ...) + (compare:if-rel? (0) (-1 1) arg ...)) + +(define-syntax-rule (if<? arg ...) + (compare:if-rel? (-1) (0 1) arg ...)) + +(define-syntax-rule (if>? arg ...) + (compare:if-rel? (1) (-1 0) arg ...)) + +(define-syntax-rule (if<=? arg ...) + (compare:if-rel? (-1 0) (1) arg ...)) + +(define-syntax-rule (if>=? arg ...) + (compare:if-rel? (0 1) (-1) arg ...)) + +(define-syntax-rule (if-not=? arg ...) + (compare:if-rel? (-1 1) (0) arg ...)) + + +; predicates from compare procedures + +(define-syntax-rule (compare:define-rel? rel? if-rel?) + (define rel? + (case-lambda + (() (lambda (x y) (if-rel? (default-compare x y) #t #f))) + ((compare) (lambda (x y) (if-rel? (compare x y) #t #f))) + ((x y) (if-rel? (default-compare x y) #t #f)) + ((compare x y) + (if (procedure? compare) + (if-rel? (compare x y) #t #f) + (error "not a procedure (Did you mean rel/rel??): " compare)))))) + +(compare:define-rel? =? if=?) +(compare:define-rel? <? if<?) +(compare:define-rel? >? if>?) +(compare:define-rel? <=? if<=?) +(compare:define-rel? >=? if>=?) +(compare:define-rel? not=? if-not=?) + + +; chains of length 3 + +(define-syntax-rule (compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?) + (define rel1/rel2? + (case-lambda + (() + (lambda (x y z) + (if-rel1? (default-compare x y) + (if-rel2? (default-compare y z) #t #f) + (compare:checked #f default-compare z)))) + ((compare) + (lambda (x y z) + (if-rel1? (compare x y) + (if-rel2? (compare y z) #t #f) + (compare:checked #f compare z)))) + ((x y z) + (if-rel1? (default-compare x y) + (if-rel2? (default-compare y z) #t #f) + (compare:checked #f default-compare z))) + ((compare x y z) + (if-rel1? (compare x y) + (if-rel2? (compare y z) #t #f) + (compare:checked #f compare z)))))) + +(compare:define-rel1/rel2? </<? if<? if<?) +(compare:define-rel1/rel2? </<=? if<? if<=?) +(compare:define-rel1/rel2? <=/<? if<=? if<?) +(compare:define-rel1/rel2? <=/<=? if<=? if<=?) +(compare:define-rel1/rel2? >/>? if>? if>?) +(compare:define-rel1/rel2? >/>=? if>? if>=?) +(compare:define-rel1/rel2? >=/>? if>=? if>?) +(compare:define-rel1/rel2? >=/>=? if>=? if>=?) + + +; chains of arbitrary length + +(define-syntax-rule (compare:define-chain-rel? chain-rel? if-rel?) + (define chain-rel? + (case-lambda + ((compare) + #t) + ((compare x1) + (compare:checked #t compare x1)) + ((compare x1 x2) + (if-rel? (compare x1 x2) #t #f)) + ((compare x1 x2 x3) + (if-rel? (compare x1 x2) + (if-rel? (compare x2 x3) #t #f) + (compare:checked #f compare x3))) + ((compare x1 x2 . x3+) + (if-rel? (compare x1 x2) + (let chain? ((head x2) (tail x3+)) + (if (null? tail) + #t + (if-rel? (compare head (car tail)) + (chain? (car tail) (cdr tail)) + (apply compare:checked #f + compare (cdr tail))))) + (apply compare:checked #f compare x3+)))))) + +(compare:define-chain-rel? chain=? if=?) +(compare:define-chain-rel? chain<? if<?) +(compare:define-chain-rel? chain>? if>?) +(compare:define-chain-rel? chain<=? if<=?) +(compare:define-chain-rel? chain>=? if>=?) + + +; pairwise inequality + +(define pairwise-not=? + (let ((= =) (<= <=)) + (case-lambda + ((compare) + #t) + ((compare x1) + (compare:checked #t compare x1)) + ((compare x1 x2) + (if-not=? (compare x1 x2) #t #f)) + ((compare x1 x2 x3) + (if-not=? (compare x1 x2) + (if-not=? (compare x2 x3) + (if-not=? (compare x1 x3) #t #f) + #f) + (compare:checked #f compare x3))) + ((compare . x1+) + (let unequal? ((x x1+) (n (length x1+)) (unchecked? #t)) + (if (< n 2) + (if (and unchecked? (= n 1)) + (compare:checked #t compare (car x)) + #t) + (let* ((i-pivot (random-integer n)) + (x-pivot (list-ref x i-pivot))) + (let split ((i 0) (x x) (x< '()) (x> '())) + (if (null? x) + (and (unequal? x< (length x<) #f) + (unequal? x> (length x>) #f)) + (if (= i i-pivot) + (split (+ i 1) (cdr x) x< x>) + (if3 (compare (car x) x-pivot) + (split (+ i 1) (cdr x) (cons (car x) x<) x>) + (if unchecked? + (apply compare:checked #f compare (cdr x)) + #f) + (split (+ i 1) (cdr x) x< (cons (car x) x>))))))))))))) + + +; min/max + +(define min-compare + (case-lambda + ((compare x1) + (compare:checked x1 compare x1)) + ((compare x1 x2) + (if<=? (compare x1 x2) x1 x2)) + ((compare x1 x2 x3) + (if<=? (compare x1 x2) + (if<=? (compare x1 x3) x1 x3) + (if<=? (compare x2 x3) x2 x3))) + ((compare x1 x2 x3 x4) + (if<=? (compare x1 x2) + (if<=? (compare x1 x3) + (if<=? (compare x1 x4) x1 x4) + (if<=? (compare x3 x4) x3 x4)) + (if<=? (compare x2 x3) + (if<=? (compare x2 x4) x2 x4) + (if<=? (compare x3 x4) x3 x4)))) + ((compare x1 x2 . x3+) + (let min ((xmin (if<=? (compare x1 x2) x1 x2)) (xs x3+)) + (if (null? xs) + xmin + (min (if<=? (compare xmin (car xs)) xmin (car xs)) + (cdr xs))))))) + +(define max-compare + (case-lambda + ((compare x1) + (compare:checked x1 compare x1)) + ((compare x1 x2) + (if>=? (compare x1 x2) x1 x2)) + ((compare x1 x2 x3) + (if>=? (compare x1 x2) + (if>=? (compare x1 x3) x1 x3) + (if>=? (compare x2 x3) x2 x3))) + ((compare x1 x2 x3 x4) + (if>=? (compare x1 x2) + (if>=? (compare x1 x3) + (if>=? (compare x1 x4) x1 x4) + (if>=? (compare x3 x4) x3 x4)) + (if>=? (compare x2 x3) + (if>=? (compare x2 x4) x2 x4) + (if>=? (compare x3 x4) x3 x4)))) + ((compare x1 x2 . x3+) + (let max ((xmax (if>=? (compare x1 x2) x1 x2)) (xs x3+)) + (if (null? xs) + xmax + (max (if>=? (compare xmax (car xs)) xmax (car xs)) + (cdr xs))))))) + + +; kth-largest + +(define kth-largest + (let ((= =) (< <)) + (case-lambda + ((compare k x0) + (case (modulo k 1) + ((0) (compare:checked x0 compare x0)) + (else (error "bad index" k)))) + ((compare k x0 x1) + (case (modulo k 2) + ((0) (if<=? (compare x0 x1) x0 x1)) + ((1) (if<=? (compare x0 x1) x1 x0)) + (else (error "bad index" k)))) + ((compare k x0 x1 x2) + (case (modulo k 3) + ((0) (if<=? (compare x0 x1) + (if<=? (compare x0 x2) x0 x2) + (if<=? (compare x1 x2) x1 x2))) + ((1) (if3 (compare x0 x1) + (if<=? (compare x1 x2) + x1 + (if<=? (compare x0 x2) x2 x0)) + (if<=? (compare x0 x2) x1 x0) + (if<=? (compare x0 x2) + x0 + (if<=? (compare x1 x2) x2 x1)))) + ((2) (if<=? (compare x0 x1) + (if<=? (compare x1 x2) x2 x1) + (if<=? (compare x0 x2) x2 x0))) + (else (error "bad index" k)))) + ((compare k x0 . x1+) ; |x1+| >= 1 + (if (not (and (integer? k) (exact? k))) + (error "bad index" k)) + (let ((n (+ 1 (length x1+)))) + (let kth ((k (modulo k n)) + (n n) ; = |x| + (rev #t) ; are x<, x=, x> reversed? + (x (cons x0 x1+))) + (let ((pivot (list-ref x (random-integer n)))) + (let split ((x x) (x< '()) (n< 0) (x= '()) (n= 0) (x> '()) (n> 0)) + (if (null? x) + (cond + ((< k n<) + (kth k n< (not rev) x<)) + ((< k (+ n< n=)) + (if rev + (list-ref x= (- (- n= 1) (- k n<))) + (list-ref x= (- k n<)))) + (else + (kth (- k (+ n< n=)) n> (not rev) x>))) + (if3 (compare (car x) pivot) + (split (cdr x) (cons (car x) x<) (+ n< 1) x= n= x> n>) + (split (cdr x) x< n< (cons (car x) x=) (+ n= 1) x> n>) + (split (cdr x) x< n< x= n= (cons (car x) x>) (+ n> 1)))))))))))) + + +; compare functions from predicates + +(define compare-by< + (case-lambda + ((lt) (lambda (x y) (if (lt x y) -1 (if (lt y x) 1 0)))) + ((lt x y) (if (lt x y) -1 (if (lt y x) 1 0))))) + +(define compare-by> + (case-lambda + ((gt) (lambda (x y) (if (gt x y) 1 (if (gt y x) -1 0)))) + ((gt x y) (if (gt x y) 1 (if (gt y x) -1 0))))) + +(define compare-by<= + (case-lambda + ((le) (lambda (x y) (if (le x y) (if (le y x) 0 -1) 1))) + ((le x y) (if (le x y) (if (le y x) 0 -1) 1)))) + +(define compare-by>= + (case-lambda + ((ge) (lambda (x y) (if (ge x y) (if (ge y x) 0 1) -1))) + ((ge x y) (if (ge x y) (if (ge y x) 0 1) -1)))) + +(define compare-by=/< + (case-lambda + ((eq lt) (lambda (x y) (if (eq x y) 0 (if (lt x y) -1 1)))) + ((eq lt x y) (if (eq x y) 0 (if (lt x y) -1 1))))) + +(define compare-by=/> + (case-lambda + ((eq gt) (lambda (x y) (if (eq x y) 0 (if (gt x y) 1 -1)))) + ((eq gt x y) (if (eq x y) 0 (if (gt x y) 1 -1))))) + +; refine and extend construction + +(define-syntax refine-compare + (syntax-rules () + ((refine-compare) + 0) + ((refine-compare c1) + c1) + ((refine-compare c1 c2 cs ...) + (if3 c1 -1 (refine-compare c2 cs ...) 1)))) + +(define-syntax select-compare + (syntax-rules (else) + ((select-compare x y clause ...) + (let ((x-val x) (y-val y)) + (select-compare (x-val y-val clause ...)))) + ; used internally: (select-compare (x y clause ...)) + ((select-compare (x y)) + 0) + ((select-compare (x y (else c ...))) + (refine-compare c ...)) + ((select-compare (x y (t? c ...) clause ...)) + (let ((t?-val t?)) + (let ((tx (t?-val x)) (ty (t?-val y))) + (if tx + (if ty (refine-compare c ...) -1) + (if ty 1 (select-compare (x y clause ...))))))))) + +(define-syntax cond-compare + (syntax-rules (else) + ((cond-compare) + 0) + ((cond-compare (else cs ...)) + (refine-compare cs ...)) + ((cond-compare ((tx ty) cs ...) clause ...) + (let ((tx-val tx) (ty-val ty)) + (if tx-val + (if ty-val (refine-compare cs ...) -1) + (if ty-val 1 (cond-compare clause ...))))))) + + +; R5RS atomic types + +(define-syntax compare:type-check + (syntax-rules () + ((compare:type-check type? type-name x) + (if (not (type? x)) + (error (string-append "not " type-name ":") x))) + ((compare:type-check type? type-name x y) + (begin (compare:type-check type? type-name x) + (compare:type-check type? type-name y))))) + +(define-syntax-rule (compare:define-by=/< compare = < type? type-name) + (define compare + (let ((= =) (< <)) + (lambda (x y) + (if (type? x) + (if (eq? x y) + 0 + (if (type? y) + (if (= x y) 0 (if (< x y) -1 1)) + (error (string-append "not " type-name ":") y))) + (error (string-append "not " type-name ":") x)))))) + +(define (boolean-compare x y) + (compare:type-check boolean? "boolean" x y) + (if x (if y 0 1) (if y -1 0))) + +(compare:define-by=/< char-compare char=? char<? char? "char") + +(compare:define-by=/< char-compare-ci char-ci=? char-ci<? char? "char") + +(compare:define-by=/< string-compare string=? string<? string? "string") + +(compare:define-by=/< string-compare-ci string-ci=? string-ci<? string? "string") + +(define (symbol-compare x y) + (compare:type-check symbol? "symbol" x y) + (string-compare (symbol->string x) (symbol->string y))) + +(compare:define-by=/< integer-compare = < integer? "integer") + +(compare:define-by=/< rational-compare = < rational? "rational") + +(compare:define-by=/< real-compare = < real? "real") + +(define (complex-compare x y) + (compare:type-check complex? "complex" x y) + (if (and (real? x) (real? y)) + (real-compare x y) + (refine-compare (real-compare (real-part x) (real-part y)) + (real-compare (imag-part x) (imag-part y))))) + +(define (number-compare x y) + (compare:type-check number? "number" x y) + (complex-compare x y)) + + +; R5RS compound data structures: dotted pair, list, vector + +(define (pair-compare-car compare) + (lambda (x y) + (compare (car x) (car y)))) + +(define (pair-compare-cdr compare) + (lambda (x y) + (compare (cdr x) (cdr y)))) + +(define pair-compare + (case-lambda + + ; dotted pair + ((pair-compare-car pair-compare-cdr x y) + (refine-compare (pair-compare-car (car x) (car y)) + (pair-compare-cdr (cdr x) (cdr y)))) + + ; possibly improper lists + ((compare x y) + (cond-compare + (((null? x) (null? y)) 0) + (((pair? x) (pair? y)) (compare (car x) (car y)) + (pair-compare compare (cdr x) (cdr y))) + (else (compare x y)))) + + ; for convenience + ((x y) + (pair-compare default-compare x y)))) + +(define list-compare + (case-lambda + ((compare x y empty? head tail) + (cond-compare + (((empty? x) (empty? y)) 0) + (else (compare (head x) (head y)) + (list-compare compare (tail x) (tail y) empty? head tail)))) + + ; for convenience + (( x y empty? head tail) + (list-compare default-compare x y empty? head tail)) + ((compare x y ) + (list-compare compare x y null? car cdr)) + (( x y ) + (list-compare default-compare x y null? car cdr)))) + +(define list-compare-as-vector + (case-lambda + ((compare x y empty? head tail) + (refine-compare + (let compare-length ((x x) (y y)) + (cond-compare + (((empty? x) (empty? y)) 0) + (else (compare-length (tail x) (tail y))))) + (list-compare compare x y empty? head tail))) + + ; for convenience + (( x y empty? head tail) + (list-compare-as-vector default-compare x y empty? head tail)) + ((compare x y ) + (list-compare-as-vector compare x y null? car cdr)) + (( x y ) + (list-compare-as-vector default-compare x y null? car cdr)))) + +(define vector-compare + (let ((= =)) + (case-lambda + ((compare x y size ref) + (let ((n (size x)) (m (size y))) + (refine-compare + (integer-compare n m) + (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1] + (if (= i n) + 0 + (refine-compare (compare (ref x i) (ref y i)) + (compare-rest (+ i 1)))))))) + + ; for convenience + (( x y size ref) + (vector-compare default-compare x y size ref)) + ((compare x y ) + (vector-compare compare x y vector-length vector-ref)) + (( x y ) + (vector-compare default-compare x y vector-length vector-ref))))) + +(define vector-compare-as-list + (let ((= =)) + (case-lambda + ((compare x y size ref) + (let ((nx (size x)) (ny (size y))) + (let ((n (min nx ny))) + (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1] + (if (= i n) + (integer-compare nx ny) + (refine-compare (compare (ref x i) (ref y i)) + (compare-rest (+ i 1)))))))) + + ; for convenience + (( x y size ref) + (vector-compare-as-list default-compare x y size ref)) + ((compare x y ) + (vector-compare-as-list compare x y vector-length vector-ref)) + (( x y ) + (vector-compare-as-list default-compare x y vector-length vector-ref))))) + + +; default compare + +(define (default-compare x y) + (select-compare + x y + (null? 0) + (pair? (default-compare (car x) (car y)) + (default-compare (cdr x) (cdr y))) + (boolean? (boolean-compare x y)) + (char? (char-compare x y)) + (string? (string-compare x y)) + (symbol? (symbol-compare x y)) + (number? (number-compare x y)) + (vector? (vector-compare default-compare x y)) + (else (error "unrecognized type in default-compare" x y)))) + +; Note that we pass default-compare to compare-{pair,vector} explictly. +; This makes sure recursion proceeds with this default-compare, which +; need not be the one in the lexical scope of compare-{pair,vector}. + + +; debug compare + +(define (debug-compare c) + + (define (checked-value c x y) + (let ((c-xy (c x y))) + (if (or (eqv? c-xy -1) (eqv? c-xy 0) (eqv? c-xy 1)) + c-xy + (error "compare value not in {-1,0,1}" c-xy (list c x y))))) + + (define (random-boolean) + (zero? (random-integer 2))) + + (define q ; (u v w) such that u <= v, v <= w, and not u <= w + '#( + ;x < y x = y x > y [x < z] + 0 0 0 ; y < z + 0 (z y x) (z y x) ; y = z + 0 (z y x) (z y x) ; y > z + + ;x < y x = y x > y [x = z] + (y z x) (z x y) 0 ; y < z + (y z x) 0 (x z y) ; y = z + 0 (y x z) (x z y) ; y > z + + ;x < y x = y x > y [x > z] + (x y z) (x y z) 0 ; y < z + (x y z) (x y z) 0 ; y = z + 0 0 0 ; y > z + )) + + (let ((z? #f) (z #f)) ; stored element from previous call + (lambda (x y) + (let ((c-xx (checked-value c x x)) + (c-yy (checked-value c y y)) + (c-xy (checked-value c x y)) + (c-yx (checked-value c y x))) + (if (not (zero? c-xx)) + (error "compare error: not reflexive" c x)) + (if (not (zero? c-yy)) + (error "compare error: not reflexive" c y)) + (if (not (zero? (+ c-xy c-yx))) + (error "compare error: not anti-symmetric" c x y)) + (if z? + (let ((c-xz (checked-value c x z)) + (c-zx (checked-value c z x)) + (c-yz (checked-value c y z)) + (c-zy (checked-value c z y))) + (if (not (zero? (+ c-xz c-zx))) + (error "compare error: not anti-symmetric" c x z)) + (if (not (zero? (+ c-yz c-zy))) + (error "compare error: not anti-symmetric" c y z)) + (let ((ijk (vector-ref q (+ c-xy (* 3 c-yz) (* 9 c-xz) 13)))) + (if (list? ijk) + (apply error + "compare error: not transitive" + c + (map (lambda (i) (case i ((x) x) ((y) y) ((z) z))) + ijk))))) + (set! z? #t)) + (set! z (if (random-boolean) x y)) ; randomized testing + c-xy)))) diff --git a/module/srfi/srfi-69.scm b/module/srfi/srfi-69.scm new file mode 100644 index 000000000..b9486c465 --- /dev/null +++ b/module/srfi/srfi-69.scm @@ -0,0 +1,336 @@ +;;; 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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 make-hash-table hash-table?)) + +(cond-expand-provide (current-module) '(srfi-69)) + +;;;; Internal helper macros + +;; Define these first, so the compiler will pick them up. + +;; 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)) + + +;;;; 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")) + +(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) + (call-with-values (lambda () (proc k v)) + (lambda vals 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-71.scm b/module/srfi/srfi-71.scm new file mode 100644 index 000000000..16c8e7f9c --- /dev/null +++ b/module/srfi/srfi-71.scm @@ -0,0 +1,267 @@ +;; Copyright (c) 2005 Sebastian Egner. +;; +;; Permission is hereby granted, free of charge, to any person obtaining a +;; copy of this software and associated documentation files (the +;; ``Software''), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be included +;; in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + +;; Reference implementation of SRFI-71 using PLT 208's modules +;; Sebastian.Egner@philips.com, 2005-04-29 +;; +;; Adjusted for Guile module system by +;; Christopher Allan Webber <cwebber@dustycloud.org>, 2017-06-29 + +(define-module (srfi srfi-71) + #:export (uncons unlist unvector values->list + values->vector) + #:replace ((srfi-let . let) + (srfi-let* . let*) + (srfi-letrec . letrec))) + +(cond-expand-provide (current-module) '(srfi-71)) + +(define-syntax r5rs-let + (syntax-rules () + ((r5rs-let ((v x) ...) body1 body ...) + (let ((v x) ...) body1 body ...)) + ((r5rs-let tag ((v x) ...) body1 body ...) + (let tag ((v x) ...) body1 body ...)))) + +(define-syntax r5rs-let* + (syntax-rules () + ((r5rs-let* ((v x) ...) body1 body ...) + (let* ((v x) ...) body1 body ...)))) + +(define-syntax r5rs-letrec + (syntax-rules () + ((r5rs-letrec ((v x) ...) body1 body ...) + (letrec ((v x) ...) body1 body ...)))) + +; --- textual copy of 'letvalues.scm' starts here --- + +; Reference implementation of SRFI-71 (generic part) +; Sebastian.Egner@philips.com, 20-May-2005, PLT 208 +; +; In order to avoid conflicts with the existing let etc. +; the macros defined here are called srfi-let etc., +; and they are defined in terms of r5rs-let etc. +; It is up to the actual implementation to save let/*/rec +; in r5rs-let/*/rec first and redefine let/*/rec +; by srfi-let/*/rec then. +; +; There is also a srfi-letrec* being defined (in view of R6RS.) +; +; Macros used internally are named i:<something>. +; +; Abbreviations for macro arguments: +; bs - <binding spec> +; b - component of a binding spec (values, <variable>, or <expression>) +; v - <variable> +; vr - <variable> for rest list +; x - <expression> +; t - newly introduced temporary variable +; vx - (<variable> <expression>) +; rec - flag if letrec is produced (and not let) +; cwv - call-with-value skeleton of the form (x formals) +; (call-with-values (lambda () x) (lambda formals /payload/)) +; where /payload/ is of the form (let (vx ...) body1 body ...). +; +; Remark (*): +; We bind the variables of a letrec to i:undefined since there is +; no portable (R5RS) way of binding a variable to a values that +; raises an error when read uninitialized. + +(define i:undefined 'undefined) + +(define-syntax srfi-letrec* ; -> srfi-letrec + (syntax-rules () + ((srfi-letrec* () body1 body ...) + (srfi-letrec () body1 body ...)) + ((srfi-letrec* (bs) body1 body ...) + (srfi-letrec (bs) body1 body ...)) + ((srfi-letrec* (bs1 bs2 bs ...) body1 body ...) + (srfi-letrec (bs1) (srfi-letrec* (bs2 bs ...) body1 body ...))))) + +(define-syntax srfi-letrec ; -> i:let + (syntax-rules () + ((srfi-letrec ((b1 b2 b ...) ...) body1 body ...) + (i:let "bs" #t () () (body1 body ...) ((b1 b2 b ...) ...))))) + +(define-syntax srfi-let* ; -> srfi-let + (syntax-rules () + ((srfi-let* () body1 body ...) + (srfi-let () body1 body ...)) + ((srfi-let* (bs) body1 body ...) + (srfi-let (bs) body1 body ...)) + ((srfi-let* (bs1 bs2 bs ...) body1 body ...) + (srfi-let (bs1) (srfi-let* (bs2 bs ...) body1 body ...))))) + +(define-syntax srfi-let ; -> i:let or i:named-let + (syntax-rules () + ((srfi-let ((b1 b2 b ...) ...) body1 body ...) + (i:let "bs" #f () () (body1 body ...) ((b1 b2 b ...) ...))) + ((srfi-let tag ((b1 b2 b ...) ...) body1 body ...) + (i:named-let tag () (body1 body ...) ((b1 b2 b ...) ...))))) + +(define-syntax i:let + (syntax-rules (values) + +; (i:let "bs" rec (cwv ...) (vx ...) body (bs ...)) +; processes the binding specs bs ... by adding call-with-values +; skeletons to cwv ... and bindings to vx ..., and afterwards +; wrapping the skeletons around the payload (let (vx ...) . body). + + ; no more bs to process -> wrap call-with-values skeletons + ((i:let "bs" rec (cwv ...) vxs body ()) + (i:let "wrap" rec vxs body cwv ...)) + + ; recognize form1 without variable -> dummy binding for side-effects + ((i:let "bs" rec cwvs (vx ...) body (((values) x) bs ...)) + (i:let "bs" rec cwvs (vx ... (dummy (begin x #f))) body (bs ...))) + + ; recognize form1 with single variable -> just extend vx ... + ((i:let "bs" rec cwvs (vx ...) body (((values v) x) bs ...)) + (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...))) + + ; recognize form1 without rest arg -> generate cwv + ((i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...)) + (i:let "form1" rec cwvs vxs body (bs ...) (x ()) (values v ...))) + + ; recognize form1 with rest arg -> generate cwv + ((i:let "bs" rec cwvs vxs body (((values . vs) x) bs ...)) + (i:let "form1+" rec cwvs vxs body (bs ...) (x ()) (values . vs))) + + ; recognize form2 with single variable -> just extend vx ... + ((i:let "bs" rec cwvs (vx ...) body ((v x) bs ...)) + (i:let "bs" rec cwvs (vx ... (v x)) body (bs ...))) + + ; recognize form2 with >=2 variables -> transform to form1 + ((i:let "bs" rec cwvs vxs body ((b1 b2 b3 b ...) bs ...)) + (i:let "form2" rec cwvs vxs body (bs ...) (b1 b2) (b3 b ...))) + +; (i:let "form1" rec cwvs vxs body bss (x (t ...)) (values v1 v2 v ...)) +; processes the variables in v1 v2 v ... adding them to (t ...) +; and producing a cwv when finished. There is not rest argument. + + ((i:let "form1" rec (cwv ...) vxs body bss (x ts) (values)) + (i:let "bs" rec (cwv ... (x ts)) vxs body bss)) + ((i:let "form1" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v ...)) + (i:let "form1" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v ...))) + +; (i:let "form1+" rec cwvs vxs body bss (x (t ...)) (values v ... . vr)) +; processes the variables in v ... . vr adding them to (t ...) +; and producing a cwv when finished. The rest arg is vr. + + ((i:let "form1+" rec cwvs (vx ...) body bss (x (t ...)) (values v1 v2 . vs)) + (i:let "form1+" rec cwvs (vx ... (v1 t1)) body bss (x (t ... t1)) (values v2 . vs))) + ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x (t ...)) (values v1 . vr)) + (i:let "bs" rec (cwv ... (x (t ... t1 . tr))) (vx ... (v1 t1) (vr tr)) body bss)) + ((i:let "form1+" rec (cwv ...) (vx ...) body bss (x ()) (values . vr)) + (i:let "bs" rec (cwv ... (x tr)) (vx ... (vr tr)) body bss)) + +; (i:let "form2" rec cwvs vxs body bss (v ...) (b ... x)) +; processes the binding items (b ... x) from form2 as in +; (v ... b ... x) into ((values v ... b ...) x), i.e. form1. +; Then call "bs" recursively. + + ((i:let "form2" rec cwvs vxs body (bs ...) (v ...) (x)) + (i:let "bs" rec cwvs vxs body (((values v ...) x) bs ...))) + ((i:let "form2" rec cwvs vxs body bss (v ...) (b1 b2 b ...)) + (i:let "form2" rec cwvs vxs body bss (v ... b1) (b2 b ...))) + +; (i:let "wrap" rec ((v x) ...) (body ...) cwv ...) +; wraps cwv ... around the payload generating the actual code. +; For letrec this is of course different than for let. + + ((i:let "wrap" #f vxs body) + (r5rs-let vxs . body)) + ((i:let "wrap" #f vxs body (x formals) cwv ...) + (call-with-values + (lambda () x) + (lambda formals (i:let "wrap" #f vxs body cwv ...)))) + + ((i:let "wrap" #t vxs body) + (r5rs-letrec vxs . body)) + ((i:let "wrap" #t ((v t) ...) body cwv ...) + (r5rs-let ((v i:undefined) ...) ; (*) + (i:let "wraprec" ((v t) ...) body cwv ...))) + +; (i:let "wraprec" ((v t) ...) body cwv ...) +; generate the inner code for a letrec. The variables v ... +; are the user-visible variables (bound outside), and t ... +; are the temporary variables bound by the cwv consumers. + + ((i:let "wraprec" ((v t) ...) (body ...)) + (begin (set! v t) ... (r5rs-let () body ...))) + ((i:let "wraprec" vxs body (x formals) cwv ...) + (call-with-values + (lambda () x) + (lambda formals (i:let "wraprec" vxs body cwv ...)))) + + )) + +(define-syntax i:named-let + (syntax-rules (values) + +; (i:named-let tag (vx ...) body (bs ...)) +; processes the binding specs bs ... by extracting the variable +; and expression, adding them to vx and turning the result into +; an ordinary named let. + + ((i:named-let tag vxs body ()) + (r5rs-let tag vxs . body)) + ((i:named-let tag (vx ...) body (((values v) x) bs ...)) + (i:named-let tag (vx ... (v x)) body (bs ...))) + ((i:named-let tag (vx ...) body ((v x) bs ...)) + (i:named-let tag (vx ... (v x)) body (bs ...))))) + +; --- standard procedures --- + +(define (uncons pair) + (values (car pair) (cdr pair))) + +(define (uncons-2 list) + (values (car list) (cadr list) (cddr list))) + +(define (uncons-3 list) + (values (car list) (cadr list) (caddr list) (cdddr list))) + +(define (uncons-4 list) + (values (car list) (cadr list) (caddr list) (cadddr list) (cddddr list))) + +(define (uncons-cons alist) + (values (caar alist) (cdar alist) (cdr alist))) + +(define (unlist list) + (apply values list)) + +(define (unvector vector) + (apply values (vector->list vector))) + +; --- standard macros --- + +(define-syntax values->list + (syntax-rules () + ((values->list x) + (call-with-values (lambda () x) list)))) + +(define-syntax values->vector + (syntax-rules () + ((values->vector x) + (call-with-values (lambda () x) vector)))) + +; --- textual copy of 'letvalues.scm' ends here --- diff --git a/module/srfi/srfi-8.scm b/module/srfi/srfi-8.scm new file mode 100644 index 000000000..ced123894 --- /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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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..043a4a78f --- /dev/null +++ b/module/srfi/srfi-88.scm @@ -0,0 +1,53 @@ +;;; srfi-88.scm --- Keyword Objects -*- coding: utf-8 -*- + +;; Copyright (C) 2008, 2009, 2010 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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)) + + +;; Change the keyword syntax both at compile time and run time; the latter is +;; useful at the REPL. +(eval-when (expand load eval) + (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..aee8be01c --- /dev/null +++ b/module/srfi/srfi-9.scm @@ -0,0 +1,348 @@ +;;; srfi-9.scm --- define-record-type + +;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012, +;; 2013, 2014, 2018 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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> <getter name>) +;; -> (<field tag> <getter name> <setter 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) + #:use-module (srfi srfi-1) + #:use-module (system base ck) + #:export (define-record-type)) + +(cond-expand-provide (current-module) '(srfi-9)) + +;; Roll our own instead of using the public `define-inlinable'. This is +;; because the public one has a different `make-procedure-name', so +;; using it would require users to recompile code that uses SRFI-9. See +;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>. +;; + +(define-syntax-rule (define-inlinable (name formals ...) body ...) + (define-tagged-inlinable () (name formals ...) body ...)) + +;; 'define-tagged-inlinable' has an additional feature: it stores a map +;; of keys to values that can be retrieved at expansion time. This is +;; currently used to retrieve the rtd id, field index, and record copier +;; macro for an arbitrary getter. + +(define-syntax-rule (%%on-error err) err) + +(define %%type #f) ; a private syntax literal +(define-syntax getter-type + (syntax-rules (quote) + ((_ s 'getter 'err) + (getter (%%on-error err) %%type s)))) + +(define %%index #f) ; a private syntax literal +(define-syntax getter-index + (syntax-rules (quote) + ((_ s 'getter 'err) + (getter (%%on-error err) %%index s)))) + +(define %%copier #f) ; a private syntax literal +(define-syntax getter-copier + (syntax-rules (quote) + ((_ s 'getter 'err) + (getter (%%on-error err) %%copier s)))) + +(define-syntax define-tagged-inlinable + (lambda (x) + (define (make-procedure-name name) + (datum->syntax name + (symbol-append '% (syntax->datum name) + '-procedure))) + + (syntax-case x () + ((_ ((key value) ...) (name formals ...) body ...) + (identifier? #'name) + (with-syntax ((proc-name (make-procedure-name #'name)) + ((args ...) (generate-temporaries #'(formals ...)))) + #`(begin + (define (proc-name formals ...) + body ...) + (define-syntax name + (lambda (x) + (syntax-case x (%%on-error key ...) + ((_ (%%on-error err) key s) #'(ck s 'value)) ... + ((_ args ...) + #'((lambda (formals ...) + body ...) + args ...)) + ((_ a (... ...)) + (syntax-violation 'name "Wrong number of arguments" x)) + (_ + (identifier? x) + #'proc-name)))))))))) + +(define (default-record-printer s p) + (display "#<" p) + (display (record-type-name (record-type-descriptor s)) p) + (let loop ((fields (record-type-fields (record-type-descriptor s))) + (off 0)) + (cond + ((not (null? fields)) + (display " " p) + (display (car fields) p) + (display ": " p) + (write (struct-ref s off) p) + (loop (cdr fields) (+ 1 off))))) + (display ">" p)) + +(define-syntax-rule (throw-bad-struct s who) + (let ((s* s)) + (throw 'wrong-type-arg who + "Wrong type argument: ~S" (list s*) + (list s*)))) + +(define (make-copier-id type-name) + (datum->syntax type-name + (symbol-append '%% (syntax->datum type-name) + '-set-fields))) + +(define-syntax %%set-fields + (lambda (x) + (syntax-case x () + ((_ type-name (getter-id ...) check? s (getter expr) ...) + (every identifier? #'(getter ...)) + (let ((copier-name (syntax->datum (make-copier-id #'type-name))) + (getter+exprs #'((getter expr) ...)) + (nfields (length #'(getter-id ...)))) + (define (lookup id default-expr) + (let ((results + (filter (lambda (g+e) + (free-identifier=? id (car g+e))) + getter+exprs))) + (case (length results) + ((0) default-expr) + ((1) (cadar results)) + (else (syntax-violation + copier-name "duplicate getter" x id))))) + (for-each (lambda (id) + (or (find (lambda (getter-id) + (free-identifier=? id getter-id)) + #'(getter-id ...)) + (syntax-violation + copier-name "unknown getter" x id))) + #'(getter ...)) + (with-syntax ((unsafe-expr + #`(make-struct/simple + type-name + #,@(map (lambda (getter index) + (lookup getter #`(struct-ref s #,index))) + #'(getter-id ...) + (iota nfields))))) + (if (syntax->datum #'check?) + #`(if (eq? (struct-vtable s) type-name) + unsafe-expr + (throw-bad-struct + s '#,(datum->syntax #'here copier-name))) + #'unsafe-expr))))))) + +(define-syntax %define-record-type + (lambda (x) + (define (field-identifiers field-specs) + (map (lambda (field-spec) + (syntax-case field-spec () + ((name getter) #'name) + ((name getter setter) #'name))) + field-specs)) + + (define (getter-identifiers field-specs) + (map (lambda (field-spec) + (syntax-case field-spec () + ((name getter) #'getter) + ((name getter setter) #'getter))) + field-specs)) + + (define (constructor form type-name constructor-spec field-ids) + (syntax-case constructor-spec () + ((ctor field ...) + (every identifier? #'(field ...)) + (letrec* ((id-list-contains? + (lambda (id-list id) + (and (not (null? id-list)) + (or (free-identifier=? (car id-list) id) + (id-list-contains? (cdr id-list) id))))) + (inits (map (lambda (id) + (and (id-list-contains? #'(field ...) id) id)) + field-ids))) + (for-each + (lambda (field) + (unless (id-list-contains? field-ids field) + (syntax-violation + (syntax-case form () ((macro . args) (syntax->datum #'macro))) + "unknown field in constructor spec" + form field))) + #'(field ...)) + #`(define-inlinable #,constructor-spec + (make-struct/simple #,type-name #,@inits)))))) + + (define (getters type-name getter-ids copier-id) + (map (lambda (getter index) + #`(define-tagged-inlinable + ((%%type #,type-name) + (%%index #,index) + (%%copier #,copier-id)) + (#,getter s) + (if (eq? (struct-vtable s) #,type-name) + (struct-ref s #,index) + (throw-bad-struct s '#,getter)))) + getter-ids + (iota (length getter-ids)))) + + (define (copier type-name getter-ids copier-id) + #`(define-syntax-rule + (#,copier-id check? s (getter expr) (... ...)) + (%%set-fields #,type-name #,getter-ids + check? s (getter expr) (... ...)))) + + (define (setters type-name field-specs) + (filter-map (lambda (field-spec index) + (syntax-case field-spec () + ((name getter) #f) + ((name getter setter) + #`(define-inlinable (setter s val) + (if (eq? (struct-vtable s) #,type-name) + (struct-set! s #,index val) + (throw-bad-struct s 'setter)))))) + field-specs + (iota (length field-specs)))) + + (define (functional-setters copier-id field-specs) + (filter-map (lambda (field-spec index) + (syntax-case field-spec () + ((name getter) #f) + ((name getter setter) + #`(define-inlinable (setter s val) + (#,copier-id #t s (getter val)))))) + field-specs + (iota (length field-specs)))) + + (define (record-layout immutable? count) + ;; Mutability is expressed on the record level; all structs in the + ;; future will be mutable. + (string-concatenate (make-list count "pw"))) + + (syntax-case x () + ((_ immutable? form type-name constructor-spec predicate-name + field-spec ...) + (let () + (define (syntax-error message subform) + (syntax-violation (syntax-case #'form () + ((macro . args) (syntax->datum #'macro))) + message #'form subform)) + (and (boolean? (syntax->datum #'immutable?)) + (or (identifier? #'type-name) + (syntax-error "expected type name" #'type-name)) + (syntax-case #'constructor-spec () + ((ctor args ...) + (every identifier? #'(ctor args ...)) + #t) + (_ (syntax-error "invalid constructor spec" + #'constructor-spec))) + (or (identifier? #'predicate-name) + (syntax-error "expected predicate name" #'predicate-name)) + (every (lambda (spec) + (syntax-case spec () + ((field getter) #t) + ((field getter setter) #t) + (_ (syntax-error "invalid field spec" spec)))) + #'(field-spec ...)))) + (let* ((field-ids (field-identifiers #'(field-spec ...))) + (getter-ids (getter-identifiers #'(field-spec ...))) + (field-count (length field-ids)) + (immutable? (syntax->datum #'immutable?)) + (layout (record-layout immutable? field-count)) + (ctor-name (syntax-case #'constructor-spec () + ((ctor args ...) #'ctor))) + (copier-id (make-copier-id #'type-name))) + #`(begin + #,(constructor #'form #'type-name #'constructor-spec field-ids) + + (define type-name + (let ((rtd (make-struct/no-tail + record-type-vtable + '#,(datum->syntax #'here (make-struct-layout layout)) + default-record-printer + 'type-name + '#,field-ids))) + (set-struct-vtable-name! rtd 'type-name) + (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name) + rtd)) + + (define-inlinable (predicate-name obj) + (and (struct? obj) + (eq? (struct-vtable obj) type-name))) + + #,@(getters #'type-name getter-ids copier-id) + #,(copier #'type-name getter-ids copier-id) + #,@(if immutable? + (functional-setters copier-id #'(field-spec ...)) + (setters #'type-name #'(field-spec ...)))))) + ((_ immutable? form . rest) + (syntax-violation + (syntax-case #'form () + ((macro . args) (syntax->datum #'macro))) + "invalid record definition syntax" + #'form))))) + +(define-syntax-rule (define-record-type name ctor pred fields ...) + (%define-record-type #f (define-record-type name ctor pred fields ...) + name ctor pred fields ...)) + +;;; srfi-9.scm ends here diff --git a/module/srfi/srfi-9/gnu.scm b/module/srfi/srfi-9/gnu.scm new file mode 100644 index 000000000..219bcdebb --- /dev/null +++ b/module/srfi/srfi-9/gnu.scm @@ -0,0 +1,168 @@ +;;; Extensions to SRFI-9 + +;; Copyright (C) 2010, 2012 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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: + +;; Extensions to SRFI-9. Fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-9 gnu) + #:use-module (srfi srfi-1) + #:use-module (system base ck) + #:export (set-record-type-printer! + define-immutable-record-type + set-field + set-fields)) + +(define (set-record-type-printer! type proc) + "Set PROC as the custom printer for TYPE." + (struct-set! type vtable-index-printer proc)) + +(define-syntax-rule (define-immutable-record-type name ctor pred fields ...) + ((@@ (srfi srfi-9) %define-record-type) + #t (define-immutable-record-type name ctor pred fields ...) + name ctor pred fields ...)) + +(define-syntax-rule (set-field s (getter ...) expr) + (%set-fields #t (set-field s (getter ...) expr) () + s ((getter ...) expr))) + +(define-syntax-rule (set-fields s . rest) + (%set-fields #t (set-fields s . rest) () + s . rest)) + +;; +;; collate-set-field-specs is a helper for %set-fields +;; thats combines all specs with the same head together. +;; +;; For example: +;; +;; SPECS: (((a b c) expr1) +;; ((a d) expr2) +;; ((b c) expr3) +;; ((c) expr4)) +;; +;; RESULT: ((a ((b c) expr1) +;; ((d) expr2)) +;; (b ((c) expr3)) +;; (c (() expr4))) +;; +(define (collate-set-field-specs specs) + (define (insert head tail expr result) + (cond ((find (lambda (tree) + (free-identifier=? head (car tree))) + result) + => (lambda (tree) + `((,head (,tail ,expr) + ,@(cdr tree)) + ,@(delq tree result)))) + (else `((,head (,tail ,expr)) + ,@result)))) + (with-syntax (((((head . tail) expr) ...) specs)) + (fold insert '() #'(head ...) #'(tail ...) #'(expr ...)))) + +(define-syntax unknown-getter + (lambda (x) + (syntax-case x () + ((_ orig-form getter) + (syntax-violation 'set-fields "unknown getter" #'orig-form #'getter))))) + +(define-syntax c-list + (lambda (x) + (syntax-case x (quote) + ((_ s 'v ...) + #'(ck s '(v ...)))))) + +(define-syntax c-same-type-check + (lambda (x) + (syntax-case x (quote) + ((_ s 'orig-form '(path ...) + '(getter0 getter ...) + '(type0 type ...) + 'on-success) + (every (lambda (t g) + (or (free-identifier=? t #'type0) + (syntax-violation + 'set-fields + (format #f + "\ +field paths ~a and ~a require one object to belong to two different record types (~a and ~a)" + (syntax->datum #`(path ... #,g)) + (syntax->datum #'(path ... getter0)) + (syntax->datum t) + (syntax->datum #'type0)) + #'orig-form))) + #'(type ...) + #'(getter ...)) + #'(ck s 'on-success))))) + +(define-syntax %set-fields + (lambda (x) + (with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type)) + (getter-index #'(@@ (srfi srfi-9) getter-index)) + (getter-copier #'(@@ (srfi srfi-9) getter-copier))) + (syntax-case x () + ((_ check? orig-form (path-so-far ...) + s) + #'s) + ((_ check? orig-form (path-so-far ...) + s (() e)) + #'e) + ((_ check? orig-form (path-so-far ...) + struct-expr ((head . tail) expr) ...) + (let ((collated-specs (collate-set-field-specs + #'(((head . tail) expr) ...)))) + (with-syntax (((getter0 getter ...) + (map car collated-specs))) + (with-syntax ((err #'(unknown-getter + orig-form getter0))) + #`(ck + () + (c-same-type-check + 'orig-form + '(path-so-far ...) + '(getter0 getter ...) + (c-list (getter-type 'getter0 'err) + (getter-type 'getter 'err) ...) + '(let ((s struct-expr)) + ((ck () (getter-copier 'getter0 'err)) + check? + s + #,@(map (lambda (spec) + (with-syntax (((head (tail expr) ...) spec)) + (with-syntax ((err #'(unknown-getter + orig-form head))) + #'(head (%set-fields + check? + orig-form + (path-so-far ... head) + (struct-ref s (ck () (getter-index + 'head 'err))) + (tail expr) ...))))) + collated-specs))))))))) + ((_ check? orig-form (path-so-far ...) + s (() e) (() e*) ...) + (syntax-violation 'set-fields "duplicate field path" + #'orig-form #'(path-so-far ...))) + ((_ check? orig-form (path-so-far ...) + s ((getter ...) expr) ...) + (syntax-violation 'set-fields "one field path is a prefix of another" + #'orig-form #'(path-so-far ...))) + ((_ check? orig-form . rest) + (syntax-violation 'set-fields "invalid syntax" #'orig-form)))))) diff --git a/module/srfi/srfi-98.scm b/module/srfi/srfi-98.scm new file mode 100644 index 000000000..944f40261 --- /dev/null +++ b/module/srfi/srfi-98.scm @@ -0,0 +1,44 @@ +;;; srfi-98.scm --- An interface to access environment variables + +;; Copyright (C) 2009 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 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; 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: 2009-05-26 + +;;; Commentary: + +;; This is an implementation of SRFI-98 (An interface to access environment +;; variables). +;; +;; This module is fully documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-98) + :use-module (srfi srfi-1) + :export (get-environment-variable + get-environment-variables)) + +(cond-expand-provide (current-module) '(srfi-98)) + +(define get-environment-variable getenv) +(define (get-environment-variables) + (define (string->alist-entry str) + (let ((pvt (string-index str #\=)) + (len (string-length str))) + (and pvt (cons (substring str 0 pvt) (substring str (+ pvt 1) len))))) + (filter-map string->alist-entry (environ))) |