diff --git a/configure.in b/configure.in index 166edccbcb..6bf9efc99a 100644 --- a/configure.in +++ b/configure.in @@ -343,11 +343,11 @@ fi AS_SCRUB_INCLUDE(GUILE_INCS) AC_SUBST(GUILE_LIBS) -AM_GUILE_VERSION_CHECK(1.6.0, , , [AC_MSG_ERROR([ +AM_GUILE_VERSION_CHECK(1.6.7, , , [AC_MSG_ERROR([ guile does not appear to be installed correctly, or is not in the correct version range. Perhaps you have not installed the guile - development packages? Gnucash requires at least version 1.6 to build. + development packages? Gnucash requires at least version 1.6.7 to build. ])]) AC_SUBST(GUILE) @@ -430,37 +430,6 @@ AC_TRY_RUN([ CFLAGS="$GNC_OLDCFLAGS" LDFLAGS="$GNC_OLDLDFLAGS" - -### -------------------------------------------------------------------------- -### Check which SRFIs we need. - -GNC_ADD_ON_SRFIS="" - -for f in ${srcdir}/lib/srfi/srfi-*.scm -do - srfi=`echo $f | sed 's%.*/%%' | sed 's/.scm//'` - AC_MSG_CHECKING(if guile needs our copy of ${srfi}) - if ${GUILE} -c "(debug-set! stack 200000) (use-modules (srfi ${srfi}))" > /dev/null 2>&1 - then - AC_MSG_RESULT(no) - else - GNC_ADD_ON_SRFIS="${GNC_ADD_ON_SRFIS} ${srfi}.scm" - AC_MSG_RESULT(yes) - fi -done - -AC_SUBST(GNC_ADD_ON_SRFIS) -if test "x${GNC_ADD_ON_SRFIS}" != "x" -then - GNC_SRFI_LOAD_PATH="\${top_srcdir}/lib/" - GNC_TEST_SRFI_LOAD_CMD="--guile-load-dir \${top_srcdir}/lib/" -else - GNC_SRFI_LOAD_PATH="" - GNC_TEST_SRFI_LOAD_CMD="" -fi -AC_SUBST(GNC_SRFI_LOAD_PATH) -AC_SUBST(GNC_TEST_SRFI_LOAD_CMD) - ### -------------------------------------------------------------------------- ### See if we need guile-www @@ -1372,7 +1341,6 @@ AC_CONFIG_FILES(po/Makefile.in intl-scm/Makefile lib/Makefile lib/guile-www/Makefile - lib/srfi/Makefile lib/libc/Makefile lib/stf/Makefile packaging/Makefile diff --git a/lib/Makefile.am b/lib/Makefile.am index 789dc0a9e8..118534962f 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -1,5 +1,5 @@ -SUBDIRS = libc guile-www srfi stf -DIST_SUBDIRS = libc guile-www srfi stf +SUBDIRS = libc guile-www stf +DIST_SUBDIRS = libc guile-www stf EXTRA_DIST = README diff --git a/lib/srfi/Makefile.am b/lib/srfi/Makefile.am deleted file mode 100644 index 6f3d8cbcc3..0000000000 --- a/lib/srfi/Makefile.am +++ /dev/null @@ -1,13 +0,0 @@ - -gncscmdir = ${GNC_SHAREDIR}/guile-modules/srfi - -gncscm_DATA = @GNC_ADD_ON_SRFIS@ - -EXTRA_DIST = \ - README \ - srfi-1.scm \ - srfi-2.scm \ - srfi-8.scm \ - srfi-9.scm \ - srfi-11.scm \ - srfi-19.scm diff --git a/lib/srfi/README b/lib/srfi/README deleted file mode 100644 index 837c29a9f4..0000000000 --- a/lib/srfi/README +++ /dev/null @@ -1,13 +0,0 @@ - -These files implement various useful SRFIs for Guile. See -http://srfi.schemers.org/. The bits taken from the Guile source tree -will go away whenever gnucash updates to require a more recent version -of Guile. - -Sources of files: - - srfi-1.scm: Guile translation of reference implementation by Olin Shivers. - srfi-2.scm: Guile source tree (modified for versioning). - srfi-8.scm: Guile source tree (modified for versioning). - srfi-9.scm: Guile source tree (modified for versioning). - srfi-19.scm: Guile source tree (modified for versioning). diff --git a/lib/srfi/srfi-1.scm b/lib/srfi/srfi-1.scm deleted file mode 100644 index 5827e9a102..0000000000 --- a/lib/srfi/srfi-1.scm +++ /dev/null @@ -1,1660 +0,0 @@ -;;; SRFI-1 list-processing library -*- Scheme -*- -;;; Reference implementation -;;; -;;; 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. Please send bug reports to shivers@ai.mit.edu. -;;; -Olin - -;;; Modifications to make the code more portable are -;;; Copyright 1999, Rob Browning . 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. - -;;; This is a library of list- and pair-processing functions. I wrote it after -;;; carefully considering the functions provided by the libraries found in -;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common -;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty -;;; rich toolkit, providing a superset of the functionality found in any of -;;; the various Schemes I considered. - -;;; This implementation is intended as a portable reference implementation -;;; for SRFI-1. See the porting notes below for more information. - -;;; Exported: -;;; xcons tree-copy make-list list-tabulate cons* list-copy -;;; proper-list? circular-list? dotted-list? not-pair? null-list? list= -;;; circular-list length+ -;;; iota -;;; 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 -;;; zip unzip1 unzip2 unzip3 unzip4 unzip5 -;;; count -;;; append! append-reverse append-reverse! concatenate concatenate! -;;; unfold fold pair-fold reduce -;;; unfold-right fold-right pair-fold-right reduce-right -;;; append-map append-map! map! pair-for-each filter-map map-in-order -;;; filter partition remove -;;; filter! partition! remove! -;;; find find-tail any every list-index-pred -;;; take-while drop-while take-while! -;;; span break span! break! -;;; delete delete! -;;; alist-cons alist-copy -;;; delete-duplicates delete-duplicates! -;;; alist-delete alist-delete! -;;; reverse! -;;; 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! -;;; -;;; In principle, the following R4RS list- and pair-processing procedures -;;; are also part of this package's exports, although they are not defined -;;; in this file: -;;; Primitives: cons pair? null? car cdr set-car! set-cdr! -;;; Non-primitives: list length append reverse cadr ... cddddr list-ref -;;; memq memv assq assv -;;; (The non-primitives are defined in this file, but commented out.) -;;; -;;; These R4RS procedures have extended definitions in SRFI-1 and are defined -;;; in this file: -;;; map for-each member assoc -;;; -;;; The remaining two R4RS list-processing procedures are not included: -;;; list-tail (use drop) -;;; list? (use proper-list?) - - -;;; A note on recursion and iteration/reversal: -;;; Many iterative list-processing algorithms naturally compute the elements -;;; of the answer list in the wrong order (left-to-right or head-to-tail) from -;;; the order needed to cons them into the proper answer (right-to-left, or -;;; tail-then-head). One style or idiom of programming these algorithms, then, -;;; loops, consing up the elements in reverse order, then destructively -;;; reverses the list at the end of the loop. I do not do this. The natural -;;; and efficient way to code these algorithms is recursively. This trades off -;;; intermediate temporary list structure for intermediate temporary stack -;;; structure. In a stack-based system, this improves cache locality and -;;; lightens the load on the GC system. Don't stand on your head to iterate! -;;; Recurse, where natural. Multiple-value returns make this even more -;;; convenient, when the recursion/iteration has multiple state values. - -;;; Porting: -;;; This is carefully tuned code; do not modify casually. -;;; - It is careful to share storage when possible; -;;; - Side-effecting code tries not to perform redundant writes. -;;; -;;; That said, a port of this library to a specific Scheme system might wish -;;; to tune this code to exploit particulars of the implementation. -;;; The single most important compiler-specific optimisation you could make -;;; to this library would be to add rewrite rules or transforms to: -;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND, -;;; LSET-UNION) into multiple applications of a primitive two-argument -;;; variant. -;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD, -;;; ANY, EVERY) into open-coded loops. The killer here is that these -;;; functions are n-ary. Handling the general case is quite inefficient, -;;; requiring many intermediate data structures to be allocated and -;;; discarded. -;;; - transform applications of procedures that take optional arguments -;;; into calls to variants that do not take optional arguments. This -;;; eliminates unnecessary consing and parsing of the rest parameter. -;;; -;;; These transforms would provide BIG speedups. In particular, the n-ary -;;; mapping functions are particularly slow and cons-intensive, and are good -;;; candidates for tuning. I have coded fast paths for the single-list cases, -;;; but what you really want to do is exploit the fact that the compiler -;;; usually knows how many arguments are being passed to a particular -;;; application of these functions -- they are usually explicitly called, not -;;; passed around as higher-order values. If you can arrange to have your -;;; compiler produce custom code or custom linkages based on the number of -;;; arguments in the call, you can speed these functions up a *lot*. But this -;;; kind of compiler technology no longer exists in the Scheme world as far as -;;; I can see. -;;; -;;; Note that this code is, of course, dependent upon standard bindings for -;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound -;;; to the procedure that takes the car of a list. If your Scheme -;;; implementation allows user code to alter the bindings of these procedures -;;; in a manner that would be visible to these definitions, then there might -;;; be trouble. You could consider horrible kludgery along the lines of -;;; (define fact -;;; (let ((= =) (- -) (* *)) -;;; (letrec ((real-fact (lambda (n) -;;; (if (= n 0) 1 (* n (real-fact (- n 1))))))) -;;; real-fact))) -;;; Or you could consider shifting to a reasonable Scheme system that, say, -;;; has a module system protecting code from this kind of lossage. -;;; -;;; This code does a fair amount of run-time argument checking. If your -;;; Scheme system has a sophisticated compiler that can eliminate redundant -;;; error checks, this is no problem. However, if not, these checks incur -;;; some performance overhead -- and, in a safe Scheme implementation, they -;;; are in some sense redundant: if we don't check to see that the PROC -;;; parameter is a procedure, we'll find out anyway three lines later when -;;; we try to call the value. It's pretty easy to rip all this argument -;;; checking code out if it's inappropriate for your implementation -- just -;;; nuke every call to CHECK-ARG. -;;; -;;; On the other hand, if you *do* have a sophisticated compiler that will -;;; actually perform soft-typing and eliminate redundant checks (Rice's systems -;;; being the only possible candidate of which I'm aware), leaving these checks -;;; in can *help*, since their presence can be elided in redundant cases, -;;; and in cases where they are needed, performing the checks early, at -;;; procedure entry, can "lift" a check out of a loop. -;;; -;;; Finally, I have only checked the properties that can portably be checked -;;; with R5RS Scheme -- and this is not complete. You may wish to alter -;;; the CHECK-ARG parameter checks to perform extra, implementation-specific -;;; checks, such as procedure arity for higher-order values. -;;; -;;; The code has only these non-R4RS dependencies: -;;; A few calls to an ERROR procedure; -;;; Uses of the R5RS multiple-value procedure VALUES and the m-v binding -;;; RECEIVE macro (which isn't R5RS, but is a trivial macro). -;;; Many calls to a parameter-checking procedure check-arg: -;;; (define (check-arg pred val caller) -;;; (let lp ((val val)) -;;; (if (pred val) val (lp (error "Bad argument" val pred caller))))) -;;; -;;; Most of these procedures use the NULL-LIST? test to trigger the -;;; base case in the inner loop or recursion. The NULL-LIST? function -;;; is defined to be a careful one -- it raises an error if passed a -;;; non-nil, non-pair value. The spec allows an implementation to use -;;; a less-careful implementation that simply defines NULL-LIST? to -;;; be NOT-PAIR?. This would speed up the inner loops of these procedures -;;; at the expense of having them silently accept dotted lists. - -;;; A note on dotted lists: -;;; I, personally, take the view that the only consistent view of lists -;;; in Scheme is the view that *everything* is a list -- values such as -;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the -;;; fact that Scheme actually has no true list type. It has a pair type, -;;; and there is an *interpretation* of the trees built using this type -;;; as lists. -;;; -;;; I lobbied to have these list-processing procedures hew to this -;;; view, and accept any value as a list argument. I was overwhelmingly -;;; overruled during the SRFI discussion phase. So I am inserting this -;;; text in the reference lib and the SRFI spec as a sort of "minority -;;; opinion" dissent. -;;; -;;; Many of the procedures in this library can be trivially redefined -;;; to handle dotted lists, just by changing the NULL-LIST? base-case -;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be -;;; an empty list. For most of these procedures, that's all that is -;;; required. -;;; -;;; However, we have to do a little more work for some procedures that -;;; *produce* lists from other lists. Were we to extend these procedures to -;;; accept dotted lists, we would have to define how they terminate the lists -;;; produced as results when passed a dotted list. I designed a coherent set -;;; of termination rules for these cases; this was posted to the SRFI-1 -;;; discussion list. I additionally wrote an earlier version of this library -;;; that implemented that spec. It has been discarded during later phases of -;;; the definition and implementation of this library. -;;; -;;; The argument *against* defining these procedures to work on dotted -;;; lists is that dotted lists are the rare, odd case, and that by -;;; arranging for the procedures to handle them, we lose error checking -;;; in the cases where a dotted list is passed by accident -- e.g., when -;;; the programmer swaps a two arguments to a list-processing function, -;;; one being a scalar and one being a list. For example, -;;; (member '(1 3 5 7 9) 7) -;;; This would quietly return #f if we extended MEMBER to accept dotted -;;; lists. -;;; -;;; The SRFI discussion record contains more discussion on this topic. - -(define-module (srfi srfi-1)) - -(export - xcons tree-copy make-list list-tabulate cons* list-copy - proper-list? circular-list? dotted-list? not-pair? null-list? list= - circular-list length+ - iota - 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 - zip unzip1 unzip2 unzip3 unzip4 unzip5 - count - append! append-reverse append-reverse! concatenate concatenate! - unfold fold pair-fold reduce - unfold-right fold-right pair-fold-right reduce-right - append-map append-map! map! pair-for-each filter-map map-in-order - filter partition remove - filter! partition! remove! - find find-tail any every list-index-pred - take-while drop-while take-while! - span break span! break! - delete delete! - alist-cons alist-copy - delete-duplicates delete-duplicates! - alist-delete alist-delete! - reverse! - 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! - map for-each member assoc) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Modifications from the "official" implementation. -;;; -;;; Removed all non r5rs-isms that I detected (i.e :optional and let-optionals). -;;; -;;; Renamed error to srfi-1:error -;;; Renamed check-arg to srfi-1:check-arg -;;; - -;; This has been modified for GnuCash to use guile's built in error -;; function. - -(define (srfi-1:error msg . args) - (apply error msg args)) - -(define (srfi-1:check-arg pred val caller) - (if (pred val) - val - (srfi-1:error "Bad argument" val "to function" caller))) - -;;; Constructors -;;;;;;;;;;;;;;;; - -;;; Occasionally useful as a value to be passed to a fold or other -;;; higher-order procedure. -(define (xcons d a) (cons a d)) - -;;;; Recursively copy every cons. -;(define (tree-copy x) -; (let recur ((x x)) -; (if (not (pair? x)) x -; (cons (recur (car x)) (recur (cdr x)))))) - -;;; Make a list of length LEN. - -(define (make-list len . maybe-elt) - (srfi-1:check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list) - (let ((elt (cond ((null? maybe-elt) #f) ; Default value - ((null? (cdr maybe-elt)) (car maybe-elt)) - (else (srfi-1:error "Too many arguments to MAKE-LIST" - (cons len maybe-elt)))))) - (do ((i len (- i 1)) - (ans '() (cons elt ans))) - ((<= i 0) ans)))) - - -;(define (list . ans) ans) ; R4RS - - -;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN. - -(define (list-tabulate len proc) - (srfi-1:check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate) - (srfi-1:check-arg procedure? proc list-tabulate) - (do ((i (- len 1) (- i 1)) - (ans '() (cons (proc i) ans))) - ((< i 0) ans))) - -;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an))) -;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...)) -;;; -;;; (cons first (unfold not-pair? car cdr rest values)) - -(define (cons* first . rest) - (let recur ((x first) (rest rest)) - (if (pair? rest) - (cons x (recur (car rest) (cdr rest))) - x))) - -;;; (unfold not-pair? car cdr lis values) - -(define (list-copy lis) - (let recur ((lis lis)) - (if (pair? lis) - (cons (car lis) (recur (cdr lis))) - lis))) - -;;; IOTA count [start step] (start start+step ... start+(count-1)*step) - -(define (iota count . maybe-start+step) - - (define (helper start step) - (srfi-1:check-arg number? start iota) - (srfi-1:check-arg number? step iota) - (let ((last-val (+ start (* (- count 1) step)))) - (do ((count count (- count 1)) - (val last-val (- val step)) - (ans '() (cons val ans))) - ((<= count 0) ans)))) - - (srfi-1:check-arg integer? count iota) - (if (< count 0) (srfi-1:error "Negative step count" iota count)) - - (if (pair? maybe-start+step) - (helper (car maybe-start+step) (cadr maybe-start+step)) - (helper 0 1))) - -;;; I thought these were lovely, but the public at large did not share my -;;; enthusiasm... -;;; :IOTA to (0 ... to-1) -;;; :IOTA from to (from ... to-1) -;;; :IOTA from to step (from from+step ...) - -;;; IOTA: to (1 ... to) -;;; IOTA: from to (from+1 ... to) -;;; IOTA: from to step (from+step from+2step ...) - -;(define (%parse-iota-args arg1 rest-args proc) -; (let ((check (lambda (n) (srfi-1:check-arg integer? n proc)))) -; (check arg1) -; (if (pair? rest-args) -; (let ((arg2 (check (car rest-args))) -; (rest (cdr rest-args))) -; (if (pair? rest) -; (let ((arg3 (check (car rest))) -; (rest (cdr rest))) -; (if (pair? rest) (srfi-1:error "Too many parameters" proc arg1 rest-args) -; (values arg1 arg2 arg3))) -; (values arg1 arg2 1))) -; (values 0 arg1 1)))) -; -;(define (iota: arg1 . rest-args) -; (receive (from to step) (%parse-iota-args arg1 rest-args iota:) -; (let* ((numsteps (floor (/ (- to from) step))) -; (last-val (+ from (* step numsteps)))) -; (if (< numsteps 0) (srfi-1:error "Negative step count" iota: from to step)) -; (do ((steps-left numsteps (- steps-left 1)) -; (val last-val (- val step)) -; (ans '() (cons val ans))) -; ((<= steps-left 0) ans))))) -; -; -;(define (:iota arg1 . rest-args) -; (receive (from to step) (%parse-iota-args arg1 rest-args :iota) -; (let* ((numsteps (ceiling (/ (- to from) step))) -; (last-val (+ from (* step (- numsteps 1))))) -; (if (< numsteps 0) (srfi-1:error "Negative step count" :iota from to step)) -; (do ((steps-left numsteps (- steps-left 1)) -; (val last-val (- val step)) -; (ans '() (cons val ans))) -; ((<= steps-left 0) ans))))) - - - -(define (circular-list val1 . vals) - (let ((ans (cons val1 vals))) - (set-cdr! (last-pair ans) ans) - ans)) - -;;; ::= () ; Empty proper list -;;; | (cons ) ; Proper-list pair -;;; Note that this definition rules out circular lists -- and this -;;; function is required to detect this case and return false. - -(define (proper-list? x) - (let lp ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (lp x lag))) - (null? x))) - (null? x)))) - - -;;; A dotted list is a finite list (possibly of length 0) terminated -;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5) -;;; is a dotted list of length 0. -;;; -;;; ::= ; Empty dotted list -;;; | (cons ) ; Proper-list pair - -(define (dotted-list? x) - (let lp ((x x) (lag x)) - (if (pair? x) - (let ((x (cdr x))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (and (not (eq? x lag)) (lp x lag))) - (not (null? x)))) - (not (null? x))))) - -(define (circular-list? x) - (let lp ((x x) (lag x)) - (and (pair? x) - (let ((x (cdr x))) - (and (pair? x) - (let ((x (cdr x)) - (lag (cdr lag))) - (or (eq? x lag) (lp x lag)))))))) - -(define (not-pair? x) (not (pair? x))) ; Inline me. - -;;; This is a legal definition which is fast and sloppy: -;;; (define null-list? not-pair?) -;;; but we'll provide a more careful one: -(define (null-list? l) - (cond ((pair? l) #f) - ((null? l) #t) - (else (srfi-1:error "null-pair?: argument out of domain" l)))) - - -(define (list= = . lists) - (or (null? lists) ; special case - - (let lp1 ((list-a (car lists)) (others (cdr lists))) - (or (null? others) - (let ((list-b (car others)) - (others (cdr others))) - (if (eq? list-a list-b) ; EQ? => LIST= - (lp1 list-b others) - (let lp2 ((list-a list-a) (list-b list-b)) - (if (null-list? list-a) - (and (null-list? list-b) - (lp1 list-b others)) - (and (not (null-list? list-b)) - (= (car list-a) (car list-b)) - (lp2 (cdr list-a) (cdr list-b))))))))))) - - - -;;; R4RS, so commented out. -;(define (length x) ; LENGTH may diverge or -; (let lp ((x x) (len 0)) ; raise an error if X is -; (if (pair? x) ; a circular list. This version -; (lp (cdr x) (+ len 1)) ; diverges. -; len))) - -(define (length+ x) ; Returns #f if X is circular. - (let lp ((x x) (lag x) (len 0)) - (if (pair? x) - (let ((x (cdr x)) - (len (+ len 1))) - (if (pair? x) - (let ((x (cdr x)) - (lag (cdr lag)) - (len (+ len 1))) - (and (not (eq? x lag)) (lp x lag len))) - len)) - len))) - -(define (zip list1 . more-lists) (apply map list list1 more-lists)) - - -;;; Selectors -;;;;;;;;;;;;; - -;;; R4RS non-primitives: -;(define (caar x) (car (car x))) -;(define (cadr x) (car (cdr x))) -;(define (cdar x) (cdr (car x))) -;(define (cddr x) (cdr (cdr x))) -; -;(define (caaar x) (caar (car x))) -;(define (caadr x) (caar (cdr x))) -;(define (cadar x) (cadr (car x))) -;(define (caddr x) (cadr (cdr x))) -;(define (cdaar x) (cdar (car x))) -;(define (cdadr x) (cdar (cdr x))) -;(define (cddar x) (cddr (car x))) -;(define (cdddr x) (cddr (cdr x))) -; -;(define (caaaar x) (caaar (car x))) -;(define (caaadr x) (caaar (cdr x))) -;(define (caadar x) (caadr (car x))) -;(define (caaddr x) (caadr (cdr x))) -;(define (cadaar x) (cadar (car x))) -;(define (cadadr x) (cadar (cdr x))) -;(define (caddar x) (caddr (car x))) -;(define (cadddr x) (caddr (cdr x))) -;(define (cdaaar x) (cdaar (car x))) -;(define (cdaadr x) (cdaar (cdr x))) -;(define (cdadar x) (cdadr (car x))) -;(define (cdaddr x) (cdadr (cdr x))) -;(define (cddaar x) (cddar (car x))) -;(define (cddadr x) (cddar (cdr x))) -;(define (cdddar x) (cdddr (car x))) -;(define (cddddr x) (cdddr (cdr x))) - - -(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 pair) (values (car pair) (cdr pair))) - -;;; take & drop - -(define (take lis k) - (srfi-1:check-arg integer? k take) - (let recur ((lis lis) (k k)) - (if (zero? k) '() - (cons (car lis) - (recur (cdr lis) (- k 1)))))) - -(define (drop lis k) - (srfi-1:check-arg integer? k drop) - (let iter ((lis lis) (k k)) - (if (zero? k) lis (iter (cdr lis) (- k 1))))) - -(define (take! lis k) - (srfi-1:check-arg integer? k take!) - (if (zero? k) '() - (begin (set-cdr! (drop lis (- k 1)) '()) - lis))) - -;;; 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. - -(define (take-right lis k) - (srfi-1:check-arg integer? k take-right) - (let lp ((lag lis) (lead (drop lis k))) - (if (pair? lead) - (lp (cdr lag) (cdr lead)) - lag))) - -(define (drop-right lis k) - (srfi-1:check-arg integer? k drop-right) - (let recur ((lag lis) (lead (drop lis k))) - (if (pair? lead) - (cons (car lag) (recur (cdr lag) (cdr lead))) - '()))) - -;;; In this function, LEAD is actually K+1 ahead of LAG. This lets -;;; us stop LAG one step early, in time to smash its cdr to (). -(define (drop-right! lis k) - (srfi-1:check-arg integer? k drop-right!) - (let ((lead (drop lis k))) - (if (pair? lead) - - (let lp ((lag lis) (lead (cdr lead))) ; Standard case - (if (pair? lead) - (lp (cdr lag) (cdr lead)) - (begin (set-cdr! lag '()) - lis))) - - '()))) ; Special case dropping everything -- no cons to side-effect. - -;(define (list-ref lis i) (car (drop lis i))) ; R4RS - -;;; These use the APL convention, whereby negative indices mean -;;; "from the right." I liked them, but they didn't win over the -;;; SRFI reviewers. -;;; K >= 0: Take and drop K elts from the front of the list. -;;; K <= 0: Take and drop -K elts from the end of the list. - -;(define (take lis k) -; (srfi-1:check-arg integer? k take) -; (if (negative? k) -; (list-tail lis (+ k (length lis))) -; (let recur ((lis lis) (k k)) -; (if (zero? k) '() -; (cons (car lis) -; (recur (cdr lis) (- k 1))))))) -; -;(define (drop lis k) -; (srfi-1:check-arg integer? k drop) -; (if (negative? k) -; (let recur ((lis lis) (nelts (+ k (length lis)))) -; (if (zero? nelts) '() -; (cons (car lis) -; (recur (cdr lis) (- nelts 1))))) -; (list-tail lis k))) -; -; -;(define (take! lis k) -; (srfi-1:check-arg integer? k take!) -; (cond ((zero? k) '()) -; ((positive? k) -; (set-cdr! (list-tail lis (- k 1)) '()) -; lis) -; (else (list-tail lis (+ k (length lis)))))) -; -;(define (drop! lis k) -; (srfi-1:check-arg integer? k drop!) -; (if (negative? k) -; (let ((nelts (+ k (length lis)))) -; (if (zero? nelts) '() -; (begin (set-cdr! (list-tail lis (- nelts 1)) '()) -; lis))) -; (list-tail lis k))) - -(define (split-at x k) - (srfi-1:check-arg integer? k split-at) - (let recur ((lis x) (k k)) - (if (zero? k) (values '() lis) - (receive (prefix suffix) (recur (cdr lis) (- k 1)) - (values (cons (car lis) prefix) suffix))))) - -(define (split-at! x k) - (srfi-1:check-arg integer? k split-at!) - (if (zero? k) (values '() x) - (let* ((prev (drop x (- k 1))) - (suffix (cdr prev))) - (set-cdr! prev '()) - (values x suffix)))) - - -(define (last lis) (car (last-pair lis))) - -(define (last-pair lis) - (srfi-1:check-arg pair? lis last-pair) - (let lp ((lis lis)) - (let ((tail (cdr lis))) - (if (pair? tail) (lp tail) lis)))) - - -;;; Unzippers -- 1 through 5 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (unzip1 lis) (map car lis)) - -(define (unzip2 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle - (let ((elt (car lis))) ; dotted lists. - (receive (a b) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b))))))) - -(define (unzip3 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis) - (let ((elt (car lis))) - (receive (a b c) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c))))))) - -(define (unzip4 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d))))))) - -(define (unzip5 lis) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis lis lis lis) - (let ((elt (car lis))) - (receive (a b c d e) (recur (cdr lis)) - (values (cons (car elt) a) - (cons (cadr elt) b) - (cons (caddr elt) c) - (cons (cadddr elt) d) - (cons (car (cddddr elt)) e))))))) - - -;;; append! append-reverse append-reverse! concatenate concatenate! -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (append! . lists) - ;; First, scan through lists looking for a non-empty one. - (let lp ((lists lists) (prev '())) - (if (not (pair? lists)) prev - (let ((first (car lists)) - (rest (cdr lists))) - (if (not (pair? first)) (lp rest first) - - ;; Now, do the splicing. - (let lp2 ((tail-cons (last-pair first)) - (rest rest)) - (if (pair? rest) - (let ((next (car rest)) - (rest (cdr rest))) - (set-cdr! tail-cons next) - (lp2 (if (pair? next) (last-pair next) tail-cons) - rest)) - first))))))) - -;;; APPEND is R4RS. -;(define (append . lists) -; (if (pair? lists) -; (let recur ((list1 (car lists)) (lists (cdr lists))) -; (if (pair? lists) -; (let ((tail (recur (car lists) (cdr lists)))) -; (fold-right cons tail list1)) ; Append LIST1 & TAIL. -; list1)) -; '())) - -;(define (append-reverse rev-head tail) (fold cons tail rev-head)) - -;(define (append-reverse! rev-head tail) -; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) -; tail -; rev-head)) - -;;; Hand-inline the FOLD and PAIR-FOLD ops for speed. - -(define (append-reverse rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (lp (cdr rev-head) (cons (car rev-head) tail))))) - -(define (append-reverse! rev-head tail) - (let lp ((rev-head rev-head) (tail tail)) - (if (null-list? rev-head) tail - (let ((next-rev (cdr rev-head))) - (set-cdr! rev-head tail) - (lp next-rev rev-head))))) - - -(define (concatenate lists) (reduce-right append '() lists)) -(define (concatenate! lists) (reduce-right append! '() lists)) - -;;; Fold/map internal utilities -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; These little internal utilities are used by the general -;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined. -;;; One the other hand, the n-ary cases are painfully inefficient as it is. -;;; An aggressive implementation should simply re-write these functions -;;; for raw efficiency; I have written them for as much clarity, portability, -;;; and simplicity as can be achieved. -;;; -;;; I use the dreaded call/cc to do local aborts. A good compiler could -;;; handle this with extreme efficiency. An implementation that provides -;;; a one-shot, non-persistent continuation grabber could help the compiler -;;; out by using that in place of the call/cc's in these routines. -;;; -;;; These functions have funky definitions that are precisely tuned to -;;; the needs of the fold/map procs -- for example, to minimize the number -;;; of times the argument lists need to be examined. - -;;; Return (map cdr lists). -;;; However, if any element of LISTS is empty, just abort and return '(). -(define (%cdrs lists) - (call-with-current-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (let ((lis (car lists))) - (if (null-list? lis) (abort '()) - (cons (cdr lis) (recur (cdr lists))))) - '()))))) - -(define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt)) - (let recur ((lists lists)) - (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt)))) - -;;; LISTS is a (not very long) non-empty list of lists. -;;; Return two lists: the cars & the cdrs of the lists. -;;; However, if any of the lists is empty, just abort and return [() ()]. - -(define (%cars+cdrs lists) - (call-with-current-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values '() '())))))) - -;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the -;;; cars list. What a hack. -(define (%cars+cdrs+ lists cars-final) - (call-with-current-continuation - (lambda (abort) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs)))))) - (values (list cars-final) '())))))) - -;;; Like %CARS+CDRS, but blow up if any list is empty. -(define (%cars+cdrs/no-test lists) - (let recur ((lists lists)) - (if (pair? lists) - (receive (list other-lists) (car+cdr lists) - (receive (a d) (car+cdr list) - (receive (cars cdrs) (recur other-lists) - (values (cons a cars) (cons d cdrs))))) - (values '() '())))) - - -;;; count -;;;;;;;;; -(define (count pred list1 . lists) - (srfi-1:check-arg procedure? pred count) - (if (pair? lists) - - ;; N-ary case - (let lp ((list1 list1) (lists lists) (i 0)) - (if (null-list? list1) i - (receive (as ds) (%cars+cdrs lists) - (if (null? as) i - (lp (cdr list1) ds - (if (apply pred (car list1) as) (+ i 1) i)))))) - - ;; Fast path - (let lp ((lis list1) (i 0)) - (if (null-list? lis) i - (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))) - - -;;; fold/unfold -;;;;;;;;;;;;;;; - -(define (unfold-right p f g seed . maybe-tail) - (srfi-1:check-arg procedure? p unfold-right) - (srfi-1:check-arg procedure? f unfold-right) - (srfi-1:check-arg procedure? g unfold-right) - (let lp ((seed seed) - (ans (if (pair? maybe-tail) (car maybe-tail) '()))) - (if (p seed) ans - (lp (g seed) - (cons (f seed) ans))))) - - -(define (unfold p f g seed . maybe-tail-gen) - (srfi-1:check-arg procedure? p unfold) - (srfi-1:check-arg procedure? f unfold) - (srfi-1:check-arg procedure? g unfold) - (if (pair? maybe-tail-gen) - - (let ((tail-gen (car maybe-tail-gen))) - (if (pair? (cdr maybe-tail-gen)) - (apply error "Too many arguments" unfold p f g seed maybe-tail-gen) - - (let recur ((seed seed)) - (if (p seed) (tail-gen seed) - (cons (f seed) (recur (g seed))))))) - - (let recur ((seed seed)) - (if (p seed) '() - (cons (f seed) (recur (g seed))))))) - - -(define (fold kons knil lis1 . lists) - (srfi-1:check-arg procedure? kons fold) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case - (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) - (if (null? cars+ans) ans ; Done. - (lp cdrs (apply kons cars+ans))))) - - (let lp ((lis lis1) (ans knil)) ; Fast path - (if (null-list? lis) ans - (lp (cdr lis) (kons (car lis) ans)))))) - - -(define (fold-right kons knil lis1 . lists) - (srfi-1:check-arg procedure? kons fold-right) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) ; N-ary case - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) knil - (apply kons (%cars+ lists (recur cdrs)))))) - - (let recur ((lis lis1)) ; Fast path - (if (null-list? lis) knil - (let ((head (car lis))) - (kons head (recur (cdr lis)))))))) - - -(define (pair-fold-right f zero lis1 . lists) - (srfi-1:check-arg procedure? f pair-fold-right) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) ; N-ary case - (let ((cdrs (%cdrs lists))) - (if (null? cdrs) zero - (apply f (append! lists (list (recur cdrs))))))) - - (let recur ((lis lis1)) ; Fast path - (if (null-list? lis) zero (f lis (recur (cdr lis))))))) - -(define (pair-fold f zero lis1 . lists) - (srfi-1:check-arg procedure? f pair-fold) - (if (pair? lists) - (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case - (let ((tails (%cdrs lists))) - (if (null? tails) ans - (lp tails (apply f (append! lists (list ans))))))) - - (let lp ((lis lis1) (ans zero)) - (if (null-list? lis) ans - (let ((tail (cdr lis))) ; Grab the cdr now, - (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS. - - -;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case. -;;; These cannot meaningfully be n-ary. - -(define (reduce f ridentity lis) - (srfi-1:check-arg procedure? f reduce) - (if (null-list? lis) ridentity - (fold f (car lis) (cdr lis)))) - -(define (reduce-right f ridentity lis) - (srfi-1:check-arg procedure? f reduce-right) - (if (null-list? lis) ridentity - (let recur ((head (car lis)) (lis (cdr lis))) - (if (pair? lis) - (f head (recur (car lis) (cdr lis))) - head)))) - - - -;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (append-map f lis1 . lists) - (really-append-map append-map append f lis1 lists)) -(define (append-map! f lis1 . lists) - (really-append-map append-map! append! f lis1 lists)) - -(define (really-append-map who appender f lis1 lists) - (srfi-1:check-arg procedure? f who) - (if (pair? lists) - (receive (cars cdrs) (%cars+cdrs (cons lis1 lists)) - (if (null? cars) '() - (let recur ((cars cars) (cdrs cdrs)) - (let ((vals (apply f cars))) - (receive (cars2 cdrs2) (%cars+cdrs cdrs) - (if (null? cars2) vals - (appender vals (recur cars2 cdrs2)))))))) - - ;; Fast path - (if (null-list? lis1) '() - (let recur ((elt (car lis1)) (rest (cdr lis1))) - (let ((vals (f elt))) - (if (null-list? rest) vals - (appender vals (recur (car rest) (cdr rest))))))))) - - -(define (pair-for-each proc lis1 . lists) - (srfi-1:check-arg procedure? proc pair-for-each) - (if (pair? lists) - - (let lp ((lists (cons lis1 lists))) - (let ((tails (%cdrs lists))) - (if (pair? tails) - (begin (apply proc lists) - (lp tails))))) - - ;; Fast path. - (let lp ((lis lis1)) - (if (not (null-list? lis)) - (let ((tail (cdr lis))) ; Grab the cdr now, - (proc lis) ; in case PROC SET-CDR!s LIS. - (lp tail)))))) - -;;; We stop when LIS1 runs out, not when any list runs out. -(define (map! f lis1 . lists) - (srfi-1:check-arg procedure? f map!) - (if (pair? lists) - (let lp ((lis1 lis1) (lists lists)) - (if (not (null-list? lis1)) - (receive (heads tails) (%cars+cdrs/no-test lists) - (set-car! lis1 (apply f (car lis1) heads)) - (lp (cdr lis1) tails)))) - - ;; Fast path. - (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1)) - lis1) - - -;;; Map F across L, and save up all the non-false results. -(define (filter-map f lis1 . lists) - (srfi-1:check-arg procedure? f filter-map) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs)))) - (else (recur cdrs))) ; Tail call in this arm. - '()))) - - ;; Fast path. - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (recur (cdr lis)))) - (cond ((f (car lis)) => (lambda (x) (cons x tail))) - (else tail))))))) - - -;;; Map F across lists, guaranteeing to go left-to-right. -;;; NOTE: Some implementations of R5RS MAP are compliant with this spec; -;;; in which case this procedure may simply be defined as a synonym for MAP. - -(define (map-in-order f lis1 . lists) - (srfi-1:check-arg procedure? f map-in-order) - (if (pair? lists) - (let recur ((lists (cons lis1 lists))) - (receive (cars cdrs) (%cars+cdrs lists) - (if (pair? cars) - (let ((x (apply f cars))) ; Do head first, - (cons x (recur cdrs))) ; then tail. - '()))) - - ;; Fast path. - (let recur ((lis lis1)) - (if (null-list? lis) lis - (let ((tail (cdr lis)) - (x (f (car lis)))) ; Do head first, - (cons x (recur tail))))))) ; then tail. - - -;;; We extend MAP to handle arguments of unequal length. -;; (define map map-in-order) - - -;;; filter, remove, partition -;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not -;;; disorder the elements of their argument. - -;; This FILTER shares the longest tail of L that has no deleted elements. -;; If Scheme had multi-continuation calls, they could be made more efficient. - -(define (filter pred lis) ; Sleazing with EQ? makes this - (srfi-1:check-arg procedure? pred filter) ; one faster. - (let recur ((lis lis)) - (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists. - (let ((head (car lis)) - (tail (cdr lis))) - (if (pred head) - (let ((new-tail (recur tail))) ; Replicate the RECUR call so - (if (eq? tail new-tail) lis - (cons head new-tail))) - (recur tail)))))) ; this one can be a tail call. - - -;;; Another version that shares longest tail. -;(define (filter pred lis) -; (receive (ans no-del?) -; ;; (recur l) returns L with (pred x) values filtered. -; ;; It also returns a flag NO-DEL? if the returned value -; ;; is EQ? to L, i.e. if it didn't have to delete anything. -; (let recur ((l l)) -; (if (null-list? l) (values l #t) -; (let ((x (car l)) -; (tl (cdr l))) -; (if (pred x) -; (receive (ans no-del?) (recur tl) -; (if no-del? -; (values l #t) -; (values (cons x ans) #f))) -; (receive (ans no-del?) (recur tl) ; Delete X. -; (values ans #f)))))) -; ans)) - - - -;(define (filter! pred lis) ; Things are much simpler -; (let recur ((lis lis)) ; if you are willing to -; (if (pair? lis) ; push N stack frames & do N -; (cond ((pred (car lis)) ; SET-CDR! writes, where N is -; (set-cdr! lis (recur (cdr lis))); the length of the answer. -; lis) -; (else (recur (cdr lis)))) -; lis))) - - -;;; This implementation of FILTER! -;;; - doesn't cons, and uses no stack; -;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are -;;; usually expensive on modern machines, and can be extremely expensive on -;;; modern Schemes (e.g., ones that have generational GC's). -;;; It just zips down contiguous runs of in and out elts in LIS doing the -;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the -;;; beginning of the next. - -(define (filter! pred lis) - (srfi-1:check-arg procedure? pred filter!) - (let lp ((ans lis)) - (cond ((null-list? ans) ans) ; Scan looking for - ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result. - - ;; ANS is the eventual answer. - ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED. - ;; Scan over a contiguous segment of the list that - ;; satisfies PRED. - ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous - ;; segment of the list that *doesn't* satisfy PRED. - ;; When the segment ends, patch in a link from PREV - ;; to the start of the next good segment, and jump to - ;; SCAN-IN. - (else (letrec ((scan-in (lambda (prev lis) - (if (pair? lis) - (if (pred (car lis)) - (scan-in lis (cdr lis)) - (scan-out prev (cdr lis)))))) - (scan-out (lambda (prev lis) - (let lp ((lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (begin (set-cdr! prev lis) - (scan-in lis (cdr lis))) - (lp (cdr lis))) - (set-cdr! prev lis)))))) - (scan-in ans (cdr ans)) - ans))))) - - - -;;; Answers share common tail with LIS where possible; -;;; the technique is slightly subtle. - -(define (partition pred lis) - (srfi-1:check-arg procedure? pred partition) - (let recur ((lis lis)) - (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists. - (let ((elt (car lis)) - (tail (cdr lis))) - (receive (in out) (recur tail) - (if (pred elt) - (values (if (pair? out) (cons elt in) lis) out) - (values in (if (pair? in) (cons elt out) lis)))))))) - - - -;(define (partition! pred lis) ; Things are much simpler -; (let recur ((lis lis)) ; if you are willing to -; (if (null-list? lis) (values lis lis) ; push N stack frames & do N -; (let ((elt (car lis))) ; SET-CDR! writes, where N is -; (receive (in out) (recur (cdr lis)) ; the length of LIS. -; (cond ((pred elt) -; (set-cdr! lis in) -; (values lis out)) -; (else (set-cdr! lis out) -; (values in lis)))))))) - - -;;; This implementation of PARTITION! -;;; - doesn't cons, and uses no stack; -;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are -;;; usually expensive on modern machines, and can be extremely expensive on -;;; modern Schemes (e.g., ones that have generational GC's). -;;; It just zips down contiguous runs of in and out elts in LIS doing the -;;; minimal number of SET-CDR!s to splice these runs together into the result -;;; lists. - -(define (partition! pred lis) - (srfi-1:check-arg procedure? pred partition!) - (if (null-list? lis) (values lis lis) - - ;; This pair of loops zips down contiguous in & out runs of the - ;; list, splicing the runs together. The invariants are - ;; SCAN-IN: (cdr in-prev) = LIS. - ;; SCAN-OUT: (cdr out-prev) = LIS. - (letrec ((scan-in (lambda (in-prev out-prev lis) - (let lp ((in-prev in-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (lp lis (cdr lis)) - (begin (set-cdr! out-prev lis) - (scan-out in-prev lis (cdr lis)))) - (set-cdr! out-prev lis))))) ; Done. - - (scan-out (lambda (in-prev out-prev lis) - (let lp ((out-prev out-prev) (lis lis)) - (if (pair? lis) - (if (pred (car lis)) - (begin (set-cdr! in-prev lis) - (scan-in lis out-prev (cdr lis))) - (lp lis (cdr lis))) - (set-cdr! in-prev lis)))))) ; Done. - - ;; Crank up the scan&splice loops. - (if (pred (car lis)) - ;; LIS begins in-list. Search for out-list's first pair. - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values lis l)) - ((pred (car l)) (lp l (cdr l))) - (else (scan-out prev-l l (cdr l)) - (values lis l)))) ; Done. - - ;; LIS begins out-list. Search for in-list's first pair. - (let lp ((prev-l lis) (l (cdr lis))) - (cond ((not (pair? l)) (values l lis)) - ((pred (car l)) - (scan-in l prev-l (cdr l)) - (values l lis)) ; Done. - (else (lp l (cdr l))))))))) - - -;;; Inline us, please. -(define (remove pred l) (filter (lambda (x) (not (pred x))) l)) -(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) - - - -;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions. -;;; (I don't actually think these are the world's most important -;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants -;;; are far more general.) -;;; -;;; Function Action -;;; --------------------------------------------------------------------------- -;;; remove pred lis Delete by general predicate -;;; delete x lis [=] Delete by element comparison -;;; -;;; find pred lis Search by general predicate -;;; find-tail pred lis Search by general predicate -;;; member x lis [=] Search by element comparison -;;; -;;; assoc key lis [=] Search alist by key comparison -;;; alist-delete key alist [=] Alist-delete by key comparison - -(define (delete x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter (lambda (y) (not (= x y))) lis))) - -(define (delete! x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter! (lambda (y) (not (= x y))) lis))) - -;;; Extended from R4RS to take an optional comparison argument. -(define (member x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (find-tail (lambda (y) (= x y)) lis))) - -;;; R4RS, hence we don't bother to define. -;;; The MEMBER and then FIND-TAIL call should definitely -;;; be inlined for MEMQ & MEMV. -;(define (memq x lis) (member x lis eq?)) -;(define (memv x lis) (member x lis eqv?)) - - -;;; right-duplicate deletion -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; delete-duplicates delete-duplicates! -;;; -;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates -;;; in long lists, sort the list to bring duplicates together, then use a -;;; linear-time algorithm to kill the dups. Or use an algorithm based on -;;; element-marking. The former gives you O(n lg n), the latter is linear. - -(define (delete-duplicates lis . maybe-=) - (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?))) - (srfi-1:check-arg procedure? elt= delete-duplicates) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail))))))) - -(define (delete-duplicates! lis maybe-=) - (let ((elt= (if (pair? maybe-=) (car maybe-=) equal?))) - (srfi-1:check-arg procedure? elt= delete-duplicates!) - (let recur ((lis lis)) - (if (null-list? lis) lis - (let* ((x (car lis)) - (tail (cdr lis)) - (new-tail (recur (delete! x tail elt=)))) - (if (eq? tail new-tail) lis (cons x new-tail))))))) - - -;;; alist stuff -;;;;;;;;;;;;;;; - -;;; Extended from R4RS to take an optional comparison argument. -(define (assoc x lis . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (find (lambda (entry) (= x (car entry))) lis))) - -(define (alist-cons key datum alist) (cons (cons key datum) alist)) - -(define (alist-copy alist) - (map (lambda (elt) (cons (car elt) (cdr elt))) - alist)) - -(define (alist-delete key alist . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter (lambda (elt) (not (= key (car elt)))) alist))) - -(define (alist-delete! key alist . maybe-=) - (let ((= (if (pair? maybe-=) (car maybe-=) equal?))) - (filter! (lambda (elt) (not (= key (car elt)))) alist))) - - -;;; find find-tail take-while drop-while span break any every list-index-pred -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (find pred list) - (cond ((find-tail pred list) => car) - (else #f))) - -(define (find-tail pred list) - (srfi-1:check-arg procedure? pred find-tail) - (let lp ((list list)) - (and (not (null-list? list)) - (if (pred (car list)) list - (lp (cdr list)))))) - -(define (take-while pred lis) - (srfi-1:check-arg procedure? pred take-while) - (let recur ((lis lis)) - (if (null-list? lis) '() - (let ((x (car lis))) - (if (pred x) - (cons x (recur (cdr lis))) - '()))))) - -(define (drop-while pred lis) - (srfi-1:check-arg procedure? pred drop-while) - (let lp ((lis lis)) - (if (null-list? lis) '() - (if (pred (car lis)) - (lp (cdr lis)) - lis)))) - -(define (take-while! pred lis) - (srfi-1:check-arg procedure? pred take-while!) - (if (or (null-list? lis) (not (pred (car lis)))) '() - (begin (let lp ((prev lis) (rest (cdr lis))) - (if (pair? rest) - (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) - (set-cdr! prev '()))))) - lis))) - -(define (span pred lis) - (srfi-1:check-arg procedure? pred span) - (let recur ((lis lis)) - (if (null-list? lis) (values '() '()) - (let ((x (car lis))) - (if (pred x) - (receive (prefix suffix) (recur (cdr lis)) - (values (cons x prefix) suffix)) - (values '() lis)))))) - -(define (span! pred lis) - (srfi-1:check-arg procedure? pred span!) - (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis) - (let ((suffix (let lp ((prev lis) (rest (cdr lis))) - (if (null-list? rest) rest - (let ((x (car rest))) - (if (pred x) (lp rest (cdr rest)) - (begin (set-cdr! prev '()) - rest))))))) - (values lis suffix)))) - - -(define (break pred lis) (span (lambda (x) (not (pred x))) lis)) -(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis)) - -(define (any pred lis1 . lists) - (srfi-1:check-arg procedure? pred any) - (if (pair? lists) - - ;; N-ary case - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (and (pair? heads) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (or (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) ; Last PRED app is tail call. - - ;; Fast path - (and (not (null-list? lis1)) - (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail) - (pred head) ; Last PRED app is tail call. - (or (pred head) (lp (car tail) (cdr tail)))))))) - - -;(define (every pred list) ; Simple definition. -; (let lp ((list list)) ; Doesn't return the last PRED value. -; (or (not (pair? list)) -; (and (pred (car list)) -; (lp (cdr list)))))) - -(define (every pred lis1 . lists) - (srfi-1:check-arg procedure? pred every) - (if (pair? lists) - - ;; N-ary case - (receive (heads tails) (%cars+cdrs (cons lis1 lists)) - (or (not (pair? heads)) - (let lp ((heads heads) (tails tails)) - (receive (next-heads next-tails) (%cars+cdrs tails) - (if (pair? next-heads) - (and (apply pred heads) (lp next-heads next-tails)) - (apply pred heads)))))) ; Last PRED app is tail call. - - ;; Fast path - (or (null-list? lis1) - (let lp ((head (car lis1)) (tail (cdr lis1))) - (if (null-list? tail) - (pred head) ; Last PRED app is tail call. - (and (pred head) (lp (car tail) (cdr tail)))))))) - -(define (list-index-pred pred lis1 . lists) - (srfi-1:check-arg procedure? pred list-index-pred) - (if (pair? lists) - - ;; N-ary case - (let lp ((lists (cons lis1 lists)) (n 0)) - (receive (heads tails) (%cars+cdrs lists) - (and (pair? heads) - (if (apply pred heads) n - (lp tails (+ n 1)))))) - - ;; Fast path - (let lp ((lis lis1) (n 0)) - (and (not (null-list? lis)) - (if (pred (car lis)) n (lp (cdr lis) (+ n 1))))))) - -;;; Reverse -;;;;;;;;;;; - -;R4RS, so not defined here. -;(define (reverse lis) (fold cons '() lis)) - -;(define (reverse! lis) -; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis)) - -(define (reverse! lis) - (let lp ((lis lis) (ans '())) - (if (null-list? lis) ans - (let ((tail (cdr lis))) - (set-cdr! lis ans) - (lp tail lis))))) - -;;; Lists-as-sets -;;;;;;;;;;;;;;;;; - -;;; This is carefully tuned code; do not modify casually. -;;; - It is careful to share storage when possible; -;;; - Side-effecting code tries not to perform redundant writes. -;;; - It tries to avoid linear-time scans in special cases where constant-time -;;; computations can be performed. -;;; - It relies on similar properties from the other list-lib procs it calls. -;;; For example, it uses the fact that the implementations of MEMBER and -;;; FILTER in this source code share longest common tails between args -;;; and results to get structure sharing in the lset procedures. - -(define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1)) - -(define (lset<= = . lists) - (srfi-1:check-arg procedure? = lset<=) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) (rest (cdr rest))) - (and (or (eq? s2 s1) ; Fast path - (%lset2<= = s1 s2)) ; Real test - (lp s2 rest))))))) - -(define (lset= = . lists) - (srfi-1:check-arg procedure? = lset=) - (or (not (pair? lists)) ; 0-ary case - (let lp ((s1 (car lists)) (rest (cdr lists))) - (or (not (pair? rest)) - (let ((s2 (car rest)) - (rest (cdr rest))) - (and (or (eq? s1 s2) ; Fast path - (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test - (lp s2 rest))))))) - - -(define (lset-adjoin = lis . elts) - (srfi-1:check-arg procedure? = lset-adjoin) - (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) - lis elts)) - - -(define (lset-union = . lists) - (srfi-1:check-arg procedure? = lset-union) - (reduce (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 (any (lambda (x) (= x elt)) ans) - ans - (cons elt ans))) - ans lis)))) - '() lists)) - -(define (lset-union! = . lists) - (srfi-1:check-arg procedure? = lset-union!) - (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS. - (cond ((null? lis) ans) ; Don't copy any lists - ((null? ans) lis) ; if we don't have to. - ((eq? lis ans) ans) - (else - (pair-fold (lambda (pair ans) - (let ((elt (car pair))) - (if (any (lambda (x) (= x elt)) ans) - ans - (begin (set-cdr! pair ans) pair)))) - ans lis)))) - '() lists)) - - -(define (lset-intersection = lis1 . lists) - (srfi-1:check-arg procedure? = lset-intersection) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut - (else (filter (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - -(define (lset-intersection! = lis1 . lists) - (srfi-1:check-arg procedure? = lset-intersection!) - (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals. - (cond ((any null-list? lists) '()) ; Short cut - ((null? lists) lis1) ; Short cut - (else (filter! (lambda (x) - (every (lambda (lis) (member x lis =)) lists)) - lis1))))) - - -(define (lset-difference = lis1 . lists) - (srfi-1:check-arg procedure? = lset-difference) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut - (else (filter (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - -(define (lset-difference! = lis1 . lists) - (srfi-1:check-arg procedure? = lset-difference!) - (let ((lists (filter pair? lists))) ; Throw out empty lists. - (cond ((null? lists) lis1) ; Short cut - ((memq lis1 lists) '()) ; Short cut - (else (filter! (lambda (x) - (every (lambda (lis) (not (member x lis =))) - lists)) - lis1))))) - - -(define (lset-xor = . lists) - (srfi-1:check-arg procedure? = lset-xor) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection = a b) - (cond ((null? a-b) (lset-difference b a =)) - ((null? a-int-b) (append b a)) - (else (fold (lambda (xb ans) - (if (member xb a-int-b =) ans (cons xb ans))) - a-b - b))))) - '() lists)) - - -(define (lset-xor! = . lists) - (srfi-1:check-arg procedure? = lset-xor!) - (reduce (lambda (b a) ; Compute A xor B: - ;; Note that this code relies on the constant-time - ;; short-cuts provided by LSET-DIFF+INTERSECTION, - ;; LSET-DIFFERENCE & APPEND to provide constant-time short - ;; cuts for the cases A = (), B = (), and A eq? B. It takes - ;; a careful case analysis to see it, but it's carefully - ;; built in. - - ;; Compute a-b and a^b, then compute b-(a^b) and - ;; cons it onto the front of a-b. - (receive (a-b a-int-b) (lset-diff+intersection! = a b) - (cond ((null? a-b) (lset-difference! b a =)) - ((null? a-int-b) (append! b a)) - (else (pair-fold (lambda (b-pair ans) - (if (member (car b-pair) a-int-b =) ans - (begin (set-cdr! b-pair ans) b-pair))) - a-b - b))))) - '() lists)) - - -(define (lset-diff+intersection = lis1 . lists) - (srfi-1:check-arg procedure? = lset-diff+intersection) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) - -(define (lset-diff+intersection! = lis1 . lists) - (srfi-1:check-arg procedure? = lset-diff+intersection!) - (cond ((every null-list? lists) (values lis1 '())) ; Short cut - ((memq lis1 lists) (values '() lis1)) ; Short cut - (else (partition! (lambda (elt) - (not (any (lambda (lis) (member elt lis =)) - lists))) - lis1)))) diff --git a/lib/srfi/srfi-11.scm b/lib/srfi/srfi-11.scm deleted file mode 100644 index 6e59836c4a..0000000000 --- a/lib/srfi/srfi-11.scm +++ /dev/null @@ -1,234 +0,0 @@ -;;;; srfi-11.scm --- SRFI-11 procedures for Guile - -;;; Copyright (C) 2000 Free Software Foundation, Inc. -;;; -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation; either version 2, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this software; see the file COPYING. If not, write to -;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;; Boston, MA 02111-1307 USA - -(define-module (srfi srfi-11) - :use-module (ice-9 syncase)) - -(export-syntax let-values let*-values) - -;;;;;;;;;;;;;; -;; let-values -;; -;; Current approach is to translate -;; -;; (let-values (((x y . z) (foo a b)) -;; ((p q) (bar c))) -;; (baz x y z p q)) -;; -;; into -;; -;; (call-with-values (lambda () (foo a b)) -;; (lambda ( . ) -;; (call-with-values (lambda () (bar c)) -;; (lambda ( ) -;; (let ((x ) -;; (y ) -;; (z ) -;; (p ) -;; (q )) -;; (baz x y z p q)))))) - -;; I originally wrote this as a define-macro, but then I found out -;; that guile's gensym/gentemp was broken, so I tried rewriting it as -;; a syntax-rules statement. -;; -;; Since syntax-rules didn't seem powerful enough to implement -;; let-values in one definition without exposing illegal syntax (or -;; perhaps my brain's just not powerful enough :>). I tried writing -;; it using a private helper, but that didn't work because the -;; let-values expands outside the scope of this module. I wonder why -;; syntax-rules wasn't designed to allow "private" patterns or -;; similar... -;; -;; So in the end, I dumped the syntax-rules implementation, reproduced -;; here for posterity, and went with the define-macro one below -- -;; gensym/gentemp's got to be fixed anyhow... -; -; (define-syntax let-values-helper -; (syntax-rules () -; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y -; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda -; ;; ( ) ...) from above, keeping track of the -; ;; temps you create so you can use them later... -; ;; -; ;; I really don't fully understand why the (var-1 var-1) trick -; ;; works below, but basically, when all those (x x) bindings show -; ;; up in the final "let", syntax-rules forces a renaming. - -; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings -; body ...) -; (lambda lambda-tmps -; (let-values-helper "cwv" lv-bindings final-let-bindings body ...))) - -; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings lv-bindings -; body ...) -; (let-values-helper "consumer" -; (var-2 ...) -; (lambda-tmp ... var-1) -; ((var-1 var-1) . final-let-bindings) -; lv-bindings -; body ...)) - -; ((_ "cwv" () final-let-bindings body ...) -; (let final-let-bindings -; body ...)) - -; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings -; body ...) -; (call-with-values (lambda () binding-1) -; (let-values-helper "consumer" -; vars-1 -; () -; final-let-bindings -; (other-bindings ...) -; body ...))))) -; -; (define-syntax let-values -; (syntax-rules () -; ((let-values () body ...) -; (begin body ...)) -; ((let-values (binding ...) body ...) -; (let-values-helper "cwv" (binding ...) () body ...)))) -; -; -; (define-syntax let-values -; (letrec-syntax ((build-consumer -; ;; Take the vars from one let binding (i.e. the (x -; ;; y z) from ((x y z) (values 1 2 3)) and turn it -; ;; in to the corresponding (lambda ( -; ;; ) ...) from above. -; (syntax-rules () -; ((_ () new-tmps tmp-vars () body ...) -; (lambda new-tmps -; body ...)) -; ((_ () new-tmps tmp-vars vars body ...) -; (lambda new-tmps -; (lv-builder vars tmp-vars body ...))) -; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...) -; (build-consumer (var-2 ...) -; (tmp-1 . new-tmps) -; ((var-1 tmp-1) . tmp-vars) -; bindings -; body ...)))) -; (lv-builder -; (syntax-rules () -; ((_ () tmp-vars body ...) -; (let tmp-vars -; body ...)) -; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...) -; tmp-vars -; body ...) -; (call-with-values (lambda () binding-1) -; (build-consumer vars-1 -; () -; tmp-vars -; ((vars-2 binding-2) ...) -; body ...)))))) -; -; (syntax-rules () -; ((_ () body ...) -; (begin body ...)) -; ((_ ((vars binding) ...) body ...) -; (lv-builder ((vars binding) ...) () body ...))))) - -;; FIXME: This is currently somewhat unsafe (b/c gentemp/gensym is -;; broken -- right now (as of 1.4.1, it doesn't generate unique -;; symbols) -(define-macro (let-values vars . body) - - (define (map-1-dot proc elts) - ;; map over one optionally dotted (a b c . d) list, producing an - ;; optionally dotted result. - (cond - ((null? elts) '()) - ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts)))) - (else (proc elts)))) - - (define (undot-list lst) - ;; produce a non-dotted list from a possibly dotted list. - (cond - ((null? lst) '()) - ((pair? lst) (cons (car lst) (undot-list (cdr lst)))) - (else (list lst)))) - - (define (let-values-helper vars body prev-let-vars) - (let* ((var-binding (car vars)) - (new-tmps (map-1-dot (lambda (sym) (gentemp)) - (car var-binding))) - (let-vars (map (lambda (sym tmp) (list sym tmp)) - (undot-list (car var-binding)) - (undot-list new-tmps)))) - - (if (null? (cdr vars)) - `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,new-tmps - (let ,(apply append let-vars prev-let-vars) - ,@body))) - `(call-with-values (lambda () ,(cadr var-binding)) - (lambda ,new-tmps - ,(let-values-helper (cdr vars) body - (cons let-vars prev-let-vars))))))) - - (if (null? vars) - `(begin ,@body) - (let-values-helper vars body '()))) - -;;;;;;;;;;;;;; -;; let*-values -;; -;; Current approach is to translate -;; -;; (let*-values (((x y z) (foo a b)) -;; ((p q) (bar c))) -;; (baz x y z p q)) -;; -;; into -;; -;; (call-with-values (lambda () (foo a b)) -;; (lambda (x y z) -;; (call-with-values (lambda (bar c)) -;; (lambda (p q) -;; (baz x y z p q))))) - -(define-syntax let*-values - (syntax-rules () - ((let*-values () body ...) - (begin body ...)) - ((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...) - (call-with-values (lambda () binding-1) - (lambda vars-1 - (let*-values ((vars-2 binding-2) ...) - body ...)))))) - -; Alternate define-macro implementation... -; -; (define-macro (let*-values vars . body) -; (define (let-values-helper vars body) -; (let ((var-binding (car vars))) -; (if (null? (cdr vars)) -; `(call-with-values (lambda () ,(cadr var-binding)) -; (lambda ,(car var-binding) -; ,@body)) -; `(call-with-values (lambda () ,(cadr var-binding)) -; (lambda ,(car var-binding) -; ,(let-values-helper (cdr vars) body)))))) - -; (if (null? vars) -; `(begin ,@body) -; (let-values-helper vars body))) diff --git a/lib/srfi/srfi-19.scm b/lib/srfi/srfi-19.scm deleted file mode 100644 index 8299156ee2..0000000000 --- a/lib/srfi/srfi-19.scm +++ /dev/null @@ -1,1496 +0,0 @@ -;;; srfi-19.scm --- SRFI-19 procedures for Guile -;;; -;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;; -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation; either version 2, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this software; see the file COPYING. If not, write to -;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;; Boston, MA 02111-1307 USA -;;; -;;; Originally from SRFI reference implementation by Will Fitzgerald. -;;; Ported to Guile by Rob Browning - -;; 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". - -;;; Modifications from the "official" implementation. -;;; -;;; Removed all non r5rs-isms that I detected (i.e :optional). - -(define-module (srfi srfi-19) - :use-module (srfi srfi-8) - :use-module (srfi srfi-9)) - -(export - ;; Constants - time-duration - time-monotonic - time-process - time-tai - time-thread - time-utc - ;; Current time and clock resolution - current-date - current-julian-day - current-modified-julian-day - current-time - time-resolution - ;; Time object and accessors - make-time - time? - time-type - time-nanosecond - time-second - set-time-type! - set-time-nanosecond! - set-time-second! - copy-time - ;; Time comparison procedures - time<=? - time=? - time>? - ;; Time arithmetic procedures - time-difference - time-difference! - add-duration - add-duration! - subtract-duration - subtract-duration! - ;; Date object and accessors - make-date - date? - date-nanosecond - date-second - date-minute - date-hour - date-day - date-month - date-year - date-zone-offset? - date-year-day - date-week-day - date-week-number - ;; Time/Date/Julian Day/Modified Julian Day converters - date->julian-day - date->modified-julian-day - date->time-monotonic - date->time-tai - date->time-utc - julian-day->date - julian-day->time-monotonic - julian-day->time-tai - julian-day->time-utc - modified-julian-day->date - modified-julian-day->time-monotonic - modified-julian-day->time-tai - modified-julian-day->time-utc - time-monotonic->date - time-monotonic->time-monotonic - 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) - -;; Guile's prior to 1.5.X didn't have this. - -(if (not (defined? 'open-input-string)) - (define (open-input-string str) - (call-with-input-string str (lambda (port) port)))) - -(define time-tai 'time-tai) -(define time-utc 'time-utc) -(define time-monotonic 'time-monotonic) -(define time-thread 'time-thread) -(define time-process 'time-process) -(define time-duration 'time-duration) - -;; FIXME: do we want to add gc time? -;; (define time-gc 'time-gc) - -;;-- LOCALE dependent constants - -(define priv:locale-number-separator ".") - -(define priv:locale-abbr-weekday-vector - (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")) - -(define priv:locale-long-weekday-vector - (vector - "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) - -;; note empty string in 0th place. -(define priv:locale-abbr-month-vector - (vector "" - "Jan" - "Feb" - "Mar" - "Apr" - "May" - "Jun" - "Jul" - "Aug" - "Sep" - "Oct" - "Nov" - "Dec")) - -(define priv:locale-long-month-vector - (vector "" - "January" - "February" - "March" - "April" - "May" - "June" - "July" - "August" - "September" - "October" - "November" - "December")) - -(define priv:locale-pm "PM") -(define priv:locale-am "AM") - -;; See date->string -(define priv:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y") -(define priv:locale-short-date-format "~m/~d/~y") -(define priv:locale-time-format "~H:~M:~S") -(define priv:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z") - -;;-- Miscellaneous Constants. -;;-- only the priv:tai-epoch-in-jd might need changing if -;; a different epoch is used. - -(define priv:nano 1000000000) ; nanoseconds in a second -(define priv:sid 86400) ; seconds in a day -(define priv:sihd 43200) ; seconds in a half day -(define priv:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch' - -;; FIXME: should this be something other than misc-error? -(define (priv:time-error caller type value) - (if value - (throw 'misc-error caller "TIME-ERROR type ~A: ~S" (list type value) #f) - (throw 'misc-error caller "TIME-ERROR type ~A" (list type) #f))) - -;; A table of leap seconds -;; See ftp://maia.usno.navy.mil/ser7/tai-utc.dat -;; and update as necessary. -;; this procedures reads the file in the abover -;; format and creates the leap second table -;; it also calls the almost standard, but not R5 procedures read-line -;; & open-input-string -;; ie (set! priv:leap-second-table (priv:read-tai-utc-date "tai-utc.dat")) - -(define (priv:read-tai-utc-data filename) - (define (convert-jd jd) - (* (- (inexact->exact jd) priv:tai-epoch-in-jd) priv:sid)) - (define (convert-sec sec) - (inexact->exact sec)) - (let ((port (open-input-file filename)) - (table '())) - (let loop ((line (read-line port))) - (if (not (eq? line eof)) - (begin - (let* ((data (read (open-input-string - (string-append "(" line ")")))) - (year (car data)) - (jd (cadddr (cdr data))) - (secs (cadddr (cdddr data)))) - (if (>= year 1972) - (set! table (cons - (cons (convert-jd jd) (convert-sec secs)) - table))) - (loop (read-line port)))))) - table)) - -;; each entry is (tai seconds since epoch . # seconds to subtract for utc) -;; note they go higher to lower, and end in 1972. -(define priv:leap-second-table - '((915148800 . 32) - (867715200 . 31) - (820454400 . 30) - (773020800 . 29) - (741484800 . 28) - (709948800 . 27) - (662688000 . 26) - (631152000 . 25) - (567993600 . 24) - (489024000 . 23) - (425865600 . 22) - (394329600 . 21) - (362793600 . 20) - (315532800 . 19) - (283996800 . 18) - (252460800 . 17) - (220924800 . 16) - (189302400 . 15) - (157766400 . 14) - (126230400 . 13) - (94694400 . 12) - (78796800 . 11) - (63072000 . 10))) - -(define (read-leap-second-table filename) - (set! priv:leap-second-table (priv:read-tai-utc-data filename)) - (values)) - - -(define (priv:leap-second-delta utc-seconds) - (letrec ((lsd (lambda (table) - (cond ((>= utc-seconds (caar table)) - (cdar table)) - (else (lsd (cdr table))))))) - (if (< utc-seconds (* (- 1972 1970) 365 priv:sid)) 0 - (lsd priv:leap-second-table)))) - - -;;; the TIME structure; creates the accessors, too. - -(define-record-type time - (make-time-unnormalized type nanosecond second) - time? - (type time-type set-time-type!) - (nanosecond time-nanosecond set-time-nanosecond!) - (second time-second set-time-second!)) - -(define (copy-time time) - (make-time (time-type time) (time-nanosecond time) (time-second time))) - -(define (priv:time-normalize! t) - (if (>= (abs (time-nanosecond t)) 1000000000) - (begin - (set-time-second! t (+ (time-second t) - (quotient (time-nanosecond t) 1000000000))) - (set-time-nanosecond! t (remainder (time-nanosecond t) - 1000000000)))) - (if (and (positive? (time-second t)) - (negative? (time-nanosecond t))) - (begin - (set-time-second! t (- (time-second t) 1)) - (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))) - (if (and (negative? (time-second t)) - (positive? (time-nanosecond t))) - (begin - (set-time-second! t (+ (time-second t) 1)) - (set-time-nanosecond! t (+ 1000000000 (time-nanosecond t)))))) - t) - -(define (make-time type nanosecond second) - (priv:time-normalize! (make-time-unnormalized type nanosecond second))) - -;; Helpers -;; FIXME: finish this and publish it? -(define (date->broken-down-time date) - (let ((result (mktime 0))) - ;; FIXME: What should we do about leap-seconds which may overflow - ;; set-tm:sec? - (set-tm:sec result (date-second date)) - (set-tm:min result (date-minute date)) - (set-tm:hour result (date-hour date)) - ;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday). - (set-tm:mday result (date-day date)) - (set-tm:month result (- (date-month date) 1)) - ;; FIXME: need to signal error on range violation. - (set-tm:year result (+ 1900 (date-year date))) - (set-tm:isdst result -1) - (set-tm:gmtoff result (- (date-zone-offset date))) - result)) - -;;; current-time - -;;; specific time getters. - -(define (priv:current-time-utc) - ;; Resolution is microseconds. - (let ((tod (gettimeofday))) - (make-time time-utc (* (cdr tod) 1000) (car tod)))) - -(define (priv:current-time-tai) - ;; Resolution is microseconds. - (let* ((tod (gettimeofday)) - (sec (car tod)) - (usec (cdr tod))) - (make-time time-tai - (* usec 1000) - (+ (car tod) (priv:leap-second-delta seconds))))) - -;;(define (priv:current-time-ms-time time-type proc) -;; (let ((current-ms (proc))) -;; (make-time time-type -;; (quotient current-ms 10000) -;; (* (remainder current-ms 1000) 10000)))) - -;; -- we define it to be the same as TAI. -;; A different implemation of current-time-montonic -;; will require rewriting all of the time-monotonic converters, -;; of course. - -(define (priv:current-time-monotonic) - ;; Resolution is microseconds. - (priv:current-time-tai)) - -(define (priv:current-time-thread) - (priv:time-error 'current-time 'unsupported-clock-type 'time-thread)) - -(define priv:ns-per-guile-tick (/ 1000000000 internal-time-units-per-second)) - -(define (priv:current-time-process) - (let ((run-time (get-internal-run-time))) - (make-time - time-process - (quotient run-time internal-time-units-per-second) - (* (remainder run-time internal-time-units-per-second) - priv:ns-per-guile-tick)))) - -(define (priv:current-time-process) - (let ((run-time (get-internal-run-time))) - (list - 'time-process - (* (remainder run-time internal-time-units-per-second) - priv:ns-per-guile-tick) - (quotient run-time internal-time-units-per-second)))) - -;;(define (priv:current-time-gc) -;; (priv:current-time-ms-time time-gc current-gc-milliseconds)) - -(define (current-time . clock-type) - (let ((clock-type (if (null? clock-type) time-utc (car clock-type)))) - (cond - ((eq? clock-type time-tai) (priv:current-time-tai)) - ((eq? clock-type time-utc) (priv:current-time-utc)) - ((eq? clock-type time-monotonic) (priv:current-time-monotonic)) - ((eq? clock-type time-thread) (priv:current-time-thread)) - ((eq? clock-type time-process) (priv:current-time-process)) - ;; ((eq? clock-type time-gc) (priv:current-time-gc)) - (else (priv:time-error 'current-time 'invalid-clock-type clock-type))))) - -;; -- Time Resolution -;; This is the resolution of the clock in nanoseconds. -;; This will be implementation specific. - -(define (time-resolution . clock-type) - (let ((clock-type (if (null? clock-type) time-utc (car clock-type)))) - (case clock-type - ((time-tai) 1000) - ((time-utc) 1000) - ((time-monotonic) 1000) - ((time-process) priv:ns-per-guile-tick) - ;; ((eq? clock-type time-thread) 1000) - ;; ((eq? clock-type time-gc) 10000) - (else (priv:time-error 'time-resolution 'invalid-clock-type clock-type))))) - -;; -- Time comparisons - -(define (time=? t1 t2) - ;; Arrange tests for speed and presume that t1 and t2 are actually times. - ;; also presume it will be rare to check two times of different types. - (and (= (time-second t1) (time-second t2)) - (= (time-nanosecond t1) (time-nanosecond 2)) - (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 time1) (time-second time2)) - (and (= (time-second time1) (time-second time2)) - (<= (time-nanosecond time1) (time-nanosecond time2))))) - -;; -- Time arithmetic - -(define (time-difference! time1 time2) - (let ((sec-diff (- (time-second time1) (time-second time2))) - (nsec-diff (- (time-nanosecond time1) (time-nanosecond time2)))) - (set-time-type! time1 time-duration) - (set-time-second! time1 sec-diff) - (set-time-nanosecond! time1 nsec-diff) - (priv:time-normalize! time1))) - -(define (time-difference time1 time2) - (let ((result (copy-time time1))) - (time-difference! result time2))) - -(define (add-duration! t duration) - (if (not (eq? (time-type duration) time-duration)) - (priv:time-error 'add-duration 'not-duration duration) - (let ((sec-plus (+ (time-second t) (time-second duration))) - (nsec-plus (+ (time-nanosecond t) (time-nanosecond duration)))) - (set-time-second! t sec-plus) - (set-time-nanosecond! t nsec-plus) - (priv:time-normalize! t)))) - -(define (priv:add-duration t duration) - (let ((result (copy-time t))) - (add-duration! result))) - -(define (subtract-duration! t duration) - (if (not (eq? (time-type duration) time-duration)) - (priv:time-error 'add-duration 'not-duration duration) - (let ((sec-minus (- (time-second t) (time-second duration))) - (nsec-minus (- (time-nanosecond t) (time-nanosecond duration)))) - (set-time-second! t sec-minus) - (set-time-nanosecond! t nsec-minus) - (priv:time-normalize! t)))) - -(define (subtract-duration time1 duration) - (let ((result (copy-time time1))) - (subtract-duration! result duration))) - -;; -- Converters between types. - -(define (priv:time-tai->time-utc! time-in time-out caller) - (if (not (eq? (time-type time-in) time-tai)) - (priv:time-error caller 'incompatible-time-types time-in)) - (set-time-type! time-out time-utc) - (set-time-nanosecond! time-out (time-nanosecond time-in)) - (set-time-second! time-out (- (time-second time-in) - (priv:leap-second-delta - (time-second time-in)))) - time-out) - -(define (time-tai->time-utc time-in) - (priv:time-tai->time-utc! time-in (make-time #f #f #f) 'time-tai->time-utc)) - - -(define (time-tai->time-utc! time-in) - (priv:time-tai->time-utc! time-in time-in 'time-tai->time-utc!)) - -(define (priv:time-utc->time-tai! time-in time-out caller) - (if (not (eq? (time-type time-in) time-utc)) - (priv:time-error caller 'incompatible-time-types time-in)) - (set-time-type! time-out time-tai) - (set-time-nanosecond! time-out (time-nanosecond time-in)) - (set-time-second! time-out (+ (time-second time-in) - (priv:leap-second-delta - (time-second time-in)))) - time-out) - -(define (time-utc->time-tai time-in) - (priv:time-utc->time-tai! time-in (make-time #f #f #f) 'time-utc->time-tai)) - -(define (time-utc->time-tai! time-in) - (priv:time-utc->time-tai! time-in time-in 'time-utc->time-tai!)) - -;; -- these depend on time-monotonic having the same definition as time-tai! -(define (time-monotonic->time-utc time-in) - (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) - (let ((ntime (copy-time time-in))) - (set-time-type! ntime time-tai) - (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))) - -(define (time-monotonic->time-utc! time-in) - (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) - (set-time-type! time-in time-tai) - (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)) - -(define (time-monotonic->time-tai time-in) - (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) - (let ((ntime (copy-time time-in))) - (set-time-type! ntime time-tai) - ntime)) - -(define (time-monotonic->time-tai! time-in) - (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) - (set-time-type! time-in time-tai) - time-in) - -(define (time-utc->time-monotonic time-in) - (if (not (eq? (time-type time-in) time-utc)) - (priv:time-error caller 'incompatible-time-types time-in)) - (let ((ntime (priv:time-utc->time-tai! time-in (make-time #f #f #f) - 'time-utc->time-monotonic))) - (set-time-type! ntime time-monotonic) - ntime)) - -(define (time-utc->time-monotonic! time-in) - (if (not (eq? (time-type time-in) time-utc)) - (priv:time-error caller 'incompatible-time-types time-in)) - (let ((ntime (priv:time-utc->time-tai! time-in time-in - 'time-utc->time-monotonic!))) - (set-time-type! ntime time-monotonic) - ntime)) - -(define (time-tai->time-monotonic time-in) - (if (not (eq? (time-type time-in) time-tai)) - (priv:time-error caller 'incompatible-time-types time-in)) - (let ((ntime (copy-time time-in))) - (set-time-type! ntime time-monotonic) - ntime)) - -(define (time-tai->time-monotonic! time-in) - (if (not (eq? (time-type time-in) time-tai)) - (priv:time-error caller 'incompatible-time-types time-in)) - (set-time-type! time-in time-monotonic) - time-in) - -;; -- Date Structures - -;; FIXME: to be really safe, perhaps we should normalize the -;; seconds/nanoseconds/minutes coming in to make-date... - -(define-record-type date - (make-date nanosecond second minute - hour day month - year - zone-offset) - date? - (nanosecond date-nanosecond) - (second date-second) - (minute date-minute) - (hour date-hour) - (day date-day) - (month date-month) - (year date-year) - (zone-offset date-zone-offset)) - -;; gives the julian day which starts at noon. -(define (priv:encode-julian-day-number day month year) - (let* ((a (quotient (- 14 month) 12)) - (y (- (+ year 4800) a (if (negative? year) -1 0))) - (m (- (+ month (* 12 a)) 3))) - (+ day - (quotient (+ (* 153 m) 2) 5) - (* 365 y) - (quotient y 4) - (- (quotient y 100)) - (quotient y 400) - -32045))) - -(define (priv:split-real r) - (if (integer? r) (values r 0) - (let ((l (truncate r))) - (values l (- r l))))) - -;; gives the seconds/date/month/year -(define (priv:decode-julian-day-number jdn) - (let* ((days (inexact->exact (truncate jdn))) - (a (+ days 32044)) - (b (quotient (+ (* 4 a) 3) 146097)) - (c (- a (quotient (* 146097 b) 4))) - (d (quotient (+ (* 4 c) 3) 1461)) - (e (- c (quotient (* 1461 d) 4))) - (m (quotient (+ (* 5 e) 2) 153)) - (y (+ (* 100 b) d -4800 (quotient m 10)))) - (values ; seconds date month year - (* (- jdn days) priv:sid) - (+ e (- (quotient (+ (* 153 m) 2) 5)) 1) - (+ m 3 (* -12 (quotient m 10))) - (if (>= 0 y) (- y 1) y)))) - -;; relies on the fact that we named our time zone accessor -;; differently from MzScheme's.... -;; This should be written to be OS specific. - -(define (priv:local-tz-offset) - ;; SRFI uses seconds West, but guile (and libc) use seconds East. - (- (tm:gmtoff (localtime 0)))) - -;; special thing -- ignores nanos -(define (priv:time->julian-day-number seconds tz-offset) - (+ (/ (+ seconds tz-offset priv:sihd) - priv:sid) - priv:tai-epoch-in-jd)) - -(define (priv:leap-second? second) - (and (assoc second priv:leap-second-table) #t)) - -(define (time-utc->date time . tz-offset) - (if (not (eq? (time-type time) time-utc)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) - (leap-second? (priv:leap-second? (+ offset (time-second time)))) - (jdn (priv:time->julian-day-number (if leap-second? - (- (time-second time) 1) - (time-second time)) - offset))) - - (call-with-values (lambda () (priv:decode-julian-day-number jdn)) - (lambda (secs date month year) - (let* ((int-secs (inexact->exact (floor secs))) - (hours (quotient int-secs (* 60 60))) - (rem (remainder int-secs (* 60 60))) - (minutes (quotient rem 60)) - (seconds (remainder rem 60))) - (make-date (time-nanosecond time) - (if leap-second? (+ seconds 1) seconds) - minutes - hours - date - month - year - offset)))))) - -(define (time-tai->date time . tz-offset) - (if (not (eq? (time-type time) time-tai)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) - (seconds (- (time-second time) - (priv:leap-second-delta (time-second time)))) - (leap-second? (priv:leap-second? (+ offset seconds))) - (jdn (priv:time->julian-day-number (if leap-second? - (- seconds 1) - seconds) - offset))) - (call-with-values (lambda () (priv:decode-julian-day-number jdn)) - (lambda (secs date month year) - ;; adjust for leap seconds if necessary ... - (let* ((hours (quotient secs (* 60 60))) - (rem (remainder secs (* 60 60))) - (minutes (quotient rem 60)) - (seconds (remainder rem 60))) - (make-date (time-nanosecond time) - (if leap-second? (+ seconds 1) seconds) - minutes - hours - date - month - year - offset)))))) - -;; this is the same as time-tai->date. -(define (time-monotonic->date time . tz-offset) - (if (not (eq? (time-type time) time-monotonic)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (let* ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset))) - (seconds (- (time-second time) - (priv:leap-second-delta (time-second time)))) - (leap-second? (priv:leap-second? (+ offset seconds))) - (jdn (priv:time->julian-day-number (if leap-second? - (- seconds 1) - seconds) - offset))) - (call-with-values (lambda () (priv:decode-julian-day-number jdn)) - (lambda (secs date month year) - ;; adjust for leap seconds if necessary ... - (let* ((hours (quotient secs (* 60 60))) - (rem (remainder secs (* 60 60))) - (minutes (quotient rem 60)) - (seconds (remainder rem 60))) - (make-date (time-nanosecond time) - (if leap-second? (+ seconds 1) seconds) - minutes - hours - date - month - year - offset)))))) - -(define (date->time-utc date) - (let ((jdays (- (priv:encode-julian-day-number (date-day date) - (date-month date) - (date-year date)) - priv:tai-epoch-in-jd))) - (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))))) - -(define (date->time-tai date) - (time-utc->time-tai! (date->time-utc date))) - -(define (date->time-monotonic date) - (time-utc->time-monotonic! (date->time-utc date))) - -(define (priv:leap-year? year) - (or (= (modulo year 400) 0) - (and (= (modulo year 4) 0) (not (= (modulo year 100) 0))))) - -(define (leap-year? date) - (priv:leap-year? (date-year date))) - -(define priv:month-assoc '((1 . 31) (2 . 59) (3 . 90) (4 . 120) - (5 . 151) (6 . 181) (7 . 212) (8 . 243) - (9 . 273) (10 . 304) (11 . 334) (12 . 365))) - -(define (priv:year-day day month year) - (let ((days-pr (assoc day priv:month-assoc))) - (if (not days-pr) - (priv:error 'date-year-day 'invalid-month-specification month)) - (if (and (priv:leap-year? year) (> month 2)) - (+ day (cdr days-pr) 1) - (+ day (cdr days-pr))))) - -(define (date-year-day date) - (priv:year-day (date-day date) (date-month date) (date-year date))) - -;; from calendar faq -(define (priv:week-day day month year) - (let* ((a (quotient (- 14 month) 12)) - (y (- year a)) - (m (+ month (* 12 a) -2))) - (modulo (+ day - y - (quotient y 4) - (- (quotient y 100)) - (quotient y 400) - (quotient (* 31 m) 12)) - 7))) - -(define (date-week-day date) - (priv:week-day (date-day date) (date-month date) (date-year date))) - -(define (priv:days-before-first-week date day-of-week-starting-week) - (let* ((first-day (make-date 0 0 0 0 - 1 - 1 - (date-year date) - #f)) - (fdweek-day (date-week-day first-day))) - (modulo (- day-of-week-starting-week fdweek-day) - 7))) - -(define (date-week-number date day-of-week-starting-week) - (quotient (- (date-year-day date) - (priv:days-before-first-week date day-of-week-starting-week)) - 7)) - -(define (current-date . tz-offset) - (time-utc->date - (current-time time-utc) - (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) - -;; given a 'two digit' number, find the year within 50 years +/- -(define (priv:natural-year n) - (let* ((current-year (date-year (current-date))) - (current-century (* (quotient current-year 100) 100))) - (cond - ((>= n 100) n) - ((< n 0) n) - ((<= (- (+ current-century n) current-year) 50) (+ current-century n)) - (else (+ (- current-century 100) n))))) - -(define (date->julian-day date) - (let ((nanosecond (date-nanosecond date)) - (second (date-second date)) - (minute (date-minute date)) - (hour (date-hour date)) - (day (date-day date)) - (month (date-month date)) - (year (date-year date))) - (+ (priv:encode-julian-day-number day month year) - (- 1/2) - (+ (/ (+ (* hour 60 60) - (* minute 60) - second - (/ nanosecond priv:nano)) - priv:sid))))) - -(define (date->modified-julian-day date) - (- (date->julian-day date) - 4800001/2)) - -(define (time-utc->julian-day time) - (if (not (eq? (time-type time) time-utc)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (+ (/ (+ (time-second time) (/ (time-nanosecond time) priv:nano)) - priv:sid) - priv:tai-epoch-in-jd)) - -(define (time-utc->modified-julian-day time) - (- (time-utc->julian-day time) - 4800001/2)) - -(define (time-tai->julian-day time) - (if (not (eq? (time-type time) time-tai)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (+ (/ (+ (- (time-second time) - (priv:leap-second-delta (time-second time))) - (/ (time-nanosecond time) priv:nano)) - priv:sid) - priv:tai-epoch-in-jd)) - -(define (time-tai->modified-julian-day time) - (- (time-tai->julian-day time) - 4800001/2)) - -;; this is the same as time-tai->julian-day -(define (time-monotonic->julian-day time) - (if (not (eq? (time-type time) time-monotonic)) - (priv:time-error 'time->date 'incompatible-time-types time)) - (+ (/ (+ (- (time-second time) - (priv:leap-second-delta (time-second time))) - (/ (time-nanosecond time) priv:nano)) - priv:sid) - priv:tai-epoch-in-jd)) - -(define (time-monotonic->modified-julian-day time) - (- (time-monotonic->julian-day time) - 4800001/2)) - -(define (julian-day->time-utc jdn) - (let ((secs (* priv:sid (- jdn priv:tai-epoch-in-jd)))) - (receive (seconds parts) - (priv:split-real secs) - (make-time time-utc - (inexact->exact (truncate (* parts priv:nano))) - (inexact->exact 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 ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) - (time-utc->date (julian-day->time-utc jdn) offset))) - -(define (modified-julian-day->date jdn . tz-offset) - (let ((offset (if (null? tz-offset) (priv:local-tz-offset) (car tz-offset)))) - (julian-day->date (+ jdn 4800001/2) offset))) - -(define (modified-julian-day->time-utc jdn) - (julian-day->time-utc (+ jdn 4800001/2))) - -(define (modified-julian-day->time-tai jdn) - (julian-day->time-tai (+ jdn 4800001/2))) - -(define (modified-julian-day->time-monotonic jdn) - (julian-day->time-monotonic (+ jdn 4800001/2))) - -(define (current-julian-day) - (time-utc->julian-day (current-time time-utc))) - -(define (current-modified-julian-day) - (time-utc->modified-julian-day (current-time time-utc))) - -;; returns a string rep. of number N, of minimum LENGTH, padded with -;; character PAD-WITH. If PAD-WITH is #f, no padding is done, and it's -;; as if number->string was used. if string is longer than or equal -;; in length to LENGTH, it's as if number->string was used. - -(define (priv:padding n pad-with length) - (let* ((str (number->string n)) - (str-len (string-length str))) - (if (or (>= str-len length) - (not pad-with)) - str - (string-append (make-string (- length str-len) pad-with) str)))) - -(define (priv:last-n-digits i n) - (abs (remainder i (expt 10 n)))) - -(define (priv:locale-abbr-weekday n) - (vector-ref priv:locale-abbr-weekday-vector n)) - -(define (priv:locale-long-weekday n) - (vector-ref priv:locale-long-weekday-vector n)) - -(define (priv:locale-abbr-month n) - (vector-ref priv:locale-abbr-month-vector n)) - -(define (priv:locale-long-month n) - (vector-ref priv:locale-long-month-vector n)) - -(define (priv:vector-find needle haystack comparator) - (let ((len (vector-length haystack))) - (define (priv:vector-find-int index) - (cond - ((>= index len) #f) - ((comparator needle (vector-ref haystack index)) index) - (else (priv:vector-find-int (+ index 1))))) - (priv:vector-find-int 0))) - -(define (priv:locale-abbr-weekday->index string) - (priv:vector-find string priv:locale-abbr-weekday-vector string=?)) - -(define (priv:locale-long-weekday->index string) - (priv:vector-find string priv:locale-long-weekday-vector string=?)) - -(define (priv:locale-abbr-month->index string) - (priv:vector-find string priv:locale-abbr-month-vector string=?)) - -(define (priv:locale-long-month->index string) - (priv:vector-find string priv:locale-long-month-vector string=?)) - - - -;; do nothing. -;; Your implementation might want to do something... -;; -;; FIXME: is it even possible to do anything reasonable here? -(define (priv:locale-print-time-zone date port) - (values)) - -;; FIXME: we should use strftime to determine this dynamically if possible. -;; Again, locale specific. -(define (priv:locale-am/pm hr) - (if (> hr 11) priv:locale-pm priv:locale-am)) - -(define (priv:tz-printer offset port) - (cond - ((= offset 0) (display "Z" port)) - ((negative? offset) (display "-" port)) - (else (display "+" port))) - (if (not (= offset 0)) - (let ((hours (abs (quotient offset (* 60 60)))) - (minutes (abs (quotient (remainder offset (* 60 60)) 60)))) - (display (priv:padding hours #\0 2) port) - (display (priv:padding minutes #\0 2) port)))) - -;; STOPPED-HERE - -;; A table of output formatting directives. -;; the first time is the format char. -;; the second is a procedure that takes the date, a padding character -;; (which might be #f), and the output port. -;; -(define priv:directives - (list - (cons #\~ (lambda (date pad-with port) - (display #\~ port))) - (cons #\a (lambda (date pad-with port) - (display (priv:locale-abbr-weekday (date-week-day date)) - port))) - (cons #\A (lambda (date pad-with port) - (display (priv:locale-long-weekday (date-week-day date)) - port))) - (cons #\b (lambda (date pad-with port) - (display (priv:locale-abbr-month (date-month date)) - port))) - (cons #\B (lambda (date pad-with port) - (display (priv:locale-long-month (date-month date)) - port))) - (cons #\c (lambda (date pad-with port) - (display (date->string date priv:locale-date-time-format) port))) - (cons #\d (lambda (date pad-with port) - (display (priv:padding (date-day date) - #\0 2) - port))) - (cons #\D (lambda (date pad-with port) - (display (date->string date "~m/~d/~y") port))) - (cons #\e (lambda (date pad-with port) - (display (priv:padding (date-day date) - #\Space 2) - port))) - (cons #\f (lambda (date pad-with port) - (if (> (date-nanosecond date) - priv:nano) - (display (priv:padding (+ (date-second date) 1) - pad-with 2) - port) - (display (priv:padding (date-second date) - pad-with 2) - port)) - (receive (i f) - (priv:split-real (/ - (date-nanosecond date) - priv:nano 1.0)) - (let* ((ns (number->string f)) - (le (string-length ns))) - (if (> le 2) - (begin - (display priv:locale-number-separator port) - (display (substring ns 2 le) port))))))) - (cons #\h (lambda (date pad-with port) - (display (date->string date "~b") port))) - (cons #\H (lambda (date pad-with port) - (display (priv:padding (date-hour date) - pad-with 2) - port))) - (cons #\I (lambda (date pad-with port) - (let ((hr (date-hour date))) - (if (> hr 12) - (display (priv:padding (- hr 12) - pad-with 2) - port) - (display (priv:padding hr - pad-with 2) - port))))) - (cons #\j (lambda (date pad-with port) - (display (priv:padding (date-year-day date) - pad-with 3) - port))) - (cons #\k (lambda (date pad-with port) - (display (priv:padding (date-hour date) - #\Space 2) - port))) - (cons #\l (lambda (date pad-with port) - (let ((hr (if (> (date-hour date) 12) - (- (date-hour date) 12) (date-hour date)))) - (display (priv:padding hr #\Space 2) - port)))) - (cons #\m (lambda (date pad-with port) - (display (priv:padding (date-month date) - pad-with 2) - port))) - (cons #\M (lambda (date pad-with port) - (display (priv:padding (date-minute date) - pad-with 2) - port))) - (cons #\n (lambda (date pad-with port) - (newline port))) - (cons #\N (lambda (date pad-with port) - (display (priv:padding (date-nanosecond date) - pad-with 7) - port))) - (cons #\p (lambda (date pad-with port) - (display (priv:locale-am/pm (date-hour date)) port))) - (cons #\r (lambda (date pad-with port) - (display (date->string date "~I:~M:~S ~p") port))) - (cons #\s (lambda (date pad-with port) - (display (time-second (date->time-utc date)) port))) - (cons #\S (lambda (date pad-with port) - (if (> (date-nanosecond date) - priv:nano) - (display (priv:padding (+ (date-second date) 1) - pad-with 2) - port) - (display (priv:padding (date-second date) - pad-with 2) - port)))) - (cons #\t (lambda (date pad-with port) - (display #\Tab port))) - (cons #\T (lambda (date pad-with port) - (display (date->string date "~H:~M:~S") port))) - (cons #\U (lambda (date pad-with port) - (if (> (priv:days-before-first-week date 0) 0) - (display (priv:padding (+ (date-week-number date 0) 1) - #\0 2) port) - (display (priv:padding (date-week-number date 0) - #\0 2) port)))) - (cons #\V (lambda (date pad-with port) - (display (priv:padding (date-week-number date 1) - #\0 2) port))) - (cons #\w (lambda (date pad-with port) - (display (date-week-day date) port))) - (cons #\x (lambda (date pad-with port) - (display (date->string date priv:locale-short-date-format) port))) - (cons #\X (lambda (date pad-with port) - (display (date->string date priv:locale-time-format) port))) - (cons #\W (lambda (date pad-with port) - (if (> (priv:days-before-first-week date 1) 0) - (display (priv:padding (+ (date-week-number date 1) 1) - #\0 2) port) - (display (priv:padding (date-week-number date 1) - #\0 2) port)))) - (cons #\y (lambda (date pad-with port) - (display (priv:padding (priv:last-n-digits - (date-year date) 2) - pad-with - 2) - port))) - (cons #\Y (lambda (date pad-with port) - (display (date-year date) port))) - (cons #\z (lambda (date pad-with port) - (priv:tz-printer (date-zone-offset date) port))) - (cons #\Z (lambda (date pad-with port) - (priv:locale-print-time-zone date port))) - (cons #\1 (lambda (date pad-with port) - (display (date->string date "~Y-~m-~d") port))) - (cons #\2 (lambda (date pad-with port) - (display (date->string date "~k:~M:~S~z") port))) - (cons #\3 (lambda (date pad-with port) - (display (date->string date "~k:~M:~S") port))) - (cons #\4 (lambda (date pad-with port) - (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port))) - (cons #\5 (lambda (date pad-with port) - (display (date->string date "~Y-~m-~dT~k:~M:~S") port))))) - - -(define (priv:get-formatter char) - (let ((associated (assoc char priv:directives))) - (if associated (cdr associated) #f))) - -(define (priv:date-printer date index format-string str-len port) - (if (>= index str-len) - (values) - (let ((current-char (string-ref format-string index))) - (if (not (char=? current-char #\~)) - (begin - (display current-char port) - (priv:date-printer date (+ index 1) format-string str-len port)) - (if (= (+ index 1) str-len) ; bad format string. - (priv:time-error 'priv:date-printer 'bad-date-format-string - format-string) - (let ((pad-char? (string-ref format-string (+ index 1)))) - (cond - ((char=? pad-char? #\-) - (if (= (+ index 2) str-len) ; bad format string. - (priv:time-error 'priv:date-printer - 'bad-date-format-string - format-string) - (let ((formatter (priv:get-formatter - (string-ref format-string - (+ index 2))))) - (if (not formatter) - (priv:time-error 'priv:date-printer - 'bad-date-format-string - format-string) - (begin - (formatter date #f port) - (priv:date-printer date - (+ index 3) - format-string - str-len - port)))))) - - ((char=? pad-char? #\_) - (if (= (+ index 2) str-len) ; bad format string. - (priv:time-error 'priv:date-printer - 'bad-date-format-string - format-string) - (let ((formatter (priv:get-formatter - (string-ref format-string - (+ index 2))))) - (if (not formatter) - (priv:time-error 'priv:date-printer - 'bad-date-format-string - format-string) - (begin - (formatter date #\Space port) - (priv:date-printer date - (+ index 3) - format-string - str-len - port)))))) - (else - (let ((formatter (priv:get-formatter - (string-ref format-string - (+ index 1))))) - (if (not formatter) - (priv:time-error 'priv:date-printer - 'bad-date-format-string - format-string) - (begin - (formatter date #\0 port) - (priv:date-printer date - (+ index 2) - format-string - str-len - port)))))))))))) - - -(define (date->string date format-string) - (call-with-output-string - (lambda (str-port) - (let ((fmt-str format-string)) - (if (not (and format-string (> (string-length format-string) 0))) - (set! fmt-str "~c")) - (priv:date-printer date 0 fmt-str (string-length fmt-str) str-port) - )))) - -(define (priv:char->int ch) - (case ch - ((#\0) 0) - ((#\1) 1) - ((#\2) 2) - ((#\3) 3) - ((#\4) 4) - ((#\5) 5) - ((#\6) 6) - ((#\7) 7) - ((#\8) 8) - ((#\9) 9) - (else (priv:time-error 'bad-date-template-string - (list "Non-integer character" ch i))))) - -;; read an integer upto n characters long on port; upto -> #f is any length -(define (priv:integer-reader upto port) - (let loop ((accum 0) (nchars 0)) - (let ((ch (peek-char port))) - (if (or (eof-object? ch) - (not (char-numeric? ch)) - (and upto (>= nchars upto))) - accum - (loop port - (+ (* accum 10) (priv:char->int (read-char port))) - (+ nchars 1)))))) - -(define (priv:make-integer-reader upto) - (lambda (port) - (priv:integer-reader upto port))) - -;; read *exactly* n characters and convert to integer; could be padded -(define (priv:integer-reader-exact n port) - (let ((padding-ok #t)) - (define (accum-int port accum nchars) - (let ((ch (peek-char port))) - (cond - ((>= nchars n) accum) - ((eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - "Premature ending to integer read.")) - ((char-numeric? ch) - (set! padding-ok #f) - (accum-int port - (+ (* accum 10) (priv:char->int (read-char port))) - (+ nchars 1))) - (padding-ok - (read-char port) ; consume padding - (accum-int port accum (+ nchars 1))) - (else ; padding where it shouldn't be - (priv:time-error 'string->date 'bad-date-template-string - "Non-numeric characters in integer read."))))) - (accum-int port 0 0))) - - -(define (priv:make-integer-exact-reader n) - (lambda (port) - (priv:integer-reader-exact n port))) - -(define (priv:zone-reader port) - (let ((offset 0) - (positive? #f)) - (let ((ch (read-char port))) - (if (eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone +/-" ch))) - (if (or (char=? ch #\Z) (char=? ch #\z)) - 0 - (begin - (cond - ((char=? ch #\+) (set! positive? #t)) - ((char=? ch #\-) (set! positive? #f)) - (else - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone +/-" ch)))) - (let ((ch (read-char port))) - (if (eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) - (set! offset (* (priv:char->int ch) - 10 60 60))) - (let ((ch (read-char port))) - (if (eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) - (set! offset (+ offset (* (priv:char->int ch) - 60 60)))) - (let ((ch (read-char port))) - (if (eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) - (set! offset (+ offset (* (priv:char->int ch) - 10 60)))) - (let ((ch (read-char port))) - (if (eof-object? ch) - (priv:time-error 'string->date 'bad-date-template-string - (list "Invalid time zone number" ch))) - (set! offset (+ offset (* (priv:char->int ch) - 60)))) - (if positive? offset (- offset))))))) - -;; looking at a char, read the char string, run thru indexer, return index -(define (priv:locale-reader port indexer) - - (define (read-char-string result) - (let ((ch (peek-char port))) - (if (char-alphabetic? ch) - (read-char-string (cons (read-char port) result)) - (list->string (reverse! result))))) - - (let* ((str (read-char-string '())) - (index (indexer str))) - (if index index (priv:time-error 'string->date - 'bad-date-template-string - (list "Invalid string for " indexer))))) - -(define (priv:make-locale-reader indexer) - (lambda (port) - (priv:locale-reader port indexer))) - -(define (priv:make-char-id-reader char) - (lambda (port) - (if (char=? char (read-char port)) - char - (priv:time-error 'string->date - 'bad-date-template-string - "Invalid character match.")))) - -;; A List of formatted read directives. -;; Each entry is a list. -;; 1. the character directive; -;; a procedure, which takes a character as input & returns -;; 2. #t as soon as a character on the input port is acceptable -;; for input, -;; 3. a port reader procedure that knows how to read the current port -;; for a value. Its one parameter is the port. -;; 4. a action procedure, that takes the value (from 3.) and some -;; object (here, always the date) and (probably) side-effects it. -;; In some cases (e.g., ~A) the action is to do nothing - -(define priv:read-directives - (let ((ireader4 (priv:make-integer-reader 4)) - (ireader2 (priv:make-integer-reader 2)) - (ireaderf (priv:make-integer-reader #f)) - (eireader2 (priv:make-integer-exact-reader 2)) - (eireader4 (priv:make-integer-exact-reader 4)) - (locale-reader-abbr-weekday (priv:make-locale-reader - priv:locale-abbr-weekday->index)) - (locale-reader-long-weekday (priv:make-locale-reader - priv:locale-long-weekday->index)) - (locale-reader-abbr-month (priv:make-locale-reader - priv:locale-abbr-month->index)) - (locale-reader-long-month (priv:make-locale-reader - priv:locale-long-month->index)) - (char-fail (lambda (ch) #t)) - (do-nothing (lambda (val object) (values)))) - - (list - (list #\~ char-fail (priv:make-char-id-reader #\~) do-nothing) - (list #\a char-alphabetic? locale-reader-abbr-weekday do-nothing) - (list #\A char-alphabetic? locale-reader-long-weekday do-nothing) - (list #\b char-alphabetic? locale-reader-abbr-month - (lambda (val object) - (priv:set-date-month! object val))) - (list #\B char-alphabetic? locale-reader-long-month - (lambda (val object) - (priv:set-date-month! object val))) - (list #\d char-numeric? ireader2 (lambda (val object) - (priv:set-date-day! - object val))) - (list #\e char-fail eireader2 (lambda (val object) - (priv:set-date-day! object val))) - (list #\h char-alphabetic? locale-reader-abbr-month - (lambda (val object) - (priv:set-date-month! object val))) - (list #\H char-numeric? ireader2 (lambda (val object) - (priv:set-date-hour! object val))) - (list #\k char-fail eireader2 (lambda (val object) - (priv:set-date-hour! object val))) - (list #\m char-numeric? ireader2 (lambda (val object) - (priv:set-date-month! object val))) - (list #\M char-numeric? ireader2 (lambda (val object) - (priv:set-date-minute! - object val))) - (list #\S char-numeric? ireader2 (lambda (val object) - (priv:set-date-second! object val))) - (list #\y char-fail eireader2 - (lambda (val object) - (priv:set-date-year! object (priv:natural-year val)))) - (list #\Y char-numeric? ireader4 (lambda (val object) - (priv:set-date-year! object val))) - (list #\z (lambda (c) - (or (char=? c #\Z) - (char=? c #\z) - (char=? c #\+) - (char=? c #\-))) - priv:zone-reader (lambda (val object) - (priv:set-date-zone-offset! object val)))))) - -(define (priv:string->date date index format-string str-len port template-string) - (define (skip-until port skipper) - (let ((ch (peek-char port))) - (if (eof-object? port) - (priv:time-error 'string->date 'bad-date-format-string template-string) - (if (not (skipper ch)) - (begin (read-char port) (skip-until port skipper)))))) - (if (>= index str-len) - (begin - (values)) - (let ((current-char (string-ref format-string index))) - (if (not (char=? current-char #\~)) - (let ((port-char (read-char port))) - (if (or (eof-object? port-char) - (not (char=? current-char port-char))) - (priv:time-error 'string->date - 'bad-date-format-string template-string)) - (priv:string->date date - (+ index 1) - format-string - str-len - port - template-string)) - ;; otherwise, it's an escape, we hope - (if (> (+ index 1) str-len) - (priv:time-error 'string->date - 'bad-date-format-string template-string) - (let* ((format-char (string-ref format-string (+ index 1))) - (format-info (assoc format-char priv:read-directives))) - (if (not format-info) - (priv:time-error 'string->date - 'bad-date-format-string template-string) - (begin - (let ((skipper (cadr format-info)) - (reader (caddr format-info)) - (actor (cadddr format-info))) - (skip-until port skipper) - (let ((val (reader port))) - (if (eof-object? val) - (priv:time-error 'string->date - 'bad-date-format-string - template-string) - (actor val date))) - (priv:string->date date - (+ index 2) - format-string - str-len - port - template-string)))))))))) - -(define (string->date input-string template-string) - (define (priv:date-ok? date) - (and (date-nanosecond date) - (date-second date) - (date-minute date) - (date-hour date) - (date-day date) - (date-month date) - (date-year date) - (date-zone-offset date))) - (let ((newdate (make-date 0 0 0 0 #f #f #f (priv:local-tz-offset)))) - (priv:string->date newdate - 0 - template-string - (string-length template-string) - (open-input-string input-string) - template-string) - (if (priv:date-ok? newdate) - newdate - (priv:time-error - 'string->date - 'bad-date-format-string - (list "Incomplete date read. " newdate template-string))))) diff --git a/lib/srfi/srfi-2.scm b/lib/srfi/srfi-2.scm deleted file mode 100644 index 35f27aa57d..0000000000 --- a/lib/srfi/srfi-2.scm +++ /dev/null @@ -1,62 +0,0 @@ -;;;; srfi-2.scm --- SRFI-2 procedures for Guile -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU General Public License as -;;;; published by the Free Software Foundation; either version 2, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -(define-module (srfi srfi-2)) - -(cond - - ((or (string=? "1.3.4" (version)) - (string=? "1.4" (substring (version) 0 3))) - (use-modules (ice-9 and-let*))) - - ((string=? "1.3" (version)) - (defmacro and-let* (vars . body) - - (define (expand vars body) - (cond - ((null? vars) - `(begin ,@body)) - ((pair? vars) - (let ((exp (car vars))) - (cond - ((pair? exp) - (cond - ((null? (cdr exp)) - `(and ,(car exp) ,(expand (cdr vars) body))) - (else - (let ((var (car exp)) - (val (cadr exp))) - `(let (,exp) - (and ,var ,(expand (cdr vars) body))))))) - (else - `(and ,exp ,(expand (cdr vars) body)))))) - (else - (error "not a proper list" vars)))) - - (expand vars body))) - - (else - (let ((msg - (string-append - "Loaded gnucash srfi-2.scm in unknown Guile version:" (version) ".\n" - "If you're running a Guile newer than 1.4, then this file should\n" - "not have been installed. Please report the bug."))) - (error msg)))) - -(export-syntax and-let*) diff --git a/lib/srfi/srfi-8.scm b/lib/srfi/srfi-8.scm deleted file mode 100644 index 53d7c3c6be..0000000000 --- a/lib/srfi/srfi-8.scm +++ /dev/null @@ -1,45 +0,0 @@ -;;;; srfi-8.scm --- SRFI-8 procedures for Guile - -;;; Copyright (C) 2000 Free Software Foundation, Inc. -;;; -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation; either version 2, or -;;; (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this software; see the file COPYING. If not, write to -;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;; Boston, MA 02111-1307 USA - -(define-module (srfi srfi-8)) - -(cond - ((or (string=? "1.3" (version)) - (string=? "1.3.4" (version)) - (string=? "1.4" (substring (version) 0 3))) - - (use-modules (ice-9 slib)) - (require 'macro-by-example) - (require 'values) - - (define-syntax receive - (syntax-rules () - ((receive formals expression body ...) - (call-with-values (lambda () expression) - (lambda formals body ...)))))) - - (else - (let ((msg - (string-append - "Loaded gnucash srfi-8.scm in unknown Guile version:" (version) ".\n" - "If you're running a Guile newer than 1.4, then this file should\n" - "not have been installed. Please report the bug."))) - (error msg)))) - -(export-syntax receive) diff --git a/lib/srfi/srfi-9.scm b/lib/srfi/srfi-9.scm deleted file mode 100644 index 7d24688921..0000000000 --- a/lib/srfi/srfi-9.scm +++ /dev/null @@ -1,89 +0,0 @@ -;;;; srfi-9.scm --- SRFI-9 procedures for Guile -;;;; -;;;; Copyright (C) 2001 Free Software Foundation, Inc. -;;;; -;;;; This program is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU General Public License as -;;;; published by the Free Software Foundation; either version 2, or -;;;; (at your option) any later version. -;;;; -;;;; This program is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;;; General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with this software; see the file COPYING. If not, write to -;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, -;;;; Boston, MA 02111-1307 USA - -;;; Commentary: - -;;; This module exports the syntactic form `define-record-type', which -;;; is the means for creating record types defined in SRFI-9. -;;; -;;; The syntax of a record type definition is: -;;; -;;; -;;; -> (define-record-type -;;; ( ...) -;;; -;;; ...) -;;; -;;; -> ( ) -;;; -> ( ) -;;; -;;; -> -;;; <... name> -> -;;; -;;; Usage example: -;;; -;;; guile> (use-modules (srfi srfi-9)) -;;; guile> (define-record-type :foo (make-foo x) foo? -;;; (x get-x) (y get-y set-y!)) -;;; guile> (define f (make-foo 1)) -;;; guile> f -;;; #<:foo x: 1 y: #f> -;;; guile> (get-x f) -;;; 1 -;;; guile> (set-y! f 2) -;;; 2 -;;; guile> (get-y f) -;;; 2 -;;; guile> f -;;; #<:foo x: 1 y: 2> -;;; guile> (foo? f) -;;; #t -;;; guile> (foo? 1) -;;; #f - -;;; Code: - -(define-module (srfi srfi-9)) - -(export-syntax define-record-type) - -(define-macro (define-record-type type-name constructor/field-tag - predicate-name . field-specs) - `(begin - (define ,type-name - (make-record-type ',type-name ',(map car field-specs))) - (define ,(car constructor/field-tag) - (record-constructor ,type-name ',(cdr constructor/field-tag))) - (define ,predicate-name - (record-predicate ,type-name)) - ,@(map - (lambda (spec) - (cond - ((= (length spec) 2) - `(define ,(cadr spec) - (record-accessor ,type-name ',(car spec)))) - ((= (length spec) 3) - `(begin - (define ,(cadr spec) - (record-accessor ,type-name ',(car spec))) - (define ,(caddr spec) - (record-modifier ,type-name ',(car spec))))) - (else - (error "invalid field spec " spec)))) - field-specs))) diff --git a/src/app-utils/test/Makefile.am b/src/app-utils/test/Makefile.am index 163d777c32..c8e10ff29d 100644 --- a/src/app-utils/test/Makefile.am +++ b/src/app-utils/test/Makefile.am @@ -14,8 +14,7 @@ test_print_parse_amount_SOURCES = \ ${top_builddir}/src/core-utils/gnc-gconf-utils.c \ test-print-parse-amount.c -GNC_TEST_DEPS = @GNC_TEST_SRFI_LOAD_CMD@ \ - --gnc-module-dir ${top_builddir}/src/engine \ +GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \ --gnc-module-dir ${top_builddir}/src/calculation \ --gnc-module-dir ${top_builddir}/src/app-utils \ --guile-load-dir ${top_builddir}/src/core-utils \ diff --git a/src/bin/overrides/Makefile.am b/src/bin/overrides/Makefile.am index b6b586d04f..2dca5361c9 100644 --- a/src/bin/overrides/Makefile.am +++ b/src/bin/overrides/Makefile.am @@ -43,7 +43,6 @@ CLEANFILES += gnucash-env gnucash-build-env: gnucash-build-env.in ${top_builddir}/config.status Makefile rm -f $@.tmp sed < $< > $@.tmp \ - -e 's#@-GNC_TEST_SRFI_LOAD_CMD-@#@GNC_TEST_SRFI_LOAD_CMD@#g' \ -e 's#@-GNC_BUILDDIR-@#${PWD}/${top_builddir}#g' \ -e 's#@-GNC_SRCDIR-@#${PWD}/${top_srcdir}#g' mv $@.tmp $@ diff --git a/src/engine/Makefile.am b/src/engine/Makefile.am index 208f57ab61..74d305e640 100644 --- a/src/engine/Makefile.am +++ b/src/engine/Makefile.am @@ -166,7 +166,7 @@ endif iso-4217-currencies.c: iso-4217-currencies.scm iso-currencies-to-c -chmod u+x ${srcdir}/iso-currencies-to-c - GUILE_LOAD_PATH=@GNC_SRFI_LOAD_PATH@:${GUILE_LOAD_PATH} srcdir=${srcdir} ${srcdir}/iso-currencies-to-c + srcdir=${srcdir} ${srcdir}/iso-currencies-to-c BUILT_SOURCES = iso-4217-currencies.c diff --git a/src/gnome-utils/test/Makefile.am b/src/gnome-utils/test/Makefile.am index 8e1cd3dba4..579f316f50 100644 --- a/src/gnome-utils/test/Makefile.am +++ b/src/gnome-utils/test/Makefile.am @@ -8,8 +8,7 @@ TESTS_GUI = test-gnc-recurrence test-gnc-dialog ##lib_LTLIBRARIES = libgncgnome.la -GNC_TEST_DEPS = @GNC_TEST_SRFI_LOAD_CMD@ \ - --gnc-module-dir ${top_builddir}/src/engine \ +GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \ --gnc-module-dir ${top_builddir}/src/gnome-utils \ --guile-load-dir ${top_builddir}/src/gnc-module \ --guile-load-dir ${top_builddir}/src/engine \ diff --git a/src/import-export/qif/test/Makefile.am b/src/import-export/qif/test/Makefile.am index 9c43a43e55..6057c0e083 100644 --- a/src/import-export/qif/test/Makefile.am +++ b/src/import-export/qif/test/Makefile.am @@ -22,8 +22,7 @@ TESTS = \ test-link \ test-qif -GNC_TEST_DEPS = @GNC_TEST_SRFI_LOAD_CMD@ \ - --gnc-module-dir ${top_builddir}/src/core-utils \ +GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/core-utils \ --gnc-module-dir ${top_builddir}/src/gnc-module \ --gnc-module-dir ${top_builddir}/src/engine \ --gnc-module-dir ${top_builddir}/src/app-utils \ diff --git a/src/import-export/test/Makefile.am b/src/import-export/test/Makefile.am index b104864c43..f33b349ae0 100644 --- a/src/import-export/test/Makefile.am +++ b/src/import-export/test/Makefile.am @@ -22,8 +22,7 @@ TESTS = \ test-link \ test-import-parse -GNC_TEST_DEPS = @GNC_TEST_SRFI_LOAD_CMD@ \ - --gnc-module-dir ${top_builddir}/src/engine \ +GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \ --gnc-module-dir ${top_builddir}/src/import-export \ --guile-load-dir ${top_builddir}/src/engine \ --library-dir ${top_builddir}/lib/libqof/qof \ diff --git a/src/report/locale-specific/us/test/Makefile.am b/src/report/locale-specific/us/test/Makefile.am index 080c79fa92..19a9b87ad6 100644 --- a/src/report/locale-specific/us/test/Makefile.am +++ b/src/report/locale-specific/us/test/Makefile.am @@ -1,7 +1,6 @@ TESTS = test-link-module -GNC_TEST_DEPS = @GNC_TEST_SRFI_LOAD_CMD@ \ - --gnc-module-dir ${top_builddir}/src/engine \ +GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \ --gnc-module-dir ${top_builddir}/src/tax/us \ --gnc-module-dir ${top_builddir}/src/report/report-system \ --gnc-module-dir ${top_builddir}/src/report/locale-specific/us \ diff --git a/src/report/report-gnome/test/Makefile.am b/src/report/report-gnome/test/Makefile.am index 4facda9963..63d92f5825 100644 --- a/src/report/report-gnome/test/Makefile.am +++ b/src/report/report-gnome/test/Makefile.am @@ -2,8 +2,7 @@ TESTS = \ test-link-module \ test-load-module -GNC_TEST_DEPS = @GNC_TEST_SRFI_LOAD_CMD@ \ - --gnc-module-dir ${top_builddir}/src/engine \ +GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \ --gnc-module-dir ${top_builddir}/src/app-utils \ --gnc-module-dir ${top_builddir}/src/report/report-gnome \ --guile-load-dir ${top_builddir}/src/gnc-module \ diff --git a/src/report/report-system/test/Makefile.am b/src/report/report-system/test/Makefile.am index 13c70798bf..a900d2a94a 100644 --- a/src/report/report-system/test/Makefile.am +++ b/src/report/report-system/test/Makefile.am @@ -2,8 +2,7 @@ TESTS = \ test-link-module \ test-load-module -GNC_TEST_DEPS = @GNC_TEST_SRFI_LOAD_CMD@ \ - --gnc-module-dir ${top_builddir}/src/engine \ +GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \ --gnc-module-dir ${top_builddir}/src/report/report-system \ --guile-load-dir ${top_builddir}/src/gnc-module \ --guile-load-dir ${top_builddir}/src/engine \ diff --git a/src/report/standard-reports/test/Makefile.am b/src/report/standard-reports/test/Makefile.am index e80cf53b0c..8836c551da 100644 --- a/src/report/standard-reports/test/Makefile.am +++ b/src/report/standard-reports/test/Makefile.am @@ -1,7 +1,6 @@ TESTS=test-load-module -GNC_TEST_DEPS = @GNC_TEST_SRFI_LOAD_CMD@ \ - --gnc-module-dir ${top_builddir}/src/engine \ +GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \ --gnc-module-dir ${top_builddir}/src/report/report-system \ --gnc-module-dir ${top_builddir}/src/report/standard-reports \ --guile-load-dir ${top_builddir}/src/gnc-module \ diff --git a/src/report/stylesheets/test/Makefile.am b/src/report/stylesheets/test/Makefile.am index 1b671fbfbc..aeec3e67f2 100644 --- a/src/report/stylesheets/test/Makefile.am +++ b/src/report/stylesheets/test/Makefile.am @@ -1,7 +1,6 @@ TESTS=test-load-module -GNC_TEST_DEPS = @GNC_TEST_SRFI_LOAD_CMD@ \ - --gnc-module-dir ${top_builddir}/src/engine \ +GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \ --gnc-module-dir ${top_builddir}/src/report/report-system \ --gnc-module-dir ${top_builddir}/src/report/stylesheets \ --guile-load-dir ${top_builddir}/src/gnc-module \ diff --git a/src/report/utility-reports/test/Makefile.am b/src/report/utility-reports/test/Makefile.am index d8ec3a5de8..bc26f40658 100644 --- a/src/report/utility-reports/test/Makefile.am +++ b/src/report/utility-reports/test/Makefile.am @@ -1,7 +1,6 @@ TESTS = test-load-module -GNC_TEST_DEPS = @GNC_TEST_SRFI_LOAD_CMD@ \ - --gnc-module-dir ${top_builddir}/src/engine \ +GNC_TEST_DEPS = --gnc-module-dir ${top_builddir}/src/engine \ --gnc-module-dir ${top_builddir}/src/report/report-system \ --gnc-module-dir ${top_builddir}/src/report/utility-reports \ --guile-load-dir ${top_builddir}/src/gnc-module \