pax_global_header00006660000000000000000000000064137515420660014523gustar00rootroot0000000000000052 comment=89f01ee0e9d5da8554e2fe8c2fa6ead0874f02ab chez-srfi-0.0+git20201107.bac6f29+dfsg/000077500000000000000000000000001375154206600167225ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a0.sls000066400000000000000000000002311375154206600200710ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :0) (export cond-expand) (import (srfi :0 cond-expand)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a0/000077500000000000000000000000001375154206600173525ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a0/cond-expand.guile.sls000066400000000000000000000001251375154206600233770ustar00rootroot00000000000000(library (srfi srfi-0) (export cond-expand) (import (only (guile) cond-expand))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a0/cond-expand.sls000066400000000000000000000030171375154206600222760ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :0 cond-expand) (export cond-expand) (import (rnrs) (for (only (srfi private registry) expand-time-features) expand)) (define-syntax cond-expand (lambda (stx) (syntax-case stx (and or not else) ((_) (syntax-violation #F "unfulfilled cond-expand" stx)) ((_ (else body ...)) #'(begin body ...)) ((_ ((and) body ...) more-clauses ...) #'(begin body ...)) ((_ ((and req1 req2 ...) body ...) more-clauses ...) #'(cond-expand (req1 (cond-expand ((and req2 ...) body ...) more-clauses ...)) more-clauses ...)) ((_ ((or) body ...) more-clauses ...) #'(cond-expand more-clauses ...)) ((_ ((or req1 req2 ...) body ...) more-clauses ...) #'(cond-expand (req1 (begin body ...)) (else (cond-expand ((or req2 ...) body ...) more-clauses ...)))) ((_ ((not req) body ...) more-clauses ...) #'(cond-expand (req (cond-expand more-clauses ...)) (else body ...))) ((_ (feature-id body ...) more-clauses ...) (if (member (syntax->datum #'feature-id) expand-time-features) #'(begin body ...) #'(cond-expand more-clauses ...)))))) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a1.sls000066400000000000000000000037521375154206600201050ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :1) (export alist-cons alist-copy alist-delete alist-delete! any append append! append-map append-map! append-reverse append-reverse! assoc assq assv break break! caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr car car+cdr cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr circular-list circular-list? concatenate concatenate! cons cons* count delete delete! delete-duplicates delete-duplicates! dotted-list? drop drop-right drop-right! drop-while eighth every fifth filter filter! filter-map find find-tail first fold fold-right for-each fourth iota last last-pair length length+ list list-copy list-index list-ref list-tabulate list= lset-adjoin lset-diff+intersection lset-diff+intersection! lset-difference lset-difference! lset-intersection lset-intersection! lset-union lset-union! lset-xor lset-xor! lset<= lset= make-list map map! map-in-order member memq memv ninth not-pair? null-list? null? pair-fold pair-fold-right pair-for-each pair? partition partition! proper-list? reduce reduce-right remove remove! reverse reverse! second set-car! set-cdr! seventh sixth span span! split-at split-at! take take! take-right take-while take-while! tenth third unfold unfold-right unzip1 unzip2 unzip3 unzip4 unzip5 xcons zip) (import (srfi :1 lists)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a1/000077500000000000000000000000001375154206600173535ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a1/lists.sls000066400000000000000000000043731375154206600212430ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :1 lists) (export ;;; Exported: xcons #;tree-copy make-list list-tabulate 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 pair-fold-right reduce-right append-map append-map! map! pair-for-each filter-map map-in-order filter! partition! remove! find-tail any every list-index 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! ;; re-exported: append assq assv caaaar caaadr caaar caadar caaddr caadr caar cadaar cadadr cadar caddar cadddr caddr cadr car cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar cddadr cddar cdddar cddddr cdddr cddr cdr cons cons* length list list-ref memq memv null? pair? reverse set-car! set-cdr! ;; different than R6RS: assoc filter find fold-right for-each map member partition remove) (import (rename (except (rnrs) find filter fold-right map partition remove) (assoc r6rs:assoc) (for-each r6rs:for-each) (member r6rs:member)) (rnrs mutable-pairs) (srfi :8 receive) (srfi :23 error tricks) (for (srfi private vanish) expand) (srfi private check-arg) (srfi private include)) (let-syntax ((define (vanish-define define (cons*)))) (SRFI-23-error->R6RS "(library (srfi :1 lists))" (include/resolve ("srfi" "%3a1") "srfi-1-reference.scm"))) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a1/srfi-1-reference.scm000066400000000000000000002426101375154206600231210ustar00rootroot00000000000000;;; 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 ;;; Copyright (c) Jéssica Milaré, 2018. 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 ;;; 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. ;;; 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 (case-lambda ((len) (make-list len #f)) ((len elt) (check-arg index? len make-list) (do ((i len (fx- i 1)) (ans '() (cons elt ans))) ((fx<=? 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) (check-arg index? len list-tabulate) (check-arg procedure? proc list-tabulate) (do ((i (fx- len 1) (fx- i 1)) (ans '() (cons (proc i) ans))) ((fx ::= () ; 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 (error "null-list?: argument out of domain" l)))) (define list= (case-lambda ((elt=) #t) ((elt= list-a) #t) ((elt= list-a list-b) (or (eq? list-a list-b) (let loop ((list-a list-a) (list-b list-b)) (if (null-list? list-a) (null-list? list-b) (and (not (null-list? list-b)) (elt= (car list-a) (car list-b)) (loop (cdr list-a) (cdr list-b))))))) ((elt= list-a list-b list-c . lists) (and (list= elt= list-a list-b) (list= elt= list-b list-c) (or (null? lists) (let loop ((list-a list-c) (lists lists)) (let ((list-b (car lists)) (others (cdr lists))) (and (list= elt= list-a list-b) (or (null? others) (loop list-b others)))))))))) ;;; 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. ;; Try 21 times before checking for cicularities (let loop ((x x) (len 0)) (if (null? x) len (if (fx>? len 20) ;; Tried 20 times, begin checking for circularities (let lp ((x (cdr x)) (lag x) (len (fx+ len 1))) (if (pair? x) (let ((x (cdr x)) (len (fx+ len 1))) (if (pair? x) (let ((x (cdr x)) (lag (cdr lag)) (len (fx+ len 1))) (and (not (eq? x lag)) (lp x lag len))) len)) len)) ;; Still not 20 times (loop (cdr x) (fx+ len 1)))))) (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) (check-arg fixnum? k take) (let recur ((lis lis) (k k)) (if (zero? k) '() (cons (car lis) (recur (cdr lis) (- k 1)))))) (define (drop lis k) (check-arg fixnum? k drop) (let iter ((lis lis) (k k)) (if (zero? k) lis (iter (cdr lis) (- k 1))))) (define (take! lis k) (check-arg fixnum? 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) (check-arg fixnum? 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) (check-arg fixnum? 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) (check-arg fixnum? 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) ; (check-arg fixnum? 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) ; (check-arg fixnum? 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) ; (check-arg fixnum? 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) ; (check-arg fixnum? 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) (check-arg fixnum? 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) (check-arg fixnum? 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) (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! (case-lambda (() '()) ;; Fast path 1 ((lis1) lis1) ;; Fast path 2 ((lis1 lis2) (cond ((null? lis2) lis1) ((null? lis1) lis2) (else (set-cdr! (last-pair lis1) lis2) lis1))) ;; N-ary case ((lis1 lis2 lis3 . lists) (let ((append-2! (lambda (lis1 lis2) (set-cdr! (last-pair lis1) lis2) lis1)) (lists (delete '() lists))) (if (null? lists) (if (null? lis3) (append! lis1 lis2) (let* ((lis (if (null? lis2) lis3 (append-2! lis2 lis3))) (lis (if (null? lis1) lis (append-2! lis1 lis)))) lis)) (let* ((lis (let loop ((lis (car lists)) (lists (cdr lists))) (if (null? lists) lis (append-2! lis (loop (car lists) (cdr lists)))))) (lis (if (null? lis3) lis (append-2! lis3 lis))) (lis (if (null? lis2) lis (append-2! lis2 lis))) (lis (if (null? lis1) lis (append-2! lis1 lis)))) lis)))))) ;;; 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. ;;; ;;; 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) (let f ((ls lists)) (if (pair? ls) (let ((x (car ls))) (if (null? x) '() (cons (cdr x) (f (cdr ls))))) '()))) (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) (let f ((ls lists)) (if (pair? ls) (let ((x (car ls))) (if (null-list? x) (values '() '()) (receive (cars cdrs) (f (cdr ls)) (values (cons (car x) cars) (cons (cdr x) 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) (let f ((ls lists)) (if (pair? ls) (let ((x (car ls))) (if (null-list? x) (values '() '()) (receive (cars cdrs) (f (cdr ls)) (values (cons (car x) cars) (cons (cdr x) 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 (case-lambda ;; Fast path ((pred list1) (check-arg procedure? pred count) (let lp ((lis list1) (i 0)) (if (null-list? lis) i (lp (cdr lis) (if (pred (car lis)) (fx+ i 1) i))))) ;; N-ary case ((pred list1 . lists) (check-arg procedure? pred count) (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) (fx+ i 1) i))))))))) ;;; fold/unfold ;;;;;;;;;;;;;;; (define unfold-right (case-lambda ((p f g seed) (unfold-right p f g seed '())) ((p f g seed tail) (check-arg procedure? p unfold-right) (check-arg procedure? f unfold-right) (check-arg procedure? g unfold-right) (let lp ((seed seed) (ans tail)) (if (p seed) ans (lp (g seed) (cons (f seed) ans))))))) (define unfold (case-lambda ((p f g seed) (check-arg procedure? p unfold) (check-arg procedure? f unfold) (check-arg procedure? g unfold) (let recur ((seed seed)) (if (p seed) '() (cons (f seed) (recur (g seed)))))) ((p f g seed tail-gen) (check-arg procedure? p unfold) (check-arg procedure? f unfold) (check-arg procedure? g unfold) (let recur ((seed seed)) (if (p seed) (tail-gen seed) (cons (f seed) (recur (g seed)))))))) (define fold (case-lambda ;; Fast path 1 ((kons knil lis1) (check-arg procedure? kons fold) (let lp ((lis lis1) (ans knil)) (if (null-list? lis) ans (lp (cdr lis) (kons (car lis) ans))))) ;; Fast path 2 ((kons knil lis1 lis2) (check-arg procedure? kons fold) (let lp ((lis1 lis1) (lis2 lis2) (ans knil)) (if (or (null-list? lis1) (null-list? lis2)) ans (lp (cdr lis1) (cdr lis2) (kons (car lis1) (car lis2) ans))))) ;; N-ary case ((kons knil lis1 lis2 lis3 . lists) (check-arg procedure? kons fold) (let lp ((lis1 lis1) (lis2 lis2) (lis3 lis3) (lists lists) (ans knil)) (if (or (null-list? lis1) (null-list? lis2) (null-list? lis3)) (receive (cars+ans cdrs) (%cars+cdrs+ lists ans) (if (null? cars+ans) ans (lp (cdr lis1) (cdr lis2) (cdr lis3) cdrs (apply kons (car lis1) (car lis2) (car lis3) cars+ans))))))))) (define fold-right (case-lambda ;; Fast path 1 ((kons knil lis1) (check-arg procedure? kons fold-right) (let recur ((lis lis1)) (if (null-list? lis) knil (kons (car lis1) (recur (cdr lis)))))) ;; Fast path 2 ((kons knil lis1 lis2) (check-arg procedure? kons fold-right) (let recur ((lis1 lis1) (lis2 lis2)) (if (or (null-list? lis1) (null-list? lis2)) knil (kons (car lis1) (car lis2) (recur (cdr lis1) (cdr lis2)))))) ;; N-ary case ((kons knil lis1 lis2 lis3 . lists) (check-arg procedure? kons fold-right) (let recur ((lis1 lis1) (lis2 lis2) (lis3 lis3) (lists lists)) (if (or (null-list? lis1) (null-list? lis2) (null-list? lis3)) knil (let ((cdrs (%cdrs lists))) (if (null? cdrs) knil (apply kons (car lis1) (car lis2) (car lis3) (%cars+ lists (recur (cdr lis1) (cdr lis2) (cdr lis3) cdrs)))))))))) (define pair-fold-right (case-lambda ;; Fast path ((f zero lis1) (check-arg procedure? f pair-fold-right) (let recur ((lis lis1)) (if (null-list? lis) zero (f lis (recur (cdr lis)))))) ;; N-ary case ((f zero lis1 lis2 . lists) (check-arg procedure? f pair-fold-right) (let recur ((lis1 lis1) (lis2 lis2) (lists lists)) (if (or (null-list? lis1) (null-list? lis2)) zero (let ((cdrs (%cdrs lists))) (if (null? cdrs) zero (apply f lis1 lis2 (append! lists (list (recur (cdr lis1) (cdr lis2) cdrs))))))))))) (define pair-fold (case-lambda ;; Fast path ((f zero lis1) (check-arg procedure? f pair-fold) (let lp ((lis lis1) (ans zero)) (if (null? lis) ans (let ((tail (cdr lis))) ; Grab the cdr now, (lp tail (f lis ans)))))) ;; N-ary case ((f zero lis1 lis2 . lists) (check-arg procedure? f pair-fold) (let lp ((lis1 lis1) (lis2 lis2) (lists lists) (ans zero)) (if (or (null-list? lis1) (null-list? lis2)) ans (let ((tails (%cdrs lists))) (if (null? tails) ans (lp (cdr lis1) (cdr lis2) tails (apply f lis1 lis2 (append! lists (list ans))))))))))) ;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case. ;;; These cannot meaningfully be n-ary. (define (reduce f ridentity lis) (check-arg procedure? f reduce) (if (null-list? lis) ridentity (fold f (car lis) (cdr lis)))) (define (reduce-right f ridentity lis) (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 (case-lambda ((f lis1) (really-append-map append-map append f lis1)) ((f lis1 lis2) (really-append-map append-map append f lis1 lis2)) ((f lis1 lis2 . lists) (really-append-map append-map append f lis1 lis2 lists)))) (define append-map! (case-lambda ((f lis1) (really-append-map append-map! append! f lis1)) ((f lis1 lis2) (really-append-map append-map! append! f lis1 lis2)) ((f lis1 lis2 . lists) (really-append-map append-map! append! f lis1 lis2 lists)))) (define really-append-map (case-lambda ;; Fast path 1 ((who appender f lis1) (check-arg procedure? f who) (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)))))))) ;; Fast path 2 ((who appender f lis1 lis2) (check-arg procedure? f who) (if (or (null-list? lis1) (null-list? lis2)) '() (let recur ((lis1 lis1) (lis2 lis2)) (let ((vals (f (car lis1) (car lis2))) (lis1 (cdr lis1)) (lis2 (cdr lis2))) (if (or (null-list? lis1) (null-list? lis2)) vals (appender vals (recur lis1 lis2))))))) ;; N-ary case ((who appender f lis1 lis2 lists) (check-arg procedure? f who) (if (or (null-list? lis1) (null-list? lis2)) '() (receive (cars cdrs) (%cars+cdrs lists) (if (null? cars) '() (let recur ((lis1 lis1) (lis2 lis2) (cars cars) (cdrs cdrs)) (let ((vals (apply f (car lis1) (car lis2) cars)) (lis1 (cdr lis1)) (lis2 (cdr lis2))) (if (or (null-list? lis1) (null-list? lis2)) vals (receive (cars2 cdrs2) (%cars+cdrs cdrs) (if (null? cars2) vals (appender vals (recur lis1 lis2 cars2 cdrs2))))))))))))) (define pair-for-each (case-lambda ;; Fast path ((proc lis1) (check-arg procedure? proc pair-for-each) (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))))) ;; N-ary case ((proc lis1 lis2 . lists) (check-arg procedure? proc pair-for-each) (let lp ((lis1 lis1) (lis2 lis2) (lists lists)) (if (and (pair? lis1) (pair? lis2)) (let ((tails (%cdrs lists))) (if (pair? tails) (begin (apply proc lis1 lis2 lists) (lp (cdr lis1) (cdr lis2) tails))))))))) ;;; We stop when LIS1 runs out, not when any list runs out. (define map! (case-lambda ;; Fast path 1 ((f lis1) (check-arg procedure? f map!) (let lp ((lis1 lis1)) (when (not (null-list? lis1)) (set-car! lis1 (f (car lis1))) (lp (cdr lis1)))) lis1) ;; Fast path 2 ((f lis1 lis2) (check-arg procedure? f map!) (let lp ((lis1 lis1) (lis2 lis2)) (when (not (null-list? lis1)) (set-car! lis1 (f (car lis1) (car lis2))) (lp (cdr lis1) (cdr lis2)))) lis1) ;; N-ary case ((f lis1 lis2 lis3 . lists) (check-arg procedure? f map!) (let lp ((lis1 lis1) (lis2 lis2) (lis3 lis3) (lists lists)) (when (not (null-list? lis1)) (receive (heads tails) (%cars+cdrs/no-test lists) (set-car! lis1 (apply f (car lis1) (car lis2) (car lis3) heads)) (lp (cdr lis1) (cdr lis2) (cdr lis3) tails)))) lis1))) ;;; Map F across L, and save up all the non-false results. (define filter-map (case-lambda ((f lis1) (check-arg procedure? f filter-map) (let recur ((lis lis1)) (if (null-list? lis) '() (let ((tail (recur (cdr lis)))) (cond ((f (car lis)) => (lambda (x) (cons x tail))) (else tail)))))) ((f lis1 . lists) (check-arg procedure? f filter-map) (let recur ((lis1 lis1) (lists lists)) (if (null-list? lis1) '() (receive (cars cdrs) (%cars+cdrs lists) (if (pair? cars) (cond ((apply f (car lis1) cars) => (lambda (x) (cons x (recur (cdr lis1) cdrs)))) (else (recur (cdr lis1) cdrs))) ; Tail call in this arm. '()))))))) ;;; 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 (case-lambda ((f lis1) (check-arg procedure? f map-in-order) (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 ((f lis1 lis2) (check-arg procedure? f map-in-order) (let recur ((lis1 lis1) (lis2 lis2)) (if (and (pair? lis1) (pair? lis2)) (let ((x (f (car lis1) (car lis2)))) ; Do head first, (cons x (recur (cdr lis1) (cdr lis2)))) ; then tail. '()))) ((f lis1 lis2 . lists) (check-arg procedure? f map-in-order) (let recur ((lis1 lis1) (lis2 lis2) (lists lists)) (receive (cars cdrs) (%cars+cdrs lists) (if (and (pair? lis1) (pair? lis2) (pair? cars)) (let ((x (apply f (car lis1) (car lis2) cars))) ; Do head first, (cons x (recur (cdr lis1) (cdr lis2) cdrs))) ; then tail. '())))))) ;;; We extend MAP to handle arguments of unequal length. (define map map-in-order) ;;; Contributed by Michael Sperber since it was missing from the ;;; reference implementation. (define for-each (case-lambda ;; Fast path 1 ((f lis1) (r6rs:for-each f lis1)) ;; Fast path 2 ((f lis1 lis2) (check-arg procedure? f for-each) (let recur ((lis1 lis1) (lis2 lis2)) (unless (or (null-list? lis1) (null-list? lis2)) (f (car lis1) (car lis2)) (recur (cdr lis1) (cdr lis2))))) ;; N-ary case ((f lis1 lis2 . lists) (check-arg procedure? f for-each) (let recur ((lis1 lis1) (lis2 lis2) (lists lists)) (unless (or (null-list? lis1) (null-list? lis2)) (receive (cars cdrs) (%cars+cdrs lists) (when (pair? cars) (apply f (car lis1) (car lis2) cars) ; Do head first, (recur (cdr lis1) (cdr lis2) cdrs)))))))) ; then tail. ;;; 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 (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) (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) (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) (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))))))))) ;; (define (remove pred l) (filter (lambda (x) (not (pred x))) l)) ;; (define (remove! pred l) (filter! (lambda (x) (not (pred x))) l)) ;; Avoid allocating a procedure ;; Just a copy of filter with (pred head) <-> (not (pred head)) (define (remove pred lis) (check-arg procedure? pred remove) (let recur ((lis lis)) (if (null-list? lis) lis (let ((head (car lis)) (tail (cdr lis))) (if (not (pred head)) (let ((new-tail (recur tail))) (if (eq? tail new-tail) lis (cons head new-tail))) (recur tail)))))) ;; Avoid allocating a procedure ;; Just a copy of filter! with (pred head) <-> (not (pred head)) (define (remove! pred lis) (check-arg procedure? pred remove!) (let lp ((ans lis)) (cond ((null-list? ans) ans) ; Scan looking for ((pred (car ans)) (lp (cdr ans))) ; first cons of result. (else (letrec ((scan-in (lambda (prev lis) (if (pair? lis) (if (not (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 (not (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))))) ;;; 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 (case-lambda ((x lis) (delete x lis equal?)) ((x lis elt=) (let recur ((lis lis)) (if (null-list? lis) lis (let ((head (car lis)) (tail (cdr lis))) (if (not (elt= x head)) (let ((new-tail (recur tail))) (if (eq? tail new-tail) lis (cons head new-tail))) (recur tail)))))))) (define delete! (case-lambda ((x lis) (delete! x lis equal?)) ((x lis elt=) (let lp ((ans lis)) (cond ((null-list? ans) ans) ; Scan looking for ((elt= x (car ans)) (lp (cdr ans))) ; first cons of result. (else (letrec ((scan-in (lambda (prev lis) (if (pair? lis) (if (not (elt= x (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 (not (elt= x (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))))))) ;;; Extended from R4RS to take an optional comparison argument. (define member (case-lambda ((x lis) (r6rs:member x lis)) ((x lis elt=) (let lp ((lis lis)) (and (not (null-list? lis)) (if (elt= x (car lis)) lis (lp (cdr 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 (case-lambda ((lis) (delete-duplicates lis equal?)) ((lis elt=) (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! (case-lambda ((lis) (delete-duplicates! lis equal?)) ((lis elt=) (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 (not (eq? tail new-tail)) (set-cdr! lis new-tail)) lis)))))) ;;; alist stuff ;;;;;;;;;;;;;;; ;;; Extended from R4RS to take an optional comparison argument. (define assoc (case-lambda ((x lis) (r6rs:assoc x lis)) ((x lis elt=) (let loop ((lis lis)) (if (pair? lis) (let ((entry (car lis))) (if (elt= x (car entry)) entry (loop (cdr lis)))) #f))))) (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 (case-lambda ((key alist) (remove (lambda (elt) (equal? key (car elt))) alist)) ((key alist elt=) (remove (lambda (elt) (elt= key (car elt))) alist)))) (define alist-delete! (case-lambda ((key alist) (remove! (lambda (elt) (equal? key (car elt))) alist)) ((key alist elt=) (remove! (lambda (elt) (elt= key (car elt))) alist)))) ;;; find find-tail take-while drop-while span break any every list-index ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (find pred lis) (check-arg procedure? pred find) (let loop ((lis lis)) (if (pair? lis) (let ((head (car lis))) (if (pred head) head (loop (cdr lis)))) #f))) (define (find-tail pred lis) (check-arg procedure? pred find-tail) (let lp ((lis lis)) (and (not (null-list? lis)) (if (pred (car lis)) lis (lp (cdr lis)))))) (define (take-while pred lis) (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) (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) (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) (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) (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)) ;; span with pred -> not pred (define (break pred lis) (check-arg procedure? pred break) (let recur ((lis lis)) (if (null-list? lis) (values '() '()) (let ((x (car lis))) (if (not (pred x)) (receive (prefix suffix) (recur (cdr lis)) (values (cons x prefix) suffix)) (values '() lis)))))) ;; span! with pred <-> not pred (define (break! pred lis) (check-arg procedure? pred break!) (if (or (null-list? lis) (pred (car lis))) (values '() lis) (let ((suffix (let lp ((prev lis) (rest (cdr lis))) (if (null-list? rest) rest (let ((x (car rest))) (if (not (pred x)) (lp rest (cdr rest)) (begin (set-cdr! prev '()) rest))))))) (values lis suffix)))) (define any (case-lambda ;; Fast path 1 ((pred lis1) (check-arg procedure? pred any) (and (not (null-list? lis1)) (let loop ((head (car lis1)) (tail (cdr lis1))) (if (null-list? tail) (pred head) ; Last PRED app is tail call. (or (pred head) (loop (car tail) (cdr tail))))))) ;; Fast path 2 ((pred lis1 lis2) (check-arg procedure? pred any) (and (not (null-list? lis1)) (not (null-list? lis2)) (let loop ((head1 (car lis1)) (tail1 (cdr lis1)) (head2 (car lis2)) (tail2 (cdr lis2))) (if (or (null-list? tail1) (null-list? tail2)) (pred head1 head2) ; Last PRED app is tail call. (or (pred head1 head2) (loop (car tail1) (cdr tail1) (car tail2) (cdr tail2))))))) ;; N-ary case ((pred lis1 lis2 . lists) (check-arg procedure? pred any) (and (not (null-list? lis1)) (not (null-list? lis2)) (receive (heads tails) (%cars+cdrs lists) (and (pair? heads) (let loop ((head1 (car lis1)) (tail1 (cdr lis1)) (head2 (car lis2)) (tail2 (cdr lis2)) (heads heads) (tails tails)) (if (or (null-list? tail1) (null-list? tail2)) (apply pred head1 head2 heads) ; Last PRED app is tail call. (receive (next-heads next-tails) (%cars+cdrs tails) (if (null? next-tails) (apply pred head1 head2 heads) ; Last PRED app is tail call. (or (apply pred head1 head2 heads) (loop (car tail1) (cdr tail1) (car tail2) (cdr tail2) next-heads next-tails)))))))))))) ;;(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 (case-lambda ;; Fast path 1 ((pred lis1) (check-arg procedure? pred every) (or (null-list? lis1) (let loop ((head (car lis1)) (tail (cdr lis1))) (if (null-list? tail) (pred head) ; Last PRED app is tail call. (and (pred head) (loop (car tail) (cdr tail))))))) ;; Fast path 2 ((pred lis1 lis2) (check-arg procedure? pred every) (or (null-list? lis1) (null-list? lis2) (let loop ((head1 (car lis1)) (tail1 (cdr lis1)) (head2 (car lis2)) (tail2 (cdr lis2))) (if (or (null-list? tail1) (null-list? tail2)) (pred head1 head2) ; Last PRED app is tail call. (and (pred head1 head2) (loop (car tail1) (cdr tail1) (car tail2) (cdr tail2))))))) ;; N-ary case ((pred lis1 lis2 . lists) (check-arg procedure? pred every) (or (null-list? lis1) (null-list? lis2) (receive (heads tails) (%cars+cdrs lists) (or (not (pair? heads)) (let loop ((head1 (car lis1)) (tail1 (cdr lis1)) (head2 (car lis2)) (tail2 (cdr lis2)) (heads heads) (tails tails)) (if (or (null-list? tail1) (null-list? tail2)) (apply pred head1 head2 heads) ; Last PRED app is tail call. (receive (next-heads next-tails) (%cars+cdrs tails) (if (null? next-tails) (apply pred head1 head2 heads) ; Last PRED app is tail call. (and (apply pred head1 head2 heads) (loop (car tail1) (cdr tail1) (car tail2) (cdr tail2) next-heads next-tails)))))))))))) (define list-index (case-lambda ;; Fast path 1 ((pred lis1) (check-arg procedure? pred list-index) (let loop ((lis lis1) (n 0)) (and (not (null-list? lis)) (if (pred (car lis)) n (loop (cdr lis) (fx+ n 1)))))) ;; Fast path 2 ((pred lis1 lis2) (check-arg procedure? pred list-index) (let loop ((lis1 lis1) (lis2 lis2) (n 0)) (and (not (or (null-list? lis1) (null-list? lis2))) (if (pred (car lis1) (car lis2)) n (loop (cdr lis1) (cdr lis2) (fx+ n 1)))))) ;; N-ary case ((pred lis1 lis2 lis3 . lists) (check-arg procedure? pred list-index) (let loop ((lis1 lis1) (lis2 lis2) (lis3 lis3) (lists lists) (n 0)) (and (not (or (null-list? lis1) (null-list? lis2) (null-list? lis3))) (receive (heads tails) (%cars+cdrs lists) (and (not (null? heads)) (if (apply pred (car lis1) (car lis2) (car lis3) heads) n (loop (cdr lis1) (cdr lis2) (cdr lis3) tails (fx+ 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<= (case-lambda ((=) (check-arg procedure? = lset<=) #t) ((= lis1) (check-arg procedure? = lset<=) #t) ((= lis1 lis2) (check-arg procedure? = lset<=) (or (eq? lis1 lis2) (%lset2<= = lis1 lis2))) ((= lis1 lis2 lis3 . lists) (check-arg procedure? = lset<=) (and (or (eq? lis1 lis2) (%lset2<= = lis1 lis2)) (or (eq? lis2 lis3) (%lset2<= = lis2 lis3)) (or (null? lists) (let loop ((lis1 lis3) (lis2 (car lists)) (lists (cdr lists))) (and (or (eq? lis1 lis2) (%lset2<= = lis1 lis2)) (or (null? lists) (loop lis2 (car lists) (cdr lists)))))))))) (define lset= (case-lambda ((=) (check-arg procedure? = lset=) #t) ((= lis1) (check-arg procedure? = lset=) #t) ((= lis1 lis2) (check-arg procedure? = lset=) (or (eq? lis1 lis2) (and (%lset2<= = lis1 lis2) (%lset2<= = lis2 lis1)))) ((= lis1 lis2 lis3 . lists) (check-arg procedure? = lset=) (and (or (eq? lis1 lis2) (and (%lset2<= = lis1 lis2) (%lset2<= = lis2 lis1))) (or (eq? lis2 lis3) (and (%lset2<= = lis2 lis3) (%lset2<= = lis3 lis2))) (or (null? lists) (let loop ((lis1 lis3) (lis2 (car lists)) (lists (cdr lists))) (and (or (eq? lis1 lis2) (and (%lset2<= = lis1 lis2) (%lset2<= = lis2 lis1))) (or (null? lists) (loop lis2 (car lists) (cdr lists)))))))))) (define lset-adjoin (case-lambda ((= lis) lis) ((= lis elt) (check-arg procedure? = lset-adjoin) (if (member elt lis) lis (cons elt lis))) ((= lis elt1 elt2) (check-arg procedure? = lset-adjoin) (let* ((lis (if (member elt1 lis) lis (cons elt1 lis))) (lis (if (member elt2 lis) lis (cons elt2 lis)))) lis)) ((= lis elt1 elt2 elt3 . elts) (check-arg procedure? = lset-adjoin) (let* ((lis (if (member elt1 lis) lis (cons elt1 lis))) (lis (if (member elt2 lis) lis (cons elt2 lis))) (lis (if (member elt3 lis) lis (cons elt3 lis)))) (if (null? elts) lis (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) lis elts)))))) (define lset-union (let ((lset-union-2 (lambda (= lis1 lis2) (cond ((null? lis1) lis2) ; Don't copy any lists ((null? lis2) lis1) ; if we don't have to. ((eq? lis1 lis2) lis1) (else (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans))) lis1 lis2)))))) (case-lambda ((=) (check-arg procedure? = lset-union) '()) ((= lis1) (check-arg procedure? = lset-union) lis1) ((= lis1 lis2) (check-arg procedure? = lset-union) (lset-union-2 = lis1 lis2)) ((= lis1 lis2 lis3 . lists) (check-arg procedure? = lset-union) (let* ((lis (lset-union-2 = lis1 lis2)) (lis (lset-union-2 = lis lis3))) (if (null? lists) lis (fold (lambda (lis2 lis1) (lset-union-2 = lis1 lis2)) lis lists))))))) (define lset-union! (let ((lset-union-2! (lambda (= lis1 lis2) (cond ((null? lis1) lis2) ; Don't copy any lists ((null? lis2) lis1) ; if we don't have to. ((eq? lis1 lis2) lis1) (else (pair-fold (lambda (pair ans) (let ((elt (car pair))) (if (member elt ans =) ans (begin (set-cdr! pair ans) pair)))) lis1 lis2)))))) (case-lambda ((=) (check-arg procedure? = lset-union!) '()) ((= lis1) (check-arg procedure? = lset-union!) lis1) ((= lis1 lis2) ; Splice new elts of LIS1 onto the front of LIS2. (check-arg procedure? = lset-union!) (lset-union-2! = lis1 lis2)) ((= lis1 lis2 lis3 . lists) (check-arg procedure? = lset-union!) (let* ((lis (lset-union-2! = lis1 lis2)) (lis (lset-union-2! = lis lis3))) (if (null? lists) lis (fold (lambda (lis1 lis2) (lset-union-2! = lis1 lis2)) lis lists))))))) (define lset-intersection (case-lambda ((= lis1) (check-arg procedure? = lset-intersection) lis1) ((= lis1 lis2) (check-arg procedure? = lset-intersection) (cond ((or (null-list? lis1) (eq? lis1 lis2)) lis1) ((null-list? lis2) lis2) (else (filter (lambda (x) (member x lis2 =)) lis1)))) ((= lis1 lis2 lis3 . lists) (check-arg procedure? = lset-intersection) (cond ;; Short cut ((or (null-list? lis1) (null-list? lis2) (null-list? lis3) (any null-list? lists)) '()) ;; Throw out lis2 (and lis3) if it is lis1 ((eq? lis2 lis1) (if (eq? lis3 lis1) (apply lset-intersection = lis1 lists) (apply lset-intersection = lis1 lis3 lists))) ;; Throw out lis3 if it is either lis1 or lis2 ((or (eq? lis3 lis1) (eq? lis3 lis2)) (apply lset-intersection = lis1 lis2 lists)) ;; Real procedure (else (let* ((lists (remove (lambda (lis) (or (eq? lis lis1) (eq? lis lis2) (eq? lis lis3))) lists))) (filter (lambda (x) (and (member x lis2 =) (member x lis3 =) (every (lambda (lis) (member x lis =)) lists))) lis1))))))) (define lset-intersection! (case-lambda ((= lis1) (check-arg procedure? = lset-intersection!) lis1) ((= lis1 lis2) (check-arg procedure? = lset-intersection!) (cond ((or (null-list? lis2) (eq? lis1 lis2)) lis1) ((null-list? lis1) lis2) (else (filter! (lambda (x) (member x lis2 =)) lis1)))) ((= lis1 lis2 lis3 . lists) (check-arg procedure? = lset-intersection!) (cond ;; Short cut ((or (null-list? lis1) (null-list? lis2) (null-list? lis3) (any null-list? lists)) '()) ;; Throw out lis2 (and lis3) if it is lis1 ((eq? lis2 lis1) (if (eq? lis3 lis1) (apply lset-intersection! = lis1 lists) (apply lset-intersection! = lis1 lis3 lists))) ;; Throw out lis3 if it is either lis1 or lis2 ((or (eq? lis3 lis1) (eq? lis3 lis2)) (apply lset-intersection! = lis1 lis2 lists)) ;; Real procedure (else (let ((lists (remove (lambda (lis) (or (eq? lis lis1) (eq? lis lis2) (eq? lis lis3))) lists))) ; Remove duplicates (filter! (lambda (x) (and (member x lis2 =) (member x lis3 =) (every (lambda (lis) (member x lis =)) lists))) lis1))))))) (define lset-difference (case-lambda ((= lis1) (check-arg procedure? = lset-difference) lis1) ((= lis1 lis2) (check-arg procedure? = lset-difference) (cond ((null-list? lis2) lis1) ((or (null-list? lis1) (eq? lis1 lis2)) '()) (else (filter (lambda (x) (not (member x lis2 =))) lis1)))) ((= lis1 lis2 lis3 . lists) (check-arg procedure? = lset-difference) (cond ;; Short cut ((or (null-list? lis1) (eq? lis1 lis2) (eq? lis1 lis3) (memq lis1 lists)) '()) ;; Throw out lis2 (or lis3) if it is nil ((null? lis2) (if (null? lis3) (apply lset-difference lis1 lists) (apply lset-difference lis1 lis3 lists))) ;; Throw out lis3 if it is lis2 or nil ((or (null? lis3) (eq? lis3 lis2)) (apply lset-difference lis1 lis2 lists)) ;; Real procedure (else (let ((lists (remove (lambda (lis) (or (null? lis) (eq? lis lis2) (eq? lis lis3))) lists))) ; Remove nil, lis2 and lis3 (filter (lambda (x) (and (not (member x lis2 =)) (not (member x lis3 =)) (every (lambda (lis) (not (member x lis =))) lists))) lis1))))))) (define lset-difference! (case-lambda ((= lis1) (check-arg procedure? = lset-difference!) lis1) ((= lis1 lis2) (check-arg procedure? = lset-difference!) (cond ((null-list? lis2) lis1) ((or (null-list? lis1) (eq? lis1 lis2)) '()) (else (filter! (lambda (x) (not (member x lis2 =))) lis1)))) ((= lis1 lis2 lis3 . lists) (check-arg procedure? = lset-difference!) (cond ;; Short cut ((or (null-list? lis1) (eq? lis1 lis2) (eq? lis1 lis3) (memq lis1 lists)) '()) ;; Throw out lis2 (or lis3) if it is nil ((null? lis2) (if (null? lis3) (apply lset-difference lis1 lists) (apply lset-difference lis1 lis3 lists))) ;; Throw out lis3 if it is lis2 or nil ((or (null? lis3) (eq? lis3 lis2)) (apply lset-difference lis1 lis2 lists)) ;; Real procedure (else (let ((lists (remove (lambda (lis) (or (null? lis) (eq? lis lis2) (eq? lis lis3))) lists))) ; Remove nil, lis2 and lis3 (filter! (lambda (x) (and (not (member x lis2 =)) (every (lambda (lis) (not (member x lis =))) lists))) lis1))))))) (define lset-xor (let ((lset-xor-2 (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))))))) (case-lambda ((=) (check-arg procedure? = lset-xor) '()) ((= a) (check-arg procedure? = lset-xor) a) ((= a b) (check-arg procedure? = lset-xor) (lset-xor-2 = b a)) ((= a b c . lists) (check-arg procedure? = lset-xor) (let* ((lis (lset-xor-2 = b a)) (lis (lset-xor-2 = c lis))) (if (null? lists) lis (fold (lambda (b a) (lset-xor-2 = b a)) lis lists))))))) (define lset-xor! (let ((lset-xor-2! (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))))))) (case-lambda ((=) (check-arg procedure? = lset-xor!) '()) ((= a) (check-arg procedure? = lset-xor!) a) ((= a b) (check-arg procedure? = lset-xor!) (lset-xor-2! = b a)) ((= a b c . lists) (check-arg procedure? = lset-xor!) (let* ((lis (lset-xor-2! = b a)) (lis (lset-xor-2! = c lis))) (if (null? lists) lis (fold (lambda (b a) (lset-xor-2! = b a)) lis lists))))))) (define lset-diff+intersection (case-lambda ;; Fast path 1 ((= lis1) (check-arg procedure? = lset-diff+intersection) (values lis1 '())) ;; Fast path 2 ((= lis1 lis2) (check-arg procedure? = lset-diff+intersection) (cond ((or (null-list? lis1) (eq? lis1 lis2)) (values '() lis1)) ((null-list? lis2) (values lis1 '())) (else (partition (lambda (elt) (not (member elt lis2 =))) lis1)))) ;; N-ary case ((= lis1 lis2 lis3 . lists) (check-arg procedure? = lset-diff+intersection) (cond ((or (null-list? lis1) (eq? lis1 lis2) (eq? lis1 lis3) (memq lis1 lists)) (values '() lis1)) ((null-list? lis2) (if (null-list? lis3) (apply lset-diff+intersection = lis1 lists) (apply lset-diff+intersection = lis1 lis3 lists))) ((or (null-list? lis3) (eq? lis3 lis2)) (apply lset-diff+intersection = lis1 lis2 lists)) (else (let ((lists (remove (lambda (lis) (or (null? lis) (eq? lis lis2) (eq? lis lis3))) lists))) (partition (lambda (elt) (not (or (member elt lis2 =) (member elt lis3 =) (any (lambda (lis) (member elt lis =)) lists)))) lis1))))))) (define lset-diff+intersection! (case-lambda ;; Fast path 1 ((= lis1) (check-arg procedure? = lset-diff+intersection!) (values lis1 '())) ;; Fast path 2 ((= lis1 lis2) (check-arg procedure? = lset-diff+intersection!) (cond ((or (null-list? lis1) (eq? lis1 lis2)) (values '() lis1)) ((null-list? lis2) (values lis1 '())) (else (partition! (lambda (elt) (not (member elt lis2 =))) lis1)))) ;; N-ary case ((= lis1 lis2 lis3 . lists) (check-arg procedure? = lset-diff+intersection!) (cond ((or (null-list? lis1) (eq? lis1 lis2) (eq? lis1 lis3) (memq lis1 lists)) (values '() lis1)) ((null-list? lis2) (if (null-list? lis3) (apply lset-diff+intersection! = lis1 lists) (apply lset-diff+intersection! = lis1 lis3 lists))) ((or (null-list? lis3) (eq? lis3 lis2)) (apply lset-diff+intersection = lis1 lis2 lists)) (else (let ((lists (remove (lambda (lis) (or (null? lis) (eq? lis lis2) (eq? lis lis3))) lists))) (partition! (lambda (elt) (not (or (member elt lis2 =) (member elt lis3 =) (any (lambda (lis) (member elt lis =)) lists)))) lis1))))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a11.sls000066400000000000000000000002511375154206600201550ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :11) (export let*-values let-values) (import (srfi :11 let-values)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a11/000077500000000000000000000000001375154206600174345ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a11/let-values.sls000066400000000000000000000004411375154206600222370ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :11 let-values) (export let-values let*-values) (import (only (rnrs) let-values let*-values)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a111.sls000066400000000000000000000001221375154206600202330ustar00rootroot00000000000000(library (srfi :111) (export box box? unbox set-box!) (import (srfi :111 boxes))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a111/000077500000000000000000000000001375154206600175155ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a111/boxes.sls000066400000000000000000000001661375154206600213630ustar00rootroot00000000000000(library (srfi :111 boxes) (export box box? unbox set-box!) (import (only (chezscheme) box box? unbox set-box!))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a115.sls000066400000000000000000000007621375154206600202510ustar00rootroot00000000000000(library (srfi :115) (export regexp regexp? valid-sre? rx regexp->sre char-set->sre regexp-matches regexp-matches? regexp-search regexp-replace regexp-replace-all regexp-fold regexp-extract regexp-split regexp-partition regexp-match? regexp-match-count regexp-match-submatch regexp-match-submatch/list regexp-match-submatch-start regexp-match-submatch-end regexp-match->list regexp-match->sexp) (import (srfi :115 regexp))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a115/000077500000000000000000000000001375154206600175215ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a115/regexp-impl.scm000066400000000000000000001337021375154206600224640ustar00rootroot00000000000000;; regexp.scm -- simple non-bactracking NFA implementation ;; Copyright (c) 2013-2016 Alex Shinn. All rights reserved. ;; BSD-style license: http://synthcode.com/license.txt ;;; An rx represents a start state and meta-info such as the number ;;; and names of submatches. (define-record-type Rx (make-rx start-state num-matches num-save-indexes non-greedy-indexes match-rules match-names sre) regexp? (start-state rx-start-state rx-start-state-set!) (num-matches rx-num-matches rx-num-matches-set!) (num-save-indexes rx-num-save-indexes rx-num-save-indexes-set!) (non-greedy-indexes rx-non-greedy-indexes rx-non-greedy-indexes-set!) (match-rules rx-rules rx-rules-set!) (match-names rx-names rx-names-set!) (sre regexp->sre)) ;; Syntactic sugar. (define-syntax rx (syntax-rules () ((rx sre ...) (regexp `(: sre ...))))) ;;; A state is a single nfa state with transition rules. (define-record-type State (%make-state accept? chars match match-rule next1 next2 id) state? ;; A boolean indicating if this is an accepting state. (accept? state-accept? state-accept?-set!) ;; A char or char-set indicating when we can transition. ;; Alternately, #f indicates an epsilon transition, while a ;; procedure of the form (lambda (ch i matches) ...) is a predicate ;; which should return #t if the char matches. (chars state-chars state-chars-set!) ;; A single integer indicating the match position to record. (match state-match state-match-set!) ;; The rule for merging ambiguous matches. Can be any of: left, ;; right, (list i j). Posix semantics are equivalent to using left ;; for the beginning of a submatch and right for the end. List is ;; used to capture a list of submatch data in the current match. (match-rule state-match-rule state-match-rule-set!) ;; The destination if the char match succeeds. (next1 state-next1 state-next1-set!) ;; An optional additional transition used for forking to two states. (next2 state-next2 state-next2-set!) ;; A unique (per regexp) id for debugging. (id state-id)) (define (make-state accept? chars match match-rule next1 next2 id) (if (and next1 (not (state? next1))) (error "expected a state" next1)) (if (and next2 (not (state? next2))) (error "expected a state" next2)) (%make-state accept? chars match match-rule next1 next2 id)) (define ~none 0) (define ~ci? 1) (define ~ascii? 2) (define ~nocapture? 4) (define (flag-set? flags i) (= i (bitwise-and flags i))) (define (flag-join a b) (if b (bitwise-ior a b) a)) (define (flag-clear a b) (bitwise-and a (bitwise-not b))) (define (char-set-ci cset) (char-set-fold (lambda (ch res) (char-set-adjoin! (char-set-adjoin! res (char-upcase ch)) (char-downcase ch))) (char-set) cset)) (define (make-char-state ch flags next id) (if (flag-set? flags ~ci?) (let ((cset (cond ((char? ch) (char-set-ci (char-set ch))) ((char-set? ch) (char-set-ci ch)) (else ch)))) (make-state #f cset #f #f next #f id)) (make-state #f ch #f #f next #f id))) (define (make-fork-state next1 next2 id) (make-state #f #f #f #f next1 next2 id)) (define (make-epsilon-state next id) (make-fork-state next #f id)) (define (make-accept-state id) (make-state #t #f #f #f #f #f id)) ;; A record holding the current match data - essentially a wrapper ;; around a vector, plus a reference to the RX for meta-info. (define-record-type Regexp-Match (%make-regexp-match matches rx string) regexp-match? (matches regexp-match-matches regexp-match-matches-set!) (rx regexp-match-rx) (string regexp-match-string)) (define (regexp-match-rules md) (rx-rules (regexp-match-rx md))) (define (regexp-match-names md) (rx-names (regexp-match-rx md))) (define (make-regexp-match len rx str) (%make-regexp-match (make-vector len #f) rx str)) (define (make-regexp-match-for-rx rx str) (make-regexp-match (rx-num-save-indexes rx) rx str)) (define (regexp-match-count md) (- (quotient (vector-length (regexp-match-matches md)) 2) 1)) (define (regexp-match-name-offset md name) (let lp ((ls (regexp-match-names md)) (first #f)) (cond ((null? ls) (or first (error "unknown match name" md name))) ((eq? name (caar ls)) (if (regexp-match-submatch-start+end md (cdar ls)) (cdar ls) (lp (cdr ls) (or first (cdar ls))))) (else (lp (cdr ls) first))))) (define (regexp-match-ref md n) (vector-ref (regexp-match-matches md) (if (integer? n) n (regexp-match-name-offset md n)))) (define (regexp-match-set! md n val) (vector-set! (regexp-match-matches md) n val)) (define (copy-regexp-match md) (let* ((src (regexp-match-matches md)) (len (vector-length src)) (dst (make-vector len #f))) (do ((i 0 (+ i 1))) ((= i len) (%make-regexp-match dst (regexp-match-rx md) (regexp-match-string md))) (vector-set! dst i (vector-ref src i))))) ;;> Returns the matching result for the given named or indexed ;;> submatch \var{n}, possibly as a list for a submatch-list, or ;;> \scheme{#f} if not matched. (define (regexp-match-submatch/list md n) (let ((n (if (integer? n) n (regexp-match-name-offset md n)))) (cond ((>= n (vector-length (regexp-match-rules md))) #f) (else (let ((rule (vector-ref (regexp-match-rules md) n))) (cond ((pair? rule) (let ((start (regexp-match-ref md (car rule))) (end (regexp-match-ref md (cdr rule))) (str (regexp-match-string md))) (and start end (substring-cursor str start end)))) (else (let ((res (regexp-match-ref md rule))) (if (pair? res) (reverse res) res))))))))) ;;> Returns the matching substring for the given named or indexed ;;> submatch \var{n}, or \scheme{#f} if not matched. (define (regexp-match-submatch md n) (let ((res (regexp-match-submatch/list md n))) (if (pair? res) (car res) res))) (define (regexp-match-submatch-start+end md n) (let ((n (if (integer? n) n (regexp-match-name-offset md n)))) (and (< n (vector-length (regexp-match-rules md))) (let ((rule (vector-ref (regexp-match-rules md) n))) (if (pair? rule) (let ((start (regexp-match-ref md (car rule))) (end (regexp-match-ref md (cdr rule))) (str (regexp-match-string md))) (and start end (cons (string-cursor->index str start) (string-cursor->index str end)))) #f))))) ;;> Returns the start index for the given named or indexed submatch ;;> \var{n}, or \scheme{#f} if not matched. (define (regexp-match-submatch-start md n) (cond ((regexp-match-submatch-start+end md n) => car) (else #f))) ;;> Returns the end index for the given named or indexed submatch ;;> \var{n}, or \scheme{#f} if not matched. (define (regexp-match-submatch-end md n) (cond ((regexp-match-submatch-start+end md n) => cdr) (else #f))) (define (regexp-match-convert recurse? md str) (cond ((vector? md) (let lp ((i 0) (res '())) (cond ((>= i (vector-length md)) (reverse res)) ((string-cursor? (vector-ref md i)) (lp (+ i 2) (cons (substring-cursor str (vector-ref md i) (vector-ref md (+ i 1))) res))) (else (lp (+ i 1) (cons (regexp-match-convert recurse? (vector-ref md i) str) res)))))) ((list? md) (if recurse? (map (lambda (x) (regexp-match-convert recurse? x str)) (reverse md)) (regexp-match-convert recurse? (car md) str))) ((and (pair? md) (string-cursor? (car md)) (string-cursor? (cdr md))) (substring-cursor str (car md) (cdr md))) ((regexp-match? md) (regexp-match-convert recurse? (regexp-match-matches md) (regexp-match-string md))) (else md))) ;;> Convert an regexp-match result to a list of submatches, beginning ;;> with the full match, using \scheme{#f} for unmatched submatches. (define (regexp-match->list md) (regexp-match-convert #f md #f)) ;;> Convert an regexp-match result to a forest of submatches, beginning ;;> with the full match, using \scheme{#f} for unmatched submatches. (define (regexp-match->sexp md) (regexp-match-convert #t md #f)) ;; Collect results from a list match. (define (match-collect md spec) (define (match-extract md n) (let* ((vec (regexp-match-matches md)) (rules (regexp-match-rules md)) (n-rule (vector-ref rules n)) (rule (vector-ref rules n-rule))) (if (pair? rule) (let ((start (regexp-match-ref md (car rule))) (end (regexp-match-ref md (cdr rule)))) (and start end (cons start end))) (regexp-match-ref md rule)))) (let ((end (cadr spec)) (vec (regexp-match-matches md))) (let lp ((i (+ 1 (car spec))) (ls '())) (if (>= i end) (reverse ls) (lp (+ i 1) (cons (match-extract md i) ls)))))) ;; A searcher represents a single rx state and match information. (define-record-type Searcher (make-searcher state matches) searcher? (state searcher-state searcher-state-set!) (matches searcher-matches searcher-matches-set!)) ;; Merge two regexp-matches, preferring the leftmost-longest of their ;; matches, or shortest for non-greedy matches. (define (regexp-match>=? m1 m2) (let ((non-greedy-indexes (rx-non-greedy-indexes (regexp-match-rx m1))) (end (- (vector-length (regexp-match-matches m1)) 1))) (let lp ((i 0)) (cond ((>= i end) #t) ((and (eqv? (regexp-match-ref m1 i) (regexp-match-ref m2 i)) (eqv? (regexp-match-ref m1 (+ i 1)) (regexp-match-ref m2 (+ i 1)))) (lp (+ i 2))) (else (not (and (string-cursor? (regexp-match-ref m2 i)) (or (not (string-cursor? (regexp-match-ref m1 i))) (string-cursor? (regexp-match-ref m2 (+ i 1)) (regexp-match-ref m1 (+ i 1))))))))))))))) (define (regexp-match-max m1 m2) (if (regexp-match>=? m1 m2) m1 m2)) ;; Merge match data from sr2 into sr1, preferring the leftmost-longest ;; match in the event of a conflict. (define (searcher-merge! sr1 sr2) (let ((m (regexp-match-max (searcher-matches sr1) (searcher-matches sr2)))) (if (not (eq? m (searcher-matches sr1))) (searcher-matches-set! sr1 (copy-regexp-match m))))) (define (searcher-max sr1 sr2) (if (or (not (searcher? sr2)) (regexp-match>=? (searcher-matches sr1) (searcher-matches sr2))) sr1 sr2)) (define (searcher-start-match sr) (regexp-match-ref (searcher-matches sr) 0)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; A posse is a group of searchers. (define (make-posse . o) (make-hash-table eq?)) (define posse? hash-table?) (define (posse-empty? posse) (zero? (hash-table-size posse))) (define (posse-ref posse sr) (hash-table-ref/default posse (searcher-state sr) #f)) (define (posse-add! posse sr) (hash-table-set! posse (searcher-state sr) sr)) (define (posse-clear! posse) (hash-table-walk posse (lambda (key val) (hash-table-delete! posse key)))) (define (posse-for-each proc posse) (hash-table-walk posse (lambda (key val) (proc val)))) (define (posse-every pred posse) (hash-table-fold posse (lambda (key val acc) (and acc (pred val))) #t)) (define (posse->list posse) (hash-table-values posse)) (define (list->posse ls) (let ((searchers (make-posse))) (for-each (lambda (sr) (posse-add! searchers sr)) ls) searchers)) (define (posse . args) (list->posse args)) (define (make-start-searcher rx str) (make-searcher (rx-start-state rx) (make-regexp-match-for-rx rx str))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Execution ;; A transition which doesn't advance the index. (define (epsilon-state? st) (or (not (state-chars st)) (procedure? (state-chars st)))) ;; Match the state against a char and index. (define (state-matches? st str i ch start end matches) (let ((matcher (state-chars st))) (cond ((char? matcher) (eqv? matcher ch)) ((char-set? matcher) (char-set-contains? matcher ch)) ((pair? matcher) (and (char<=? (car matcher) ch) (char<=? ch (cdr matcher)))) ((procedure? matcher) (matcher str i ch start end matches)) ((not matcher)) (else (error "unknown state matcher" (state-chars st)))))) ;; Advance epsilons together - if the State is newly added to the ;; group and is an epsilon state, recursively add the transition. (define (posse-advance! new seen accept sr str i start end) (let advance! ((sr sr)) (let ((st (searcher-state sr))) ;; Update match data. (cond ((state-match st) (let* ((index (state-match st)) (matches (searcher-matches sr)) (before (copy-regexp-match matches))) (cond ((pair? index) ;; Submatch list, accumulate and push. (let* ((prev (regexp-match-ref matches (car index))) (new (cons (match-collect matches (cdr index)) (if (pair? prev) prev '())))) (regexp-match-set! matches (car index) new))) ((not (and (eq? 'non-greedy-left (state-match-rule st)) (regexp-match-ref matches index) (string-cursor>=? (regexp-match-ref matches index) (regexp-match-ref matches (- index 1))))) (regexp-match-set! matches index i)))))) ;; Follow transitions. (cond ((state-accept? st) (set-cdr! accept (searcher-max sr (cdr accept)))) ((posse-ref seen sr) => (lambda (sr-prev) (searcher-merge! sr-prev sr))) ((epsilon-state? st) (let ((ch (and (string-cursor (lambda (sr-prev) (searcher-merge! sr-prev sr))) (else ;; Add new searcher. (posse-add! new sr)))))) ;; Run so long as there is more to match. (define (regexp-run-offsets search? rx str start end) (let ((rx (regexp rx)) (epsilons (posse)) (accept (list #f))) (let lp ((i start) (searchers1 (posse)) (searchers2 (posse))) ;; Advance initial epsilons once from the first index, or every ;; time when searching. (cond ((or search? (string-cursor=? i start)) (posse-advance! searchers1 epsilons accept (make-start-searcher rx str) str i start end) (posse-clear! epsilons))) (cond ((or (string-cursor>=? i end) (and search? (searcher? (cdr accept)) (let ((accept-start (searcher-start-match (cdr accept)))) (posse-every (lambda (searcher) (string-cursor>? (searcher-start-match searcher) accept-start)) searchers1))) (and (not search?) (posse-empty? searchers1))) ;; Terminate when the string is done or there are no more ;; searchers. If we terminate prematurely and are not ;; searching, return false. (and (searcher? (cdr accept)) (let ((matches (searcher-matches (cdr accept)))) (and (or search? (string-cursor>=? (regexp-match-ref matches 1) end)) (searcher-matches (cdr accept)))))) (else ;; Otherwise advance normally. (let ((ch (string-cursor-ref str i)) (i2 (string-cursor-next str i))) (posse-for-each ;; NOTE: non-deterministic from hash order (lambda (sr) (cond ((state-matches? (searcher-state sr) str i ch start end (searcher-matches sr)) (searcher-state-set! sr (state-next1 (searcher-state sr))) ;; Epsilons are considered at the next position. (posse-advance! searchers2 epsilons accept sr str i2 start end) (posse-clear! epsilons)))) searchers1) (posse-clear! searchers1) (lp i2 searchers2 searchers1))))))) ;; Wrapper to determine start and end offsets. (define (regexp-run search? rx str . o) (let ((start (string-start-arg str o)) (end (string-end-arg str (if (pair? o) (cdr o) o)))) (regexp-run-offsets search? rx str start end))) ;;> Match the given regexp or SRE against the entire string and return ;;> the match data on success. Returns \scheme{#f} on failure. (define (regexp-matches rx str . o) (apply regexp-run #f rx str o)) ;;> Match the given regexp or SRE against the entire string and return ;;> the \scheme{#t} on success. Returns \scheme{#f} on failure. (define (regexp-matches? rx str . o) (and (apply regexp-matches rx str o) #t)) ;;> Search for the given regexp or SRE within string and return ;;> the match data on success. Returns \scheme{#f} on failure. (define (regexp-search rx str . o) (apply regexp-run #t rx str o)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Compiling (define (parse-flags ls) (define (symbol->flag s) (case s ((i ci case-insensitive) ~ci?) (else ~none))) (let lp ((ls ls) (res ~none)) (if (not (pair? ls)) res (lp (cdr ls) (flag-join res (symbol->flag (car ls))))))) (define char-set:nonl (char-set-difference char-set:full (char-set #\newline))) (define char-set:control (ucs-range->char-set 0 32)) (define char-set:word-constituent (char-set-union char-set:letter char-set:digit (char-set #\_))) (define %char-set:word-constituent (char-set-union %char-set:letter %char-set:digit (char-set #\_))) (define (char-word-constituent? ch) (char-set-contains? char-set:word-constituent ch)) (define get-char-set:cased (let ((char-set:cased #f)) (lambda () (if (not char-set:cased) (set! char-set:cased (char-set-union char-set:upper-case char-set:lower-case char-set:title-case))) char-set:cased))) (define (match/bos str i ch start end matches) (string-cursor=? i start)) (define (match/eos str i ch start end matches) (string-cursor>=? i end)) (define (match/bol str i ch start end matches) (or (string-cursor=? i start) (eqv? #\newline (string-cursor-ref str (string-cursor-prev str i))))) (define (match/eol str i ch start end matches) (or (string-cursor>=? i end) (eqv? #\newline (string-cursor-ref str i)))) (define (match/bow str i ch start end matches) (and (string-cursor=? i end) (not (char-word-constituent? ch))) (string-cursor>? i start) (char-word-constituent? (string-cursor-ref str (string-cursor-prev str i))))) (define (match/nwb str i ch start end matches) (and (not (match/bow str i ch start end matches)) (not (match/eow str i ch start end matches)))) (define (match/bog str i ch start end matches) (and (string-cursor? i start) (or (string-cursor>=? i end) (let ((m (regexp-search re:grapheme str (string-cursor->index str i) (string-cursor->index str end)))) (and m (string-cursor<=? (regexp-match-submatch-end m 0) i)))))) (define (lookup-char-set name flags) (cond ((flag-set? flags ~ascii?) (case name ((any) char-set:full) ((nonl) char-set:nonl) ((lower-case lower) (if (flag-set? flags ~ci?) %char-set:letter %char-set:lower-case)) ((upper-case upper) (if (flag-set? flags ~ci?) %char-set:letter %char-set:upper-case)) ((title-case title) (if (flag-set? flags ~ci?) %char-set:letter (char-set))) ((alphabetic alpha) %char-set:letter) ((numeric num digit) %char-set:digit) ((alphanumeric alphanum alnum) %char-set:letter+digit) ((punctuation punct) %char-set:punctuation) ((symbol) %char-set:symbol) ((graphic graph) %char-set:graphic) ((word-constituent) %char-set:word-constituent) ((whitespace white space) %char-set:whitespace) ((printing print) %char-set:printing) ((control cntrl) %char-set:iso-control) ((hex-digit xdigit hex) char-set:hex-digit) ((ascii) char-set:ascii) (else #f))) (else (case name ((any) char-set:full) ((nonl) char-set:nonl) ((lower-case lower) (if (flag-set? flags ~ci?) (get-char-set:cased) char-set:lower-case)) ((upper-case upper) (if (flag-set? flags ~ci?) (get-char-set:cased) char-set:upper-case)) ((title-case title) (if (flag-set? flags ~ci?) (get-char-set:cased) char-set:title-case)) ((alphabetic alpha) char-set:letter) ((numeric num digit) char-set:digit) ((alphanumeric alphanum alnum) char-set:letter+digit) ((punctuation punct) char-set:punctuation) ((symbol) char-set:symbol) ((graphic graph) char-set:graphic) ((word-constituent) char-set:word-constituent) ((whitespace white space) char-set:whitespace) ((printing print) char-set:printing) ((control cntrl) char-set:control) ((hex-digit xdigit hex) char-set:hex-digit) ((ascii) char-set:ascii) (else #f))))) (define (sre-flatten-ranges orig-ls) (let lp ((ls orig-ls) (res '())) (cond ((null? ls) (reverse res)) ((string? (car ls)) (lp (append (string->list (car ls)) (cdr ls)) res)) ((null? (cdr ls)) (error "unbalanced cset / range" orig-ls)) ((string? (cadr ls)) (lp (cons (car ls) (append (string->list (cadr ls)) (cddr ls))) res)) (else (lp (cddr ls) (cons (cons (car ls) (cadr ls)) res)))))) (define (every pred ls) (or (null? ls) (and (pred (car ls)) (every pred (cdr ls))))) (define (char-set-sre? sre) (or (char? sre) (and (string? sre) (= 1 (string-length sre))) (lookup-char-set sre ~none) (and (pair? sre) (or (string? (car sre)) (memq (car sre) '(char-set / char-range & and ~ complement - difference)) (and (memq (car sre) '(\x7C; or w/case w/nocase w/unicode w/ascii)) (every char-set-sre? (cdr sre))))))) (define (non-greedy-sre? sre) (and (pair? sre) (or (memq (car sre) '(?? *? **? non-greedy-optional non-greedy-zero-or-more non-greedy-repeated)) (and (memq (car sre) '(: seq w/case w/nocase w/unicode w/ascii)) (non-greedy-sre? (car (reverse sre)))) (and (eq? (car sre) 'or) (any non-greedy-sre? (cdr sre)))))) (define (valid-sre? x) (guard (exn (else #f)) (regexp x) #t)) (define (sre->char-set sre . o) (let ((flags (if (pair? o) (car o) ~none))) (define (->cs sre) (sre->char-set sre flags)) (define (maybe-ci sre) (if (flag-set? flags ~ci?) (char-set-ci sre) sre)) (cond ((lookup-char-set sre flags)) ((char-set? sre) (maybe-ci sre)) ((char? sre) (maybe-ci (char-set sre))) ((string? sre) (if (= 1 (string-length sre)) (maybe-ci (string->char-set sre)) (error "only single char strings can be char-sets"))) ((pair? sre) (if (string? (car sre)) (maybe-ci (string->char-set (car sre))) (case (car sre) ((char-set) (maybe-ci (string->char-set (cadr sre)))) ((/ char-range) (->cs `(or ,@(map (lambda (x) (ucs-range->char-set (char->integer (car x)) (+ 1 (char->integer (cdr x))))) (sre-flatten-ranges (cdr sre)))))) ((& and) (apply char-set-intersection (map ->cs (cdr sre)))) ((\x7C; or) (apply char-set-union (map ->cs (cdr sre)))) ((~ complement) (char-set-complement (->cs `(or ,@(cdr sre))))) ((- difference) (char-set-difference (->cs (cadr sre)) (->cs `(or ,@(cddr sre))))) ((w/case) (sre->char-set (cadr sre) (flag-clear flags ~ci?))) ((w/nocase) (sre->char-set (cadr sre) (flag-join flags ~ci?))) ((w/ascii) (sre->char-set (cadr sre) (flag-join flags ~ascii?))) ((w/unicode) (sre->char-set (cadr sre) (flag-clear flags ~ascii?))) (else (error "invalid sre char-set" sre))))) (else (error "invalid sre char-set" sre))))) (define (char-set->sre cset) (list (char-set->string cset))) (define (strip-submatches sre) (if (pair? sre) (case (car sre) (($ submatch) (strip-submatches (cons ': (cdr sre)))) ((-> => submatch-named) (strip-submatches (cons ': (cddr sre)))) (else (cons (strip-submatches (car sre)) (strip-submatches (cdr sre))))) sre)) (define (sre-expand-reps from to sre) (let ((sre0 (strip-submatches sre))) (let lp ((i 0) (res '(:))) (if (= i from) (cond ((not to) (reverse (cons `(* ,sre) res))) ((= from to) (reverse (cons sre (cdr res)))) (else (let lp ((i (+ i 1)) (res res)) (if (>= i to) (reverse (cons `(? ,sre) res)) (lp (+ i 1) (cons `(? ,sre0) res)))))) (lp (+ i 1) (cons sre0 res)))))) ;;> Compile an \var{sre} into a regexp. (define (regexp sre . o) (define current-index 2) (define current-match 0) (define current-id 0) (define match-names '()) (define match-rules (list (cons 0 1))) (define non-greedy-indexes '()) (define (next-id) (let ((res current-id)) (set! current-id (+ current-id 1)) res)) (define (make-submatch-state sre flags next index) (let* ((n3 (make-epsilon-state next (next-id))) (n2 (->rx sre flags n3)) (n1 (make-epsilon-state n2 (next-id))) (non-greedy? (non-greedy-sre? sre))) (state-match-set! n1 index) (state-match-rule-set! n1 'left) (state-match-set! n3 (+ index 1)) (state-match-rule-set! n3 (if non-greedy? 'non-greedy-left 'right)) (if non-greedy? (set! non-greedy-indexes (cons (+ index 1) non-greedy-indexes))) n1)) (define (->rx sre flags next) (cond ;; The base cases chars and strings match literally. ((char? sre) (make-char-state sre flags next (next-id))) ((char-set? sre) (make-char-state sre flags next (next-id))) ((string? sre) (->rx (cons 'seq (string->list sre)) flags next)) ((and (symbol? sre) (lookup-char-set sre flags)) => (lambda (cset) (make-char-state cset ~none next (next-id)))) ((symbol? sre) (case sre ((epsilon) next) ((bos) (make-char-state match/bos flags next (next-id))) ((eos) (make-char-state match/eos flags next (next-id))) ((bol) (make-char-state match/bol flags next (next-id))) ((eol) (make-char-state match/eol flags next (next-id))) ((bow) (make-char-state match/bow flags next (next-id))) ((eow) (make-char-state match/eow flags next (next-id))) ((nwb) (make-char-state match/nwb flags next (next-id))) ((bog) (make-char-state match/bog flags next (next-id))) ((eog) (make-char-state match/eog flags next (next-id))) ((grapheme) (->rx `(or (: (* ,char-set:hangul-l) (+ ,char-set:hangul-v) (* ,char-set:hangul-t)) (: (* ,char-set:hangul-l) ,char-set:hangul-v (* ,char-set:hangul-v) (* ,char-set:hangul-t)) (: (* ,char-set:hangul-l) ,char-set:hangul-lvt (* ,char-set:hangul-t)) (+ ,char-set:hangul-l) (+ ,char-set:hangul-t) (+ ,char-set:regional-indicator) (: "\r\n") (: (~ control ("\r\n")) (+ ,char-set:extend-or-spacing-mark)) control) flags next)) ((word) (->rx '(word+ any) flags next)) (else (error "unknown sre" sre)))) ((pair? sre) (case (car sre) ((seq :) ;; Sequencing. An empty sequence jumps directly to next, ;; otherwise we join the first element to the sequence formed ;; of the remaining elements followed by next. (if (null? (cdr sre)) next ;; Make a dummy intermediate to join the states so that ;; we can generate n1 first, preserving the submatch order. (let* ((n2 (make-epsilon-state #f (next-id))) (n1 (->rx (cadr sre) flags n2)) (n3 (->rx (cons 'seq (cddr sre)) flags next))) (state-next1-set! n2 n3) n1))) ((or \x7C; ) ;; Alternation. An empty alternation always fails. ;; Otherwise we fork between any of the alternations, each ;; continuing to next. (cond ((null? (cdr sre)) #f) ((char-set-sre? sre) (make-char-state (sre->char-set sre) flags next (next-id))) ((null? (cddr sre)) (->rx (cadr sre) flags next)) (else (let* ((n1 (->rx (cadr sre) flags next)) (n2 (->rx (cons 'or (cddr sre)) flags next))) (make-fork-state n1 n2 (next-id)))))) ((? optional ?? non-greedy-optional) ;; Optionality. Either match the body or fork to the next ;; state directly. (make-fork-state (->rx (cons 'seq (cdr sre)) flags next) next (next-id))) ((* zero-or-more *? non-greedy-zero-or-more) ;; Repetition. Introduce two fork states which can jump from ;; the end of the loop to the beginning and from the ;; beginning to the end (to skip the first iteration). (let* ((n2 (make-fork-state next #f (next-id))) (n1 (make-fork-state (->rx (cons 'seq (cdr sre)) flags n2) n2 (next-id)))) (state-next2-set! n2 n1) n1)) ((+ one-or-more) ;; One-or-more repetition. Same as above but the first ;; transition is required so the rx is simpler - we only ;; need one fork from the end of the loop to the beginning. (let* ((n2 (make-fork-state next #f (next-id))) (n1 (->rx (cons 'seq (cdr sre)) flags n2))) (state-next2-set! n2 n1) n1)) ((= exactly) ;; Exact repetition. (->rx (sre-expand-reps (cadr sre) (cadr sre) (cons 'seq (cddr sre))) flags next)) ((>= at-least) ;; n-or-more repetition. (->rx (sre-expand-reps (cadr sre) #f (cons 'seq (cddr sre))) flags next)) ((** repeated **? non-greedy-repeated) ;; n-to-m repetition. (->rx (sre-expand-reps (cadr sre) (car (cddr sre)) (cons 'seq (cdr (cddr sre)))) flags next)) ((-> => submatch-named) ;; Named submatches just record the name for the current ;; match and rewrite as a non-named submatch. (cond ((flag-set? flags ~nocapture?) (->rx (cons 'seq (cddr sre)) flags next)) (else (set! match-names (cons (cons (cadr sre) (+ 1 current-match)) match-names)) (->rx (cons 'submatch (cddr sre)) flags next)))) ((*-> *=> submatch-named-list) (cond ((flag-set? flags ~nocapture?) (->rx (cons 'seq (cddr sre)) flags next)) (else (set! match-names (cons (cons (cadr sre) current-match) match-names)) (->rx (cons 'submatch-list (cddr sre)) flags next)))) (($ submatch) ;; A submatch wraps next with an epsilon transition before ;; next, setting the start and end index on the result and ;; wrapped next respectively. (cond ((flag-set? flags ~nocapture?) (->rx (cons 'seq (cdr sre)) flags next)) (else (let ((num current-match) (index current-index)) (set! current-match (+ current-match 1)) (set! current-index (+ current-index 2)) (set! match-rules `((,index . ,(+ index 1)) ,@match-rules)) (make-submatch-state (cons 'seq (cdr sre)) flags next index))))) ((*$ submatch-list) ;; A submatch-list wraps a range of submatch results into a ;; single match value. (cond ((flag-set? flags ~nocapture?) (->rx (cons 'seq (cdr sre)) flags next)) (else (let* ((num current-match) (index current-index)) (set! current-match (+ current-match 1)) (set! current-index (+ current-index 1)) (set! match-rules `(,index ,@match-rules)) (let* ((n2 (make-epsilon-state next (next-id))) (n1 (->rx (cons 'submatch (cdr sre)) flags n2))) (state-match-set! n2 (list index num current-match)) (state-match-rule-set! n2 'list) n1))))) ((~ - & / complement difference and char-range char-set) (make-char-state (sre->char-set sre flags) ~none next (next-id))) ((word) (->rx `(: bow ,@(cdr sre) eow) flags next)) ((word+) (->rx `(word (+ ,(if (equal? '(any) (cdr sre)) 'word-constituent (char-set-intersection char-set:word-constituent (sre->char-set `(or ,@(cdr sre)) flags))))) flags next)) ((w/case) (->rx `(: ,@(cdr sre)) (flag-clear flags ~ci?) next)) ((w/nocase) (->rx `(: ,@(cdr sre)) (flag-join flags ~ci?) next)) ((w/unicode) (->rx `(: ,@(cdr sre)) (flag-clear flags ~ascii?) next)) ((w/ascii) (->rx `(: ,@(cdr sre)) (flag-join flags ~ascii?) next)) ((w/nocapture) (->rx `(: ,@(cdr sre)) (flag-join flags ~nocapture?) next)) (else (if (string? (car sre)) (make-char-state (sre->char-set sre flags) ~none next (next-id)) (error "unknown sre" sre))))))) (let ((flags (parse-flags (and (pair? o) (car o))))) (if (regexp? sre) sre (let ((start (make-submatch-state sre flags (make-accept-state (next-id)) 0))) ;; (define (state->list st) ;; (let ((seen (make-hash-table eq?)) ;; (count 0)) ;; (reverse ;; (let lp ((st st) (res '())) ;; (cond ;; ((not (state? st)) res) ;; ((hash-table-ref/default seen st #f) res) ;; (else ;; (hash-table-set! seen st count) ;; (let ((orig-count count)) ;; (set! count (+ count 1)) ;; (let* ((next1 (lp (state-next1 st) '())) ;; (next2 (lp (state-next2 st) '())) ;; (this (append ;; (list (state-id st) ;;orig-count ;; (cond ;; ((epsilon-state? st) ;; (if (state-chars st) '? '-)) ;; ((and (char-set? (state-chars st)) ;; (< (char-set-size (state-chars st)) 5)) ;; (char-set->string (state-chars st))) ;; ((char? (state-chars st)) ;; (string (state-chars st))) ;; (else '+)) ;; (cond ;; ((state-next1 st) => state-id) ;; (else #f))) ;; (if (state-next2 st) ;; (list (state-id (state-next2 st))) ;; '()) ;; (if (state-match st) ;; (list (list 'm (state-match st))) ;; '())))) ;; (append next2 next1 (cons this res)))))))))) ;;(for-each (lambda (x) (write x) (newline)) (state->list start)) (make-rx start current-match current-index non-greedy-indexes (list->vector (reverse match-rules)) match-names sre))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Utilities ;;> The fundamental regexp matching iterator. Repeatedly searches ;;> \var{str} for the regexp \var{re} so long as a match can be found. ;;> On each successful match, applies \scheme{(\var{kons} \var{i} ;;> \var{regexp-match} \var{str} \var{acc})} where \var{i} is the ;;> index since the last match (beginning with ;;> \var{start}),\var{regexp-match} is the resulting match, and ;;> \var{acc} is the result of the previous \var{kons} application, ;;> beginning with \var{knil}. When no more matches can be found, ;;> calls \var{finish} with the same arguments, except that ;;> \var{regexp-match} is \scheme{#f}. ;;> ;;> By default \var{finish} just returns \var{acc}. (define (regexp-fold rx kons knil str . o) (let* ((rx (regexp rx)) (finish (if (pair? o) (car o) (lambda (from md str acc) acc))) (o (if (pair? o) (cdr o) o)) (start (string-start-arg str o)) (end (string-end-arg str (if (pair? o) (cdr o) o)))) (let lp ((i start) (from start) (acc knil)) (cond ((and (string-cursor (lambda (md) (let ((j (regexp-match-ref md 1))) (lp (if (and (string-cursor=? i j) (string-cursorindex str from) md str acc))))) (else (finish (string-cursor->index str from) #f str acc)))))) ;;> Extracts all non-empty substrings of \var{str} which match ;;> \var{re} between \var{start} and \var{end} as a list of strings. (define (regexp-extract rx str . o) (apply regexp-fold rx (lambda (from md str a) (let ((s (regexp-match-submatch md 0))) (if (equal? s "") a (cons s a)))) '() str (lambda (from md str a) (reverse a)) o)) ;;> Splits \var{str} into a list of strings separated by matches of ;;> \var{re}. (define (regexp-split rx str . o) ;; start and end in indices passed to regexp-fold (let ((start (if (pair? o) (car o) 0)) (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) (regexp-fold rx (lambda (from md str a) (let ((i (regexp-match-submatch-start md 0)) (j (regexp-match-submatch-end md 0))) (if (eqv? i j) a (cons j (cons (substring str (car a) i) (cdr a)))))) (cons start '()) str (lambda (from md str a) (reverse (cons (substring str (car a) end) (cdr a)))) start end))) ;;> Partitions \var{str} into a list of non-empty strings ;;> matching \var{re}, interspersed with the unmatched portions ;;> of the string. The first and every odd element is an unmatched ;;> substring, which will be the empty string if \var{re} matches ;;> at the beginning of the string or end of the previous match. The ;;> second and every even element will be a substring matching ;;> \var{re}. If the final match ends at the end of the string, ;;> no trailing empty string will be included. Thus, in the ;;> degenerate case where \var{str} is the empty string, the ;;> result is \scheme{("")}. (define (regexp-partition rx str . o) (let ((start (if (pair? o) (car o) 0)) (end (if (and (pair? o) (pair? (cdr o))) (cadr o) (string-length str)))) (define (kons from md str a) (let ((i (regexp-match-submatch-start md 0)) (j (regexp-match-submatch-end md 0))) (if (eqv? i j) a (let ((left (substring str (car a) i))) (cons j (cons (regexp-match-submatch md 0) (cons left (cdr a)))))))) (define (final from md str a) (if (or (< from end) (null? (cdr a))) (cons (substring str (car a) end) (cdr a)) (cdr a))) (reverse (regexp-fold rx kons (cons start '()) str final start end)))) ;;> Returns a new string replacing the \var{count}th match of \var{re} ;;> in \var{str} the \var{subst}, where the zero-indexed \var{count} ;;> defaults to zero (i.e. the first match). If there are not ;;> \var{count} matches, returns the selected substring unmodified. ;;> \var{subst} can be a string, an integer or symbol indicating the ;;> contents of a numbered or named submatch of \var{re},\scheme{'pre} ;;> for the substring to the left of the match, or \scheme{'post} for ;;> the substring to the right of the match. ;;> The optional parameters \var{start} and \var{end} restrict both ;;> the matching and the substitution, to the given indices, such that ;;> the result is equivalent to omitting these parameters and ;;> replacing on \scheme{(substring str start end)}. As a convenience, ;;> a value of \scheme{#f} for \var{end} is equivalent to ;;> \scheme{(string-length str)}. (define (regexp-replace rx str subst . o) (let* ((start (if (and (pair? o) (car o)) (car o) 0)) (o (if (pair? o) (cdr o) '())) (end (if (and (pair? o) (car o)) (car o) (string-length str))) (o (if (pair? o) (cdr o) '())) (count (if (pair? o) (car o) 0))) (let lp ((i start) (count count)) (let ((m (regexp-search rx str i end))) (cond ((not m) str) ((positive? count) (lp (regexp-match-submatch-end m 0) (- count 1))) (else (string-concatenate (cons (substring str start (regexp-match-submatch-start m 0)) (append (reverse (regexp-apply-match m str subst)) (list (substring str (regexp-match-submatch-end m 0) end))))))))))) ;;> Equivalent to \var{regexp-replace}, but replaces all occurrences ;;> of \var{re} in \var{str}. (define (regexp-replace-all rx str subst . o) (regexp-fold rx (lambda (i m str acc) (let ((m-start (regexp-match-submatch-start m 0))) (append (regexp-apply-match m str subst) (if (>= i m-start) acc (cons (substring str i m-start) acc))))) '() str (lambda (i m str acc) (let ((end (string-length str))) (string-concatenate-reverse (if (>= i end) acc (cons (substring str i end) acc))))))) (define (regexp-apply-match m str ls) (let lp ((ls ls) (res '())) (cond ((null? ls) res) ((not (pair? ls)) (lp (list ls) res)) ((integer? (car ls)) (lp (cdr ls) (cons (or (regexp-match-submatch m (car ls)) "") res))) ((procedure? (car ls)) (lp (cdr ls) (cons ((car ls) m) res))) ((symbol? (car ls)) (case (car ls) ((pre) (lp (cdr ls) (cons (substring str 0 (regexp-match-submatch-start m 0)) res))) ((post) (lp (cdr ls) (cons (substring str (regexp-match-submatch-end m 0) (string-length str)) res))) (else (cond ((assq (car ls) (regexp-match-names m)) => (lambda (x) (lp (cons (cdr x) (cdr ls)) res))) (else (error "unknown match replacement" (car ls))))))) (else (lp (cdr ls) (cons (car ls) res)))))) (define re:grapheme (regexp 'grapheme)) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a115/regexp.sls000066400000000000000000000103151375154206600215360ustar00rootroot00000000000000#!r6rs ;; Copyright (c) 2009-2015 Alex Shinn ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. The name of the author may not be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. ;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT ;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;; Converted from lib/chibi/regexp.sld to R6RS by Göran Weinholt. (library (srfi :115 regexp) (export regexp regexp? valid-sre? rx regexp->sre char-set->sre regexp-matches regexp-matches? regexp-search regexp-replace regexp-replace-all regexp-fold regexp-extract regexp-split regexp-partition regexp-match? regexp-match-count regexp-match-submatch regexp-match-submatch/list regexp-match-submatch-start regexp-match-submatch-end regexp-match->list regexp-match->sexp) (import (rename (except (rnrs) define-record-type string-ci-hash string-hash error) (exists any)) (only (rnrs r5rs) quotient) (rnrs mutable-pairs) (srfi :9 records) (srfi :14 char-sets) (srfi :23 error) (srfi :69 basic-hash-tables) (srfi :115 regexp boundary) (srfi private include)) (define %char-set:letter (char-set-intersection char-set:ascii char-set:letter)) (define %char-set:lower-case (char-set-intersection char-set:ascii char-set:lower-case)) (define %char-set:upper-case (char-set-intersection char-set:ascii char-set:upper-case)) (define %char-set:digit (char-set-intersection char-set:ascii char-set:digit)) (define %char-set:letter+digit (char-set-intersection char-set:ascii char-set:letter+digit)) (define %char-set:punctuation (char-set-intersection char-set:ascii char-set:punctuation)) (define %char-set:symbol (char-set-intersection char-set:ascii char-set:symbol)) (define %char-set:graphic (char-set-intersection char-set:ascii char-set:graphic)) (define %char-set:whitespace (char-set-intersection char-set:ascii char-set:whitespace)) (define %char-set:printing (char-set-intersection char-set:ascii char-set:printing)) (define %char-set:iso-control (char-set-intersection char-set:ascii char-set:iso-control)) (define (string-start-arg s o) (if (pair? o) (string-index->cursor s (car o)) 0)) (define (string-end-arg s o) (if (pair? o) (string-index->cursor s (car o)) (string-length s))) (define string-cursor? integer?) (define string-cursor=? =) (define string-cursor? >) (define string-cursor>=? >=) (define string-cursor-ref string-ref) (define (string-cursor-next s i) (+ i 1)) (define (string-cursor-prev s i) (- i 1)) (define substring-cursor substring) (define (string-cursor->index str off) off) (define (string-index->cursor str i) i) (define (string-concatenate ls) (apply string-append ls)) (define (string-concatenate-reverse ls) (string-concatenate (reverse ls))) ;; Replaced |\|| with \x7C;. (include/resolve ("srfi" "%3a115") "regexp-impl.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a115/regexp/000077500000000000000000000000001375154206600210135ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a115/regexp/boundary-impl.scm000066400000000000000000000533451375154206600243130ustar00rootroot00000000000000;; Control (define char-set:control (immutable-char-set (char-set-union (ucs-range->char-set 0 10) (ucs-range->char-set 11 13) (ucs-range->char-set 14 32) (ucs-range->char-set 127 160) (ucs-range->char-set 1536 1541) (ucs-range->char-set 8206 8208) (ucs-range->char-set 8234 8239) (ucs-range->char-set 8288 8293) (ucs-range->char-set 8294 8304) (ucs-range->char-set 55296 57344) (ucs-range->char-set 65520 65529) (ucs-range->char-set 65529 65532) (ucs-range->char-set 119155 119163) (ucs-range->char-set 917506 917536) (ucs-range->char-set 917536 917632) (ucs-range->char-set 917632 917760) (ucs-range->char-set 918000 921600)))) ;; Extend,SpacingMark (define char-set:extend-or-spacing-mark (immutable-char-set (char-set-union (char-set-union (ucs-range->char-set 768 880) (ucs-range->char-set 1155 1160) (ucs-range->char-set 1160 1162) (ucs-range->char-set 1425 1470) (ucs-range->char-set 1473 1475) (ucs-range->char-set 1476 1478) (ucs-range->char-set 1552 1563) (ucs-range->char-set 1611 1632) (ucs-range->char-set 1750 1757) (ucs-range->char-set 1759 1765) (ucs-range->char-set 1767 1769) (ucs-range->char-set 1770 1774) (ucs-range->char-set 1840 1867) (ucs-range->char-set 1958 1969) (ucs-range->char-set 2027 2036) (ucs-range->char-set 2070 2074) (ucs-range->char-set 2075 2084) (ucs-range->char-set 2085 2088) (ucs-range->char-set 2089 2094) (ucs-range->char-set 2137 2140) (ucs-range->char-set 2276 2303) (ucs-range->char-set 2304 2307) (ucs-range->char-set 2369 2377) (ucs-range->char-set 2385 2392) (ucs-range->char-set 2402 2404) (ucs-range->char-set 2497 2501) (ucs-range->char-set 2530 2532) (ucs-range->char-set 2561 2563) (ucs-range->char-set 2625 2627) (ucs-range->char-set 2631 2633) (ucs-range->char-set 2635 2638) (ucs-range->char-set 2672 2674) (ucs-range->char-set 2689 2691) (ucs-range->char-set 2753 2758) (ucs-range->char-set 2759 2761) (ucs-range->char-set 2786 2788) (ucs-range->char-set 2881 2885) (ucs-range->char-set 2914 2916) (ucs-range->char-set 3134 3137) (ucs-range->char-set 3142 3145) (ucs-range->char-set 3146 3150) (ucs-range->char-set 3157 3159) (ucs-range->char-set 3170 3172) (ucs-range->char-set 3276 3278) (ucs-range->char-set 3285 3287) (ucs-range->char-set 3298 3300) (ucs-range->char-set 3393 3397) (ucs-range->char-set 3426 3428) (ucs-range->char-set 3538 3541) (ucs-range->char-set 3636 3643) (ucs-range->char-set 3655 3663) (ucs-range->char-set 3764 3770) (ucs-range->char-set 3771 3773) (ucs-range->char-set 3784 3790) (ucs-range->char-set 3864 3866) (ucs-range->char-set 3953 3967) (ucs-range->char-set 3968 3973) (ucs-range->char-set 3974 3976) (ucs-range->char-set 3981 3992) (ucs-range->char-set 3993 4029) (ucs-range->char-set 4141 4145) (ucs-range->char-set 4146 4152) (ucs-range->char-set 4153 4155) (ucs-range->char-set 4157 4159) (ucs-range->char-set 4184 4186) (ucs-range->char-set 4190 4193) (ucs-range->char-set 4209 4213) (ucs-range->char-set 4229 4231) (ucs-range->char-set 4957 4960) (ucs-range->char-set 5906 5909) (ucs-range->char-set 5938 5941) (ucs-range->char-set 5970 5972) (ucs-range->char-set 6002 6004) (ucs-range->char-set 6068 6070) (ucs-range->char-set 6071 6078) (ucs-range->char-set 6089 6100) (ucs-range->char-set 6155 6158) (ucs-range->char-set 6432 6435) (ucs-range->char-set 6439 6441) (ucs-range->char-set 6457 6460) (ucs-range->char-set 6679 6681) (ucs-range->char-set 6744 6751) (ucs-range->char-set 6757 6765) (ucs-range->char-set 6771 6781) (ucs-range->char-set 6912 6916) (ucs-range->char-set 6966 6971) (ucs-range->char-set 7019 7028) (ucs-range->char-set 7040 7042) (ucs-range->char-set 7074 7078) (ucs-range->char-set 7080 7082) (ucs-range->char-set 7144 7146) (ucs-range->char-set 7151 7154) (ucs-range->char-set 7212 7220) (ucs-range->char-set 7222 7224) (ucs-range->char-set 7376 7379) (ucs-range->char-set 7380 7393) (ucs-range->char-set 7394 7401) (ucs-range->char-set 7616 7655) (ucs-range->char-set 7676 7680) (ucs-range->char-set 8204 8206) (ucs-range->char-set 8400 8413) (ucs-range->char-set 8413 8417) (ucs-range->char-set 8418 8421) (ucs-range->char-set 8421 8433) (ucs-range->char-set 11503 11506) (ucs-range->char-set 11744 11776) (ucs-range->char-set 12330 12334) (ucs-range->char-set 12334 12336) (ucs-range->char-set 12441 12443) (ucs-range->char-set 42608 42611) (ucs-range->char-set 42612 42622) (ucs-range->char-set 42736 42738) (ucs-range->char-set 43045 43047) (ucs-range->char-set 43232 43250) (ucs-range->char-set 43302 43310) (ucs-range->char-set 43335 43346) (ucs-range->char-set 43392 43395) (ucs-range->char-set 43446 43450) (ucs-range->char-set 43561 43567) (ucs-range->char-set 43569 43571) (ucs-range->char-set 43573 43575) (ucs-range->char-set 43698 43701) (ucs-range->char-set 43703 43705) (ucs-range->char-set 43710 43712) (ucs-range->char-set 43756 43758) (ucs-range->char-set 65024 65040) (ucs-range->char-set 65056 65063) (ucs-range->char-set 65438 65440) (ucs-range->char-set 68097 68100) (ucs-range->char-set 68101 68103) (ucs-range->char-set 68108 68112) (ucs-range->char-set 68152 68155) (ucs-range->char-set 69688 69703) (ucs-range->char-set 69760 69762) (ucs-range->char-set 69811 69815) (ucs-range->char-set 69817 69819) (ucs-range->char-set 69888 69891) (ucs-range->char-set 69927 69932) (ucs-range->char-set 69933 69941) (ucs-range->char-set 70016 70018) (ucs-range->char-set 70070 70079) (ucs-range->char-set 71344 71350) (ucs-range->char-set 94095 94099) (ucs-range->char-set 119143 119146) (ucs-range->char-set 119150 119155) (ucs-range->char-set 119163 119171) (ucs-range->char-set 119173 119180) (ucs-range->char-set 119210 119214) (ucs-range->char-set 119362 119365) (ucs-range->char-set 917760 918000)) (char-set-union (ucs-range->char-set 2366 2369) (ucs-range->char-set 2377 2381) (ucs-range->char-set 2382 2384) (ucs-range->char-set 2434 2436) (ucs-range->char-set 2495 2497) (ucs-range->char-set 2503 2505) (ucs-range->char-set 2507 2509) (ucs-range->char-set 2622 2625) (ucs-range->char-set 2750 2753) (ucs-range->char-set 2763 2765) (ucs-range->char-set 2818 2820) (ucs-range->char-set 2887 2889) (ucs-range->char-set 2891 2893) (ucs-range->char-set 3009 3011) (ucs-range->char-set 3014 3017) (ucs-range->char-set 3018 3021) (ucs-range->char-set 3073 3076) (ucs-range->char-set 3137 3141) (ucs-range->char-set 3202 3204) (ucs-range->char-set 3264 3266) (ucs-range->char-set 3267 3269) (ucs-range->char-set 3271 3273) (ucs-range->char-set 3274 3276) (ucs-range->char-set 3330 3332) (ucs-range->char-set 3391 3393) (ucs-range->char-set 3398 3401) (ucs-range->char-set 3402 3405) (ucs-range->char-set 3458 3460) (ucs-range->char-set 3536 3538) (ucs-range->char-set 3544 3551) (ucs-range->char-set 3570 3572) (ucs-range->char-set 3902 3904) (ucs-range->char-set 4155 4157) (ucs-range->char-set 4182 4184) (ucs-range->char-set 6078 6086) (ucs-range->char-set 6087 6089) (ucs-range->char-set 6435 6439) (ucs-range->char-set 6441 6444) (ucs-range->char-set 6448 6450) (ucs-range->char-set 6451 6457) (ucs-range->char-set 6581 6584) (ucs-range->char-set 6681 6683) (ucs-range->char-set 6765 6771) (ucs-range->char-set 6973 6978) (ucs-range->char-set 6979 6981) (ucs-range->char-set 7078 7080) (ucs-range->char-set 7084 7086) (ucs-range->char-set 7146 7149) (ucs-range->char-set 7154 7156) (ucs-range->char-set 7204 7212) (ucs-range->char-set 7220 7222) (ucs-range->char-set 7410 7412) (ucs-range->char-set 43043 43045) (ucs-range->char-set 43136 43138) (ucs-range->char-set 43188 43204) (ucs-range->char-set 43346 43348) (ucs-range->char-set 43444 43446) (ucs-range->char-set 43450 43452) (ucs-range->char-set 43453 43457) (ucs-range->char-set 43567 43569) (ucs-range->char-set 43571 43573) (ucs-range->char-set 43758 43760) (ucs-range->char-set 44003 44005) (ucs-range->char-set 44006 44008) (ucs-range->char-set 44009 44011) (ucs-range->char-set 69808 69811) (ucs-range->char-set 69815 69817) (ucs-range->char-set 70067 70070) (ucs-range->char-set 70079 70081) (ucs-range->char-set 71342 71344) (ucs-range->char-set 94033 94079))))) ;; Regional_Indicator (define char-set:regional-indicator (immutable-char-set (char-set-union (ucs-range->char-set 127462 127488)))) ;; :L (define char-set:hangul-l (immutable-char-set (char-set-union (ucs-range->char-set 4352 4448) (ucs-range->char-set 43360 43389)))) ;; :V (define char-set:hangul-v (immutable-char-set (char-set-union (ucs-range->char-set 4448 4520) (ucs-range->char-set 55216 55239)))) ;; :T (define char-set:hangul-t (immutable-char-set (char-set-union (ucs-range->char-set 4520 4608) (ucs-range->char-set 55243 55292)))) ;; :LV (define char-set:hangul-lv (immutable-char-set (char-set-union))) ;; :LVT (define char-set:hangul-lvt (immutable-char-set (char-set-union (ucs-range->char-set 44033 44060) (ucs-range->char-set 44061 44088) (ucs-range->char-set 44089 44116) (ucs-range->char-set 44117 44144) (ucs-range->char-set 44145 44172) (ucs-range->char-set 44173 44200) (ucs-range->char-set 44201 44228) (ucs-range->char-set 44229 44256) (ucs-range->char-set 44257 44284) (ucs-range->char-set 44285 44312) (ucs-range->char-set 44313 44340) (ucs-range->char-set 44341 44368) (ucs-range->char-set 44369 44396) (ucs-range->char-set 44397 44424) (ucs-range->char-set 44425 44452) (ucs-range->char-set 44453 44480) (ucs-range->char-set 44481 44508) (ucs-range->char-set 44509 44536) (ucs-range->char-set 44537 44564) (ucs-range->char-set 44565 44592) (ucs-range->char-set 44593 44620) (ucs-range->char-set 44621 44648) (ucs-range->char-set 44649 44676) (ucs-range->char-set 44677 44704) (ucs-range->char-set 44705 44732) (ucs-range->char-set 44733 44760) (ucs-range->char-set 44761 44788) (ucs-range->char-set 44789 44816) (ucs-range->char-set 44817 44844) (ucs-range->char-set 44845 44872) (ucs-range->char-set 44873 44900) (ucs-range->char-set 44901 44928) (ucs-range->char-set 44929 44956) (ucs-range->char-set 44957 44984) (ucs-range->char-set 44985 45012) (ucs-range->char-set 45013 45040) (ucs-range->char-set 45041 45068) (ucs-range->char-set 45069 45096) (ucs-range->char-set 45097 45124) (ucs-range->char-set 45125 45152) (ucs-range->char-set 45153 45180) (ucs-range->char-set 45181 45208) (ucs-range->char-set 45209 45236) (ucs-range->char-set 45237 45264) (ucs-range->char-set 45265 45292) (ucs-range->char-set 45293 45320) (ucs-range->char-set 45321 45348) (ucs-range->char-set 45349 45376) (ucs-range->char-set 45377 45404) (ucs-range->char-set 45405 45432) (ucs-range->char-set 45433 45460) (ucs-range->char-set 45461 45488) (ucs-range->char-set 45489 45516) (ucs-range->char-set 45517 45544) (ucs-range->char-set 45545 45572) (ucs-range->char-set 45573 45600) (ucs-range->char-set 45601 45628) (ucs-range->char-set 45629 45656) (ucs-range->char-set 45657 45684) (ucs-range->char-set 45685 45712) (ucs-range->char-set 45713 45740) (ucs-range->char-set 45741 45768) (ucs-range->char-set 45769 45796) (ucs-range->char-set 45797 45824) (ucs-range->char-set 45825 45852) (ucs-range->char-set 45853 45880) (ucs-range->char-set 45881 45908) (ucs-range->char-set 45909 45936) (ucs-range->char-set 45937 45964) (ucs-range->char-set 45965 45992) (ucs-range->char-set 45993 46020) (ucs-range->char-set 46021 46048) (ucs-range->char-set 46049 46076) (ucs-range->char-set 46077 46104) (ucs-range->char-set 46105 46132) (ucs-range->char-set 46133 46160) (ucs-range->char-set 46161 46188) (ucs-range->char-set 46189 46216) (ucs-range->char-set 46217 46244) (ucs-range->char-set 46245 46272) (ucs-range->char-set 46273 46300) (ucs-range->char-set 46301 46328) (ucs-range->char-set 46329 46356) (ucs-range->char-set 46357 46384) (ucs-range->char-set 46385 46412) (ucs-range->char-set 46413 46440) (ucs-range->char-set 46441 46468) (ucs-range->char-set 46469 46496) (ucs-range->char-set 46497 46524) (ucs-range->char-set 46525 46552) (ucs-range->char-set 46553 46580) (ucs-range->char-set 46581 46608) (ucs-range->char-set 46609 46636) (ucs-range->char-set 46637 46664) (ucs-range->char-set 46665 46692) (ucs-range->char-set 46693 46720) (ucs-range->char-set 46721 46748) (ucs-range->char-set 46749 46776) (ucs-range->char-set 46777 46804) (ucs-range->char-set 46805 46832) (ucs-range->char-set 46833 46860) (ucs-range->char-set 46861 46888) (ucs-range->char-set 46889 46916) (ucs-range->char-set 46917 46944) (ucs-range->char-set 46945 46972) (ucs-range->char-set 46973 47000) (ucs-range->char-set 47001 47028) (ucs-range->char-set 47029 47056) (ucs-range->char-set 47057 47084) (ucs-range->char-set 47085 47112) (ucs-range->char-set 47113 47140) (ucs-range->char-set 47141 47168) (ucs-range->char-set 47169 47196) (ucs-range->char-set 47197 47224) (ucs-range->char-set 47225 47252) (ucs-range->char-set 47253 47280) (ucs-range->char-set 47281 47308) (ucs-range->char-set 47309 47336) (ucs-range->char-set 47337 47364) (ucs-range->char-set 47365 47392) (ucs-range->char-set 47393 47420) (ucs-range->char-set 47421 47448) (ucs-range->char-set 47449 47476) (ucs-range->char-set 47477 47504) (ucs-range->char-set 47505 47532) (ucs-range->char-set 47533 47560) (ucs-range->char-set 47561 47588) (ucs-range->char-set 47589 47616) (ucs-range->char-set 47617 47644) (ucs-range->char-set 47645 47672) (ucs-range->char-set 47673 47700) (ucs-range->char-set 47701 47728) (ucs-range->char-set 47729 47756) (ucs-range->char-set 47757 47784) (ucs-range->char-set 47785 47812) (ucs-range->char-set 47813 47840) (ucs-range->char-set 47841 47868) (ucs-range->char-set 47869 47896) (ucs-range->char-set 47897 47924) (ucs-range->char-set 47925 47952) (ucs-range->char-set 47953 47980) (ucs-range->char-set 47981 48008) (ucs-range->char-set 48009 48036) (ucs-range->char-set 48037 48064) (ucs-range->char-set 48065 48092) (ucs-range->char-set 48093 48120) (ucs-range->char-set 48121 48148) (ucs-range->char-set 48149 48176) (ucs-range->char-set 48177 48204) (ucs-range->char-set 48205 48232) (ucs-range->char-set 48233 48260) (ucs-range->char-set 48261 48288) (ucs-range->char-set 48289 48316) (ucs-range->char-set 48317 48344) (ucs-range->char-set 48345 48372) (ucs-range->char-set 48373 48400) (ucs-range->char-set 48401 48428) (ucs-range->char-set 48429 48456) (ucs-range->char-set 48457 48484) (ucs-range->char-set 48485 48512) (ucs-range->char-set 48513 48540) (ucs-range->char-set 48541 48568) (ucs-range->char-set 48569 48596) (ucs-range->char-set 48597 48624) (ucs-range->char-set 48625 48652) (ucs-range->char-set 48653 48680) (ucs-range->char-set 48681 48708) (ucs-range->char-set 48709 48736) (ucs-range->char-set 48737 48764) (ucs-range->char-set 48765 48792) (ucs-range->char-set 48793 48820) (ucs-range->char-set 48821 48848) (ucs-range->char-set 48849 48876) (ucs-range->char-set 48877 48904) (ucs-range->char-set 48905 48932) (ucs-range->char-set 48933 48960) (ucs-range->char-set 48961 48988) (ucs-range->char-set 48989 49016) (ucs-range->char-set 49017 49044) (ucs-range->char-set 49045 49072) (ucs-range->char-set 49073 49100) (ucs-range->char-set 49101 49128) (ucs-range->char-set 49129 49156) (ucs-range->char-set 49157 49184) (ucs-range->char-set 49185 49212) (ucs-range->char-set 49213 49240) (ucs-range->char-set 49241 49268) (ucs-range->char-set 49269 49296) (ucs-range->char-set 49297 49324) (ucs-range->char-set 49325 49352) (ucs-range->char-set 49353 49380) (ucs-range->char-set 49381 49408) (ucs-range->char-set 49409 49436) (ucs-range->char-set 49437 49464) (ucs-range->char-set 49465 49492) (ucs-range->char-set 49493 49520) (ucs-range->char-set 49521 49548) (ucs-range->char-set 49549 49576) (ucs-range->char-set 49577 49604) (ucs-range->char-set 49605 49632) (ucs-range->char-set 49633 49660) (ucs-range->char-set 49661 49688) (ucs-range->char-set 49689 49716) (ucs-range->char-set 49717 49744) (ucs-range->char-set 49745 49772) (ucs-range->char-set 49773 49800) (ucs-range->char-set 49801 49828) (ucs-range->char-set 49829 49856) (ucs-range->char-set 49857 49884) (ucs-range->char-set 49885 49912) (ucs-range->char-set 49913 49940) (ucs-range->char-set 49941 49968) (ucs-range->char-set 49969 49996) (ucs-range->char-set 49997 50024) (ucs-range->char-set 50025 50052) (ucs-range->char-set 50053 50080) (ucs-range->char-set 50081 50108) (ucs-range->char-set 50109 50136) (ucs-range->char-set 50137 50164) (ucs-range->char-set 50165 50192) (ucs-range->char-set 50193 50220) (ucs-range->char-set 50221 50248) (ucs-range->char-set 50249 50276) (ucs-range->char-set 50277 50304) (ucs-range->char-set 50305 50332) (ucs-range->char-set 50333 50360) (ucs-range->char-set 50361 50388) (ucs-range->char-set 50389 50416) (ucs-range->char-set 50417 50444) (ucs-range->char-set 50445 50472) (ucs-range->char-set 50473 50500) (ucs-range->char-set 50501 50528) (ucs-range->char-set 50529 50556) (ucs-range->char-set 50557 50584) (ucs-range->char-set 50585 50612) (ucs-range->char-set 50613 50640) (ucs-range->char-set 50641 50668) (ucs-range->char-set 50669 50696) (ucs-range->char-set 50697 50724) (ucs-range->char-set 50725 50752) (ucs-range->char-set 50753 50780) (ucs-range->char-set 50781 50808) (ucs-range->char-set 50809 50836) (ucs-range->char-set 50837 50864) (ucs-range->char-set 50865 50892) (ucs-range->char-set 50893 50920) (ucs-range->char-set 50921 50948) (ucs-range->char-set 50949 50976) (ucs-range->char-set 50977 51004) (ucs-range->char-set 51005 51032) (ucs-range->char-set 51033 51060) (ucs-range->char-set 51061 51088) (ucs-range->char-set 51089 51116) (ucs-range->char-set 51117 51144) (ucs-range->char-set 51145 51172) (ucs-range->char-set 51173 51200) (ucs-range->char-set 51201 51228) (ucs-range->char-set 51229 51256) (ucs-range->char-set 51257 51284) (ucs-range->char-set 51285 51312) (ucs-range->char-set 51313 51340) (ucs-range->char-set 51341 51368) (ucs-range->char-set 51369 51396) (ucs-range->char-set 51397 51424) (ucs-range->char-set 51425 51452) (ucs-range->char-set 51453 51480) (ucs-range->char-set 51481 51508) (ucs-range->char-set 51509 51536) (ucs-range->char-set 51537 51564) (ucs-range->char-set 51565 51592) (ucs-range->char-set 51593 51620) (ucs-range->char-set 51621 51648) (ucs-range->char-set 51649 51676) (ucs-range->char-set 51677 51704) (ucs-range->char-set 51705 51732) (ucs-range->char-set 51733 51760) (ucs-range->char-set 51761 51788) (ucs-range->char-set 51789 51816) (ucs-range->char-set 51817 51844) (ucs-range->char-set 51845 51872) (ucs-range->char-set 51873 51900) (ucs-range->char-set 51901 51928) (ucs-range->char-set 51929 51956) (ucs-range->char-set 51957 51984) (ucs-range->char-set 51985 52012) (ucs-range->char-set 52013 52040) (ucs-range->char-set 52041 52068) (ucs-range->char-set 52069 52096) (ucs-range->char-set 52097 52124) (ucs-range->char-set 52125 52152) (ucs-range->char-set 52153 52180) (ucs-range->char-set 52181 52208) (ucs-range->char-set 52209 52236) (ucs-range->char-set 52237 52264) (ucs-range->char-set 52265 52292) (ucs-range->char-set 52293 52320) (ucs-range->char-set 52321 52348) (ucs-range->char-set 52349 52376) (ucs-range->char-set 52377 52404) (ucs-range->char-set 52405 52432) (ucs-range->char-set 52433 52460) (ucs-range->char-set 52461 52488) (ucs-range->char-set 52489 52516) (ucs-range->char-set 52517 52544) (ucs-range->char-set 52545 52572) (ucs-range->char-set 52573 52600) (ucs-range->char-set 52601 52628) (ucs-range->char-set 52629 52656) (ucs-range->char-set 52657 52684) (ucs-range->char-set 52685 52712) (ucs-range->char-set 52713 52740) (ucs-range->char-set 52741 52768) (ucs-range->char-set 52769 52796) (ucs-range->char-set 52797 52824) (ucs-range->char-set 52825 52852) (ucs-range->char-set 52853 52880) (ucs-range->char-set 52881 52908) (ucs-range->char-set 52909 52936) (ucs-range->char-set 52937 52964) (ucs-range->char-set 52965 52992) (ucs-range->char-set 52993 53020) (ucs-range->char-set 53021 53048) (ucs-range->char-set 53049 53076) (ucs-range->char-set 53077 53104) (ucs-range->char-set 53105 53132) (ucs-range->char-set 53133 53160) (ucs-range->char-set 53161 53188) (ucs-range->char-set 53189 53216) (ucs-range->char-set 53217 53244) (ucs-range->char-set 53245 53272) (ucs-range->char-set 53273 53300) (ucs-range->char-set 53301 53328) (ucs-range->char-set 53329 53356) (ucs-range->char-set 53357 53384) (ucs-range->char-set 53385 53412) (ucs-range->char-set 53413 53440) (ucs-range->char-set 53441 53468) (ucs-range->char-set 53469 53496) (ucs-range->char-set 53497 53524) (ucs-range->char-set 53525 53552) (ucs-range->char-set 53553 53580) (ucs-range->char-set 53581 53608) (ucs-range->char-set 53609 53636) (ucs-range->char-set 53637 53664) (ucs-range->char-set 53665 53692) (ucs-range->char-set 53693 53720) (ucs-range->char-set 53721 53748) (ucs-range->char-set 53749 53776) (ucs-range->char-set 53777 53804) (ucs-range->char-set 53805 53832) (ucs-range->char-set 53833 53860) (ucs-range->char-set 53861 53888) (ucs-range->char-set 53889 53916) (ucs-range->char-set 53917 53944) (ucs-range->char-set 53945 53972) (ucs-range->char-set 53973 54000) (ucs-range->char-set 54001 54028) (ucs-range->char-set 54029 54056) (ucs-range->char-set 54057 54084) (ucs-range->char-set 54085 54112) (ucs-range->char-set 54113 54140) (ucs-range->char-set 54141 54168) (ucs-range->char-set 54169 54196) (ucs-range->char-set 54197 54224) (ucs-range->char-set 54225 54252) (ucs-range->char-set 54253 54280) (ucs-range->char-set 54281 54308) (ucs-range->char-set 54309 54336) (ucs-range->char-set 54337 54364) (ucs-range->char-set 54365 54392) (ucs-range->char-set 54393 54420) (ucs-range->char-set 54421 54448) (ucs-range->char-set 54449 54476) (ucs-range->char-set 54477 54504) (ucs-range->char-set 54505 54532) (ucs-range->char-set 54533 54560) (ucs-range->char-set 54561 54588) (ucs-range->char-set 54589 54616) (ucs-range->char-set 54617 54644) (ucs-range->char-set 54645 54672) (ucs-range->char-set 54673 54700) (ucs-range->char-set 54701 54728) (ucs-range->char-set 54729 54756) (ucs-range->char-set 54757 54784) (ucs-range->char-set 54785 54812) (ucs-range->char-set 54813 54840) (ucs-range->char-set 54841 54868) (ucs-range->char-set 54869 54896) (ucs-range->char-set 54897 54924) (ucs-range->char-set 54925 54952) (ucs-range->char-set 54953 54980) (ucs-range->char-set 54981 55008) (ucs-range->char-set 55009 55036) (ucs-range->char-set 55037 55064) (ucs-range->char-set 55065 55092) (ucs-range->char-set 55093 55120) (ucs-range->char-set 55121 55148) (ucs-range->char-set 55149 55176) (ucs-range->char-set 55177 55204)))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a115/regexp/boundary.sls000066400000000000000000000020041375154206600233550ustar00rootroot00000000000000;; Character sets for Unicode boundaries, TR29. ;; This code is written by Alex Shinn and placed in the ;; Public Domain. All warranties are disclaimed. ;;> Char-sets used for ;;> \hyperlink["http://unicode.org/reports/tr29/"]{TR29} word ;;> boundaries. ;; Converted from lib/chibi/char-set/boundary.sld to R6RS by Göran Weinholt. (library (srfi :115 regexp boundary) (export char-set:regional-indicator char-set:extend-or-spacing-mark char-set:hangul-l char-set:hangul-v char-set:hangul-t char-set:hangul-lv char-set:hangul-lvt) (import (rnrs) (srfi :14 char-sets) (srfi private include)) (define (immutable-char-set cs) cs) ;; generated with: ;; tools/extract-unicode-props.scm --derived GraphemeBreakProperty.txt ;; Control extend-or-spacing-mark=Extend,SpacingMark Regional_Indicator ;; hangul-l=:L hangul-v=:V hangul-t=:T hangul-lv=:LV hangul-lvt=:LVT (include/resolve ("srfi" "%3a115" "regexp") "boundary-impl.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a117.sls000066400000000000000000000010361375154206600202460ustar00rootroot00000000000000#!r6rs (library (srfi :117) (export make-list-queue list-queue list-queue-copy list-queue-unfold list-queue-unfold-right list-queue? list-queue-empty? list-queue-front list-queue-back list-queue-list list-queue-first-last list-queue-add-front! list-queue-add-back! list-queue-remove-front! list-queue-remove-back! list-queue-remove-all! list-queue-set-list! list-queue-append list-queue-append! list-queue-concatenate list-queue-map list-queue-map! list-queue-for-each ) (import (srfi :117 list-queues)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a117/000077500000000000000000000000001375154206600175235ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a117/list-queues-impl.scm000066400000000000000000000167201375154206600234540ustar00rootroot00000000000000;;;; Implementation of list-queue SRFI ;;;; ;;;; Copyright (C) John Cowan (2015, 2016). All Rights Reserved. ;;;; ;;;; Permission is hereby granted, free of charge, to any person obtaining a copy of ;;;; this software and associated documentation files (the "Software"), to deal in ;;;; the Software without restriction, including without limitation the rights to ;;;; use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies ;;;; of the Software, and to permit persons to whom the Software is furnished to do ;;;; so, subject to the following conditions: ;;;; ;;;; The above copyright notice and this permission notice shall be included in all ;;;; copies or substantial portions of the Software. ;;;; ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, ;;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;;;; SOFTWARE. ;;;; Later modified from the R7RS SRFI-117 reference implementation for ;;;; possible inclusion within the R6RS https://github.com/arcfide/chez-srfi. ;;; R7RS shims. Comment these out on an R7RS system. ;;; [John Cowan] stole this code from Chibi Scheme, which is BSD-licensed. (define (make-list n . o) (let ((default (if (pair? o) (car o)))) (let lp ((n n) (res '())) (if (<= n 0) res (lp (- n 1) (cons default res)))))) (define (list-copy ls) (let lp ((ls ls) (res '())) (if (pair? ls) (lp (cdr ls) (cons (car ls) res)) (append (reverse res) ls)))) (define (list-set! ls k x) (cond ((null? ls) (error "invalid list index")) ((zero? k) (set-car! ls x)) (else (list-set! (cdr ls) (- k 1) x)))) ;;; This definition is from Chibi's SRFI-1 implementation. (define (last-pair ls) (if (null? (cdr ls)) ls (last-pair (cdr ls)))) ;;; This definition of map! isn't fully SRFI-1 compliant, as it ;;; handles only unary functions. You can use SRFI-1's definition ;;; if you want. (define (map! f lis) (let lp ((lis lis)) (if (pair? lis) (begin (set-car! lis (f (car lis))) (lp (cdr lis)))))) ;;; The list-queue record ;;; The invariant is that either first is (the first pair of) a list ;;; and last is the last pair, or both of them are the empty list. (define-record-type ( raw-make-list-queue list-queue?) (fields (mutable first get-first set-first!) (mutable last get-last set-last!))) ;;; Constructors (define make-list-queue (case-lambda ((list) (if (null? list) (raw-make-list-queue '() '()) (raw-make-list-queue list (last-pair list)))) ((list last) (raw-make-list-queue list last)))) (define (list-queue . objs) (make-list-queue objs)) (define (list-queue-copy list-queue) (make-list-queue (list-copy (get-first list-queue)))) ;;; Predicates (define (list-queue-empty? list-queue) (null? (get-first list-queue))) ;;; Accessors (define (list-queue-front list-queue) (if (list-queue-empty? list-queue) (error "Empty list-queue") (car (get-first list-queue)))) (define (list-queue-back list-queue) (if (list-queue-empty? list-queue) (error "Empty list-queue") (car (get-last list-queue)))) ;;; Mutators (which carefully maintain the invariant) (define (list-queue-add-front! list-queue elem) (let ((new-first (cons elem (get-first list-queue)))) (if (list-queue-empty? list-queue) (set-last! list-queue new-first)) (set-first! list-queue new-first))) (define (list-queue-add-back! list-queue elem) (let ((new-last (list elem))) (if (list-queue-empty? list-queue) (set-first! list-queue new-last) (set-cdr! (get-last list-queue) new-last)) (set-last! list-queue new-last))) (define (list-queue-remove-front! list-queue) (if (list-queue-empty? list-queue) (error "Empty list-queue")) (let* ((old-first (get-first list-queue)) (elem (car old-first)) (new-first (cdr old-first))) (if (null? new-first) (set-last! list-queue '())) (set-first! list-queue new-first) elem)) (define (list-queue-remove-back! list-queue) (if (list-queue-empty? list-queue) (error "Empty list-queue")) (let* ((old-last (get-last list-queue)) (elem (car old-last)) (new-last (penult-pair (get-first list-queue)))) (if (null? new-last) (set-first! list-queue '()) (set-cdr! new-last '())) (set-last! list-queue new-last) elem)) (define (list-queue-remove-all! list-queue) (let ((result (get-first list-queue))) (set-first! list-queue '()) (set-last! list-queue '()) result)) ;; Return the next to last pair of lis, or nil if there is none (define (penult-pair lis) (let lp ((lis lis)) (cond ;((null? lis) (error "Empty list-queue")) ((null? (cdr lis)) '()) ((null? (cddr lis)) lis) (else (lp (cdr lis)))))) ;;; The whole list-queue ;; Because append does not copy its back argument, we cannot use it (define (list-queue-append . list-queues) (list-queue-concatenate list-queues)) (define (list-queue-concatenate list-queues) (let ((result (list-queue))) (for-each (lambda (list-queue) (for-each (lambda (elem) (list-queue-add-back! result elem)) (get-first list-queue))) list-queues) result)) (define list-queue-append! (case-lambda (() (list-queue)) ((queue) queue) (queues (for-each (lambda (queue) (list-queue-join! (car queues) queue)) (cdr queues)) (car queues)))) ; Forcibly join two queues, destroying the second (define (list-queue-join! queue1 queue2) (set-cdr! (get-last queue1) (get-first queue2))) (define (list-queue-map proc list-queue) (make-list-queue (map proc (get-first list-queue)))) (define list-queue-unfold (case-lambda ((stop? mapper successor seed queue) (list-queue-unfold* stop? mapper successor seed queue)) ((stop? mapper successor seed) (list-queue-unfold* stop? mapper successor seed (list-queue))))) (define (list-queue-unfold* stop? mapper successor seed queue) (let loop ((seed seed)) (if (not (stop? seed)) (list-queue-add-front! (loop (successor seed)) (mapper seed))) queue)) (define list-queue-unfold-right (case-lambda ((stop? mapper successor seed queue) (list-queue-unfold-right* stop? mapper successor seed queue)) ((stop? mapper successor seed) (list-queue-unfold-right* stop? mapper successor seed (list-queue))))) (define (list-queue-unfold-right* stop? mapper successor seed queue) (let loop ((seed seed)) (if (not (stop? seed)) (list-queue-add-back! (loop (successor seed)) (mapper seed))) queue)) (define (list-queue-map! proc list-queue) (map! proc (get-first list-queue))) (define (list-queue-for-each proc list-queue) (for-each proc (get-first list-queue))) ;;; Conversion (define (list-queue-list list-queue) (get-first list-queue)) (define (list-queue-first-last list-queue) (values (get-first list-queue) (get-last list-queue))) (define list-queue-set-list! (case-lambda ((list-queue first) (set-first! list-queue first) (if (null? first) (set-last! list-queue '()) (set-last! list-queue (last-pair first)))) ((list-queue first last) (set-first! list-queue first) (set-last! list-queue last)))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a117/list-queues.sls000066400000000000000000000013411375154206600225250ustar00rootroot00000000000000(library (srfi :117 list-queues) (export make-list-queue list-queue list-queue-copy list-queue-unfold list-queue-unfold-right list-queue? list-queue-empty? list-queue-front list-queue-back list-queue-list list-queue-first-last list-queue-add-front! list-queue-add-back! list-queue-remove-front! list-queue-remove-back! list-queue-remove-all! list-queue-set-list! list-queue-append list-queue-append! list-queue-concatenate list-queue-map list-queue-map! list-queue-for-each) (import (only (srfi :23) error) (except (rnrs base) error) (rnrs control) (rnrs mutable-pairs) (rnrs records syntactic) (srfi private include)) (include/resolve ("srfi" "%3a117") "list-queues-impl.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a125.sls000066400000000000000000000021611375154206600202450ustar00rootroot00000000000000(library (srfi :125) (export make-hash-table hash-table hash-table-unfold alist->hash-table hash-table? hash-table-contains? hash-table-empty? hash-table=? hash-table-mutable? hash-table-ref hash-table-ref/default hash-table-set! hash-table-delete! hash-table-intern! hash-table-update! hash-table-update!/default hash-table-pop! hash-table-clear! hash-table-size hash-table-keys hash-table-values hash-table-entries hash-table-find hash-table-count hash-table-map hash-table-for-each hash-table-map! hash-table-map->list hash-table-fold hash-table-prune! hash-table-copy hash-table-empty-copy hash-table->alist hash-table-union! hash-table-intersection! hash-table-difference! hash-table-xor! ;; The following procedures are deprecated by SRFI 125: deprecated:hash deprecated:string-hash deprecated:string-ci-hash deprecated:hash-by-identity deprecated:hash-table-equivalence-function deprecated:hash-table-hash-function deprecated:hash-table-exists? deprecated:hash-table-walk deprecated:hash-table-merge!) (import (srfi :125 hashtables))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a125/000077500000000000000000000000001375154206600175225ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a125/125.body.scm000066400000000000000000000465761375154206600215130ustar00rootroot00000000000000;;; Copyright 2015 William D Clinger. ;;; ;;; Permission to copy this software, in whole or in part, to use this ;;; software for any lawful purpose, and to redistribute this software ;;; is granted subject to the restriction that all copies made of this ;;; software must include this copyright and permission notice in full. ;;; ;;; I also request that you send me a copy of any improvements that you ;;; make to this software so that they may be incorporated within it to ;;; the benefit of the Scheme community. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Private stuff, not exported. ;;; Ten of the SRFI 125 procedures are deprecated, and another ;;; two allow alternative arguments that are deprecated. (define (issue-deprecated-warnings?) #t) (define (issue-warning-deprecated name-of-deprecated-misfeature) (if (not (memq name-of-deprecated-misfeature already-warned)) (begin (set! already-warned (cons name-of-deprecated-misfeature already-warned)) (if (issue-deprecated-warnings?) (let ((out (current-error-port))) (display "WARNING: " out) (display name-of-deprecated-misfeature out) (newline out) (display " is deprecated by SRFI 125. See" out) (newline out) (display " " out) (display url:deprecated out) (newline out)))))) (define url:deprecated "http://srfi.schemers.org/srfi-125/srfi-125.html") ; List of deprecated features for which a warning has already ; been issued. (define already-warned '()) ;;; Comparators contain a type test predicate, which implementations ;;; of the hash-table-set! procedure can use to reject invalid keys. ;;; That's hard to do without sacrificing interoperability with R6RS ;;; and/or SRFI 69 and/or SRFI 126 hash tables. ;;; ;;; Full interoperability means the hash tables implemented here are ;;; interchangeable with the SRFI 126 hashtables used to implement them. ;;; SRFI 69 and R6RS and SRFI 126 hashtables don't contain comparators, ;;; so any association between a hash table and its comparator would have ;;; to be maintained outside the representation of hash tables themselves, ;;; which is problematic unless weak pointers are available. ;;; ;;; Not all of the hash tables implemented here will have comparators ;;; associated with them anyway, because an equivalence procedure ;;; and hash function can be used to create a hash table instead of ;;; a comparator (although that usage is deprecated by SRFI 125). ;;; ;;; One way to preserve interoperability while enforcing a comparator's ;;; type test is to incorporate that test into a hash table's hash ;;; function. The advantage of doing that should be weighed against ;;; these disadvantages: ;;; ;;; If the type test is slow, then hashing would also be slower. ;;; ;;; The R6RS, SRFI 69, and SRFI 126 APIs allow extraction of ;;; a hash function from some hash tables. ;;; Some programmers might expect that hash function to be the ;;; hash function encapsulated by the comparator (in the sense ;;; of eq?, perhaps) even though this API makes no such guarantee ;;; (and extraction of that hash function from an existing hash ;;; table can only be done by calling a deprecated procedure). ;;; If %enforce-comparator-type-tests is true, then make-hash-table, ;;; when passed a comparator, will use a hash function that enforces ;;; the comparator's type test. (define %enforce-comparator-type-tests #t) ;;; Given a comparator, return its hash function, possibly augmented ;;; by the comparator's type test. (define (%comparator-hash-function comparator) (let ((okay? (comparator-type-test-predicate comparator)) (hash-function (comparator-hash-function comparator))) (if %enforce-comparator-type-tests (lambda (x . rest) (cond ((not (okay? x)) (error #f "key rejected by hash-table comparator" x comparator)) ((null? rest) (hash-function x)) (else (apply hash-function x rest)))) hash-function))) ;;; A unique (in the sense of eq?) value that will never be found ;;; within a hash-table. (define %not-found (list '%not-found)) ;;; A unique (in the sense of eq?) value that escapes only as an irritant ;;; when a hash-table key is not found. (define %not-found-irritant (list 'not-found)) ;;; The error message used when a hash-table key is not found. (define %not-found-message "hash-table key not found") ;;; We let SRFI 126 decide which weakness is supported (define (%check-optional-arguments procname args) (if (memq 'thread-safe args) (error (string-append (symbol->string procname) ": unsupported optional argument(s)") args))) (define (%get-hash-table-weakness args) (cond ((memq 'ephemeral-values args) (if (or (memq 'ephemeral-keys args) (memq 'weak-keys args)) 'ephemeral-key-and-value 'ephemeral-value)) ((memq 'ephemeral-keys args) (if (memq 'weak-values args) 'ephemeral-key-and-value 'ephemeral-key)) ((memq 'weak-keys args) (if (memq 'weak-values args) 'weak-key-and-value 'weak-key)) ((memq 'weak-values args) 'weak-value) (else #f))) (define (%get-hash-table-capacity args) (find fixnum? args)) ;;; This was exported by an earlier draft of SRFI 125, ;;; and is still used by hash-table=? (define (hash-table-every proc ht) (call-with-values (lambda () (hashtable-entries ht)) (lambda (keys vals) (let ((size (vector-length keys))) (let loop ((i 0)) (or (fx>=? i size) (let* ((key (vector-ref keys i)) (val (vector-ref vals i))) (and (proc key val) (loop (fx+ i 1)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Exported procedures ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Constructors. ;;; The first argument can be a comparator or an equality predicate. ;;; ;;; If the first argument is a comparator, any remaining arguments ;;; are implementation-dependent, but a non-negative exact integer ;;; should be interpreted as an initial capacity and the symbols ;;; thread-safe, weak-keys, ephemeral-keys, weak-values, and ;;; emphemeral-values should be interpreted specially. (These ;;; special symbols are distinct from the analogous special symbols ;;; in SRFI 126.) ;;; ;;; If the first argument is not a comparator, then it had better ;;; be an equality predicate (which is deprecated by SRFI 125). ;;; If a second argument is present and is a procedure, then it's ;;; a hash function (which is allowed only for the deprecated case ;;; in which the first argument is an equality predicate). If a ;;; second argument is not a procedure, then it's some kind of ;;; implementation-dependent optional argument, as are all arguments ;;; beyond the second. ;;; ;;; SRFI 128 defines make-eq-comparator, make-eqv-comparator, and ;;; make-equal-comparator procedures whose hash function is the ;;; default-hash procedure of SRFI 128, which is inappropriate ;;; for use with eq? and eqv? unless the object being hashed is ;;; never mutated. Neither SRFI 125 nor 128 provide any way to ;;; define a comparator whose hash function is truly compatible ;;; with the use of eq? or eqv? as an equality predicate. ;;; ;;; That would make SRFI 125 almost as bad as SRFI 69 if not for ;;; the following paragraph of SRFI 125: ;;; ;;; Implementations are permitted to ignore user-specified ;;; hash functions in certain circumstances. Specifically, ;;; if the equality predicate, whether passed as part of a ;;; comparator or explicitly, is more fine-grained (in the ;;; sense of R7RS-small section 6.1) than equal?, the ;;; implementation is free — indeed, is encouraged — to ;;; ignore the user-specified hash function and use something ;;; implementation-dependent. This allows the use of addresses ;;; as hashes, in which case the keys must be rehashed if ;;; they are moved by the garbage collector. Such a hash ;;; function is unsafe to use outside the context of ;;; implementation-provided hash tables. It can of course be ;;; exposed by an implementation as an extension, with ;;; suitable warnings against inappropriate uses. ;;; ;;; That gives implementations permission to do something more ;;; useful, but when should implementations take advantage of ;;; that permission? This implementation uses the superior ;;; solution provided by SRFI 126 whenever: ;;; ;;; A comparator is passed as first argument and its equality ;;; predicate is eq? or eqv?. ;;; ;;; The eq? or eqv? procedure is passed as first argument ;;; (which is a deprecated usage). (define (make-hash-table comparator/equiv . rest) (if (comparator? comparator/equiv) (let ((equiv (comparator-equality-predicate comparator/equiv)) (hash-function (%comparator-hash-function comparator/equiv))) (%make-hash-table equiv hash-function rest)) (let* ((equiv comparator/equiv) (hash-function (if (and (not (null? rest)) (procedure? (car rest))) (car rest) #f)) (rest (if hash-function (cdr rest) rest))) (issue-warning-deprecated 'srfi-69-style:make-hash-table) (%make-hash-table equiv hash-function rest)))) (define (%make-hash-table equiv hash-function opts) (%check-optional-arguments 'make-hash-table opts) (let ((weakness (%get-hash-table-weakness opts)) (capacity (%get-hash-table-capacity opts))) ;; Use SRFI :126 make-hashtable to handle capacity and weakness (cond ((equal? equiv eq?) (make-eq-hashtable capacity weakness)) ((equal? equiv eqv?) (make-eqv-hashtable capacity weakness)) (hash-function (make-hashtable hash-function equiv capacity weakness)) ((equal? equiv equal?) (make-hashtable equal-hash equiv capacity weakness)) ((equal? equiv string=?) (make-hashtable string-hash equiv capacity weakness)) ((equal? equiv string-ci=?) (make-hashtable string-ci-hash equiv capacity weakness)) ((equal? equiv symbol=?) (make-hashtable symbol-hash equiv capacity weakness)) (else (error "make-hash-table: unable to infer hash function" equiv))))) (define (hash-table comparator . rest) (let ((ht (apply make-hash-table comparator rest))) (let loop ((kvs rest)) (cond ((null? kvs) #f) ((null? (cdr kvs)) (error #f "hash-table: wrong number of arguments")) ((hashtable-contains? ht (car kvs)) (error "hash-table: two equivalent keys were provided" (car kvs))) (else (hashtable-set! ht (car kvs) (cadr kvs)) (loop (cddr kvs))))) (hash-table-copy ht #f))) (define (hash-table-unfold stop? mapper successor seed comparator . rest) (let ((ht (apply make-hash-table comparator rest))) (let loop ((seed seed)) (if (stop? seed) ht (call-with-values (lambda () (mapper seed)) (lambda (key val) (hash-table-set! ht key val) (loop (successor seed)))))))) (define (alist->hash-table alist comparator/equiv . rest) (if (and (not (null? rest)) (procedure? (car rest))) (issue-warning-deprecated 'srfi-69-style:alist->hash-table)) (let ((ht (apply make-hash-table comparator/equiv rest)) (entries (reverse alist))) (for-each (lambda (entry) (hash-table-set! ht (car entry) (cdr entry))) entries) ht)) ;;; Predicates. ;; (define (hash-table? obj) ;; (hashtable? obj)) ;; (define (hash-table-contains? ht key) ;; (hashtable-contains? ht key)) ;; (define (hash-table-empty? ht) ;; (hashtable-empty? ht)) (define (hash-table=? value-comparator ht1 ht2) (let ((val=? (comparator-equality-predicate value-comparator)) (n1 (hash-table-size ht1)) (n2 (hash-table-size ht2))) (and (= n1 n2) (eq? (hashtable-equivalence-function ht1) (hashtable-equivalence-function ht2)) (hash-table-every (lambda (key val1) (and (hash-table-contains? ht2 key) (val=? val1 (hashtable-ref ht2 key 'ignored)))) ht1)))) (define (hash-table-mutable? ht) (hashtable-mutable? ht)) ;;; Accessors. (define hash-table-ref (case-lambda ((ht key) (hashtable-ref ht key)) ((ht key failure) (let ((val (hashtable-ref ht key %not-found))) (if (eq? val %not-found) (failure) val))) ((ht key failure success) (let ((val (hashtable-ref ht key %not-found))) (if (eq? val %not-found) (failure) (success val)))))) (define (hash-table-ref/default ht key default) (hashtable-ref ht key default)) ;;; Mutators. (define hash-table-set! (case-lambda ((ht) #f) ((ht key val) (hashtable-set! ht key val)) ((ht key1 val1 key2 val2 . others) (hashtable-set! ht key1 val1) (hashtable-set! ht key2 val2) (apply hash-table-set! ht others)))) (define (hash-table-delete! ht . keys) (let ((count 0)) (for-each (lambda (key) (when (hashtable-contains? ht key) (set! count (fx+ 1 count)) (hashtable-delete! ht key))) keys) count)) ;; (define (hash-table-intern! ht key failure) ;; (hashtable-intern! ht key failure)) (define hash-table-update! (case-lambda ((ht key updater) (hashtable-update! ht key updater)) ((ht key updater failure) (let ((updater* (lambda (val) (if (eq? %not-found val) (updater (failure)) (updater val))))) (hashtable-update! ht key updater* %not-found))) ((ht key updater failure success) (let* ((updater* (lambda (val) (if (eq? %not-found val) (updater (failure)) (success (updater val)))))) (hashtable-update! ht key updater* %not-found))))) (define (hash-table-update!/default ht key updater default) (hashtable-update! ht key updater default)) ;; (define (hash-table-pop! ht) ;; (hashtable-pop! ht)) ;; (define (hash-table-clear! ht) ;; (hashtable-clear! ht)) ;;; The whole hash table. ;; (define (hash-table-size ht) ;; (hashtable-size ht)) (define (hash-table-keys ht) (vector->list (hashtable-keys ht))) (define (hash-table-values ht) (vector->list (hashtable-values ht))) (define (hash-table-entries ht) (call-with-values (lambda () (hashtable-entries ht)) (lambda (keys vals) (values (vector->list keys) (vector->list vals))))) (define (hash-table-find proc ht failure) (call-with-values (lambda () (hashtable-entries ht)) (lambda (keys vals) (let ((size (vector-length keys))) (let loop ((i 0)) (if (fx>=? i size) (failure) (let* ((key (vector-ref keys i)) (val (vector-ref vals i)) (x (proc key val))) (or x (loop (fx+ i 1)))))))))) (define (hash-table-count pred ht) (let ((count 0)) (call-with-values (lambda () (hashtable-entries ht)) (lambda (keys vals) (vector-for-each (lambda (key val) (if (pred key val) (set! count (fx+ count 1)))) keys vals))) count)) ;;; Mapping and folding. (define (hash-table-map proc comparator ht) (let ((result (make-hash-table comparator))) (hash-table-for-each (lambda (key val) (hash-table-set! result key (proc val))) ht) result)) (define (hash-table-map->list proc ht) (call-with-values (lambda () (hash-table-entries ht)) (lambda (keys vals) (map proc keys vals)))) ;;; With this particular implementation, the proc can safely mutate ht. ;;; That property is not guaranteed by the specification, but can be ;;; relied upon by procedures defined in this file. (define (hash-table-for-each proc ht) (hashtable-walk ht proc)) (define (hash-table-map! proc ht) (hashtable-update-all! ht proc)) (define (hash-table-fold proc init ht) (if (hashtable? proc) (deprecated:hash-table-fold proc init ht) (hashtable-sum ht init proc))) (define (hash-table-prune! proc ht) (hashtable-prune! ht proc)) ;;; Copying and conversion. ;; (define hash-table-copy hashtable-copy) (define (hash-table-empty-copy ht) (let* ((ht2 (hash-table-copy ht #t)) (ignored (hash-table-clear! ht2))) ht2)) (define (hash-table->alist ht) (call-with-values (lambda () (hash-table-entries ht)) (lambda (keys vals) (map cons keys vals)))) ;;; Hash tables as sets. (define (hash-table-union! ht1 ht2) (hash-table-for-each (lambda (key2 val2) (if (not (hashtable-contains? ht1 key2)) (hashtable-set! ht1 key2 val2))) ht2) ht1) (define (hash-table-intersection! ht1 ht2) (hash-table-for-each (lambda (key1 val1) (if (not (hashtable-contains? ht2 key1)) (hashtable-delete! ht1 key1))) ht1) ht1) (define (hash-table-difference! ht1 ht2) (hash-table-for-each (lambda (key1 val1) (if (hashtable-contains? ht2 key1) (hashtable-delete! ht1 key1))) ht1) ht1) (define (hash-table-xor! ht1 ht2) (hash-table-for-each (lambda (key2 val2) (if (hashtable-contains? ht1 key2) (hashtable-delete! ht1 key2) (hashtable-set! ht1 key2 val2))) ht2) ht1) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The following procedures are deprecated by SRFI 125, but must ;;; be exported nonetheless. ;;; ;;; Programs that import the (srfi 125) library must rename the ;;; deprecated string-hash and string-ci-hash procedures to avoid ;;; conflict with the string-hash and string-ci-hash procedures ;;; exported by SRFI 126 and SRFI 128. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (deprecated:hash obj . rest) (issue-warning-deprecated 'hash) (default-hash obj)) (define (deprecated:string-hash obj . rest) (issue-warning-deprecated 'srfi-125:string-hash) (string-hash obj)) (define (deprecated:string-ci-hash obj . rest) (issue-warning-deprecated 'srfi-125:string-ci-hash) (string-ci-hash obj)) (define (deprecated:hash-by-identity obj . rest) (issue-warning-deprecated 'hash-by-identity) (deprecated:hash obj)) (define (deprecated:hash-table-equivalence-function ht) (issue-warning-deprecated 'hash-table-equivalence-function) (hashtable-equivalence-function ht)) (define (deprecated:hash-table-hash-function ht) (issue-warning-deprecated 'hash-table-hash-function) (hashtable-hash-function ht)) (define (deprecated:hash-table-exists? ht key) (issue-warning-deprecated 'hash-table-exists?) (hash-table-contains? ht key)) (define (deprecated:hash-table-walk ht proc) (issue-warning-deprecated 'hash-table-walk) (hash-table-for-each proc ht)) (define (deprecated:hash-table-fold ht proc seed) (issue-warning-deprecated 'srfi-69-style:hash-table-fold) (hash-table-fold proc seed ht)) (define (deprecated:hash-table-merge! ht1 ht2) (issue-warning-deprecated 'hash-table-merge!) (hash-table-union! ht1 ht2)) ; eof chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a125/hashtables.sls000066400000000000000000000041361375154206600223670ustar00rootroot00000000000000(library (srfi :125 hashtables) (export make-hash-table hash-table hash-table-unfold alist->hash-table hash-table? hash-table-contains? hash-table-empty? hash-table=? hash-table-mutable? hash-table-ref hash-table-ref/default hash-table-set! hash-table-delete! hash-table-intern! hash-table-update! hash-table-update!/default hash-table-pop! hash-table-clear! hash-table-size hash-table-keys hash-table-values hash-table-entries hash-table-find hash-table-count hash-table-map hash-table-for-each hash-table-map! hash-table-map->list hash-table-fold hash-table-prune! hash-table-copy hash-table-empty-copy hash-table->alist hash-table-union! hash-table-intersection! hash-table-difference! hash-table-xor! ;; The following procedures are deprecated by SRFI 125: deprecated:hash deprecated:string-hash deprecated:string-ci-hash deprecated:hash-by-identity deprecated:hash-table-equivalence-function deprecated:hash-table-hash-function deprecated:hash-table-exists? deprecated:hash-table-walk deprecated:hash-table-merge!) (import (except (rnrs) make-hashtable hashtable-clear! hashtable-copy hashtable-ref hashtable-update! make-eq-hashtable make-eqv-hashtable) (srfi private include) (rename (srfi :126) (hashtable? hash-table?) (hashtable-contains? hash-table-contains?) (hashtable-empty? hash-table-empty?) (hashtable-intern! hash-table-intern!) (hashtable-clear! hash-table-clear!) (hashtable-copy hash-table-copy) (hashtable-size hash-table-size) (hashtable-pop! hash-table-pop!) (hashtable-merge! hash-table-merge!) (hashtable-hash-function hash-table-hash-function) (hashtable-equivalence-function hash-table-equivalence-function)) (except (srfi :128) hash-salt string-hash string-ci-hash symbol-hash)) (include/resolve ("srfi" "%3a125") "125.body.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a126.sls000066400000000000000000000017001375154206600202440ustar00rootroot00000000000000(library (srfi :126) (export make-eq-hashtable make-eqv-hashtable make-hashtable alist->eq-hashtable alist->eqv-hashtable alist->hashtable weakness hashtable? hashtable-size hashtable-ref hashtable-set! hashtable-delete! hashtable-contains? hashtable-lookup hashtable-update! hashtable-intern! hashtable-copy hashtable-clear! hashtable-empty-copy hashtable-keys hashtable-values hashtable-entries hashtable-key-list hashtable-value-list hashtable-entry-lists hashtable-walk hashtable-update-all! hashtable-prune! hashtable-merge! hashtable-sum hashtable-map->lset hashtable-find hashtable-empty? hashtable-pop! hashtable-inc! hashtable-dec! hashtable-equivalence-function hashtable-hash-function hashtable-weakness hashtable-mutable? hash-salt equal-hash string-hash string-ci-hash symbol-hash) (import (srfi :126 r6rs-hashtables))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a126/000077500000000000000000000000001375154206600175235ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a126/126.body.scm000066400000000000000000000311501375154206600214730ustar00rootroot00000000000000(define make-eq-hashtable (case-lambda (() (rnrs:make-eq-hashtable)) ((capacity) (if capacity (rnrs:make-eq-hashtable capacity) (rnrs:make-eq-hashtable))) ((capacity weakness) (if weakness (cond ((memq weakness (weak-eq-hashtables-supported)) (if capacity ((make-weak-eq-hashtable-procedure weakness) capacity) ((make-weak-eq-hashtable-procedure weakness)))) ((memq weakness (ephemeral-eq-hashtables-supported)) (if capacity ((make-ephemeral-eq-hashtable-procedure weakness) capacity) ((make-ephemeral-eq-hashtable-procedure weakness)))) (else (error 'make-eq-hashtable "weakness not supported" weakness))) (if capacity (rnrs:make-eq-hashtable capacity) (rnrs:make-eq-hashtable)))))) (define make-eqv-hashtable (case-lambda (() (rnrs:make-eqv-hashtable)) ((capacity) (if capacity (rnrs:make-eqv-hashtable capacity) (rnrs:make-eqv-hashtable))) ((capacity weakness) (if weakness (cond ((memq weakness (weak-eqv-hashtables-supported)) (if capacity ((make-weak-eqv-hashtable-procedure weakness) capacity) ((make-weak-eqv-hashtable-procedure weakness)))) ((memq weakness (ephemeral-eqv-hashtables-supported)) (if capacity ((make-ephemeral-eqv-hashtable-procedure weakness) capacity) ((make-ephemeral-eqv-hashtable-procedure weakness)))) (else (error 'make-eqv-hashtable "weakness not supported" weakness))) (if capacity (rnrs:make-eqv-hashtable capacity) (rnrs:make-eqv-hashtable)))))) (define make-hashtable (case-lambda ((hash equiv) (if hash (rnrs:make-hashtable (if (pair? hash) (car hash) hash) equiv) (cond ((eq? equiv eq?) (make-eq-hashtable)) ((eq? equiv eqv?) (make-eqv-hashtable)) (else (error 'make-hashtable "hash procedure cannot be #f except with eq? or eqv?" hash equiv))))) ((hash equiv capacity) (if hash (if capacity (rnrs:make-hashtable (if (pair? hash) (car hash) hash) equiv capacity) (rnrs:make-hashtable (if (pair? hash) (car hash) hash) equiv)) (cond ((eq? equiv eq?) (make-eq-hashtable capacity)) ((eq? equiv eqv?) (make-eqv-hashtable capacity)) (else (error 'make-hashtable "hash procedure cannot be #f except with eq? or eqv?" hash equiv))))) ((hash equiv capacity weakness) (if hash (let ((hash (if (pair? hash) (car hash) hash))) ;; why? - read spec (if weakness (cond ((memq weakness (weak-hashtables-supported)) (if capacity ((make-weak-hashtable-procedure weakness) hash equiv capacity) ((make-weak-hashtable-procedure weakness) hash equiv))) ((memq weakness (ephemeral-hashtables-supported)) (if capacity ((make-ephemeral-hashtable-procedure weakness) hash equiv capacity) ((make-ephemeral-hashtable-procedure weakness) hash equiv))) (else (error 'make-hashtable "weakness not supported" weakness))) (if capacity (rnrs:make-hashtable hash equiv capacity) (rnrs:make-hashtable hash equiv)))) (cond ; hash function not provided ((eq? equiv eq?) (make-eq-hashtable capacity weakness)) ((eq? equiv eqv?) (make-eqv-hashtable capacity weakness)) (else (error 'make-hashtable "hash procedure cannot be #f except with eq? or eqv?" hash equiv))))))) (define (alist->eq-hashtable . args) (apply alist->hashtable #f eq? args)) (define (alist->eqv-hashtable . args) (apply alist->hashtable #f eqv? args)) (define alist->hashtable (case-lambda ((hash equiv alist) (alist->hashtable hash equiv #f #f alist)) ((hash equiv capacity alist) (alist->hashtable hash equiv capacity #f alist)) ((hash equiv capacity weakness alist) (let ((hashtable (make-hashtable hash equiv capacity weakness))) (for-each (lambda (entry) (hashtable-set! hashtable (car entry) (cdr entry))) (reverse alist)) hashtable)))) (define-enumeration weakness (weak-key weak-value weak-key-and-value ephemeral-key ephemeral-value ephemeral-key-and-value) weakness-set) #;(define hashtable? rnrs:hashtable?) #;(define hashtable-size rnrs:hashtable-size) (define nil (cons #f #f)) (define (nil? obj) (eq? obj nil)) (define hashtable-ref (case-lambda ((hashtable key) (let ((value (rnrs:hashtable-ref hashtable key nil))) (if (nil? value) (error "No such key in hashtable." hashtable key) value))) ((hashtable key default) (rnrs:hashtable-ref hashtable key default)))) #;(define hashtable-set! rnrs:hashtable-set!) #;(define hashtable-delete! rnrs:hashtable-delete!) #;(define hashtable-contains? rnrs:hashtable-contains?) (define (hashtable-lookup hashtable key) (let ((value (rnrs:hashtable-ref hashtable key nil))) (if (nil? value) (values #f #f) (values value #t)))) (define hashtable-update! (case-lambda ((hashtable key proc) (rnrs:hashtable-update! hashtable key (lambda (value) (if (nil? value) (error "No such key in hashtable." hashtable key) (proc value))) nil)) ((hashtable key proc default) (rnrs:hashtable-update! hashtable key proc default)))) (define (hashtable-intern! hashtable key default-proc) (if (hashtable-cell-support) (let ((cell (hashtable-cell hashtable key nil))) (if (nil? (hashtable-cell-value cell)) (let ((value (default-proc))) (set-hashtable-cell-value! cell value) value) (hashtable-cell-value cell))) (let ((value (rnrs:hashtable-ref hashtable key nil))) (if (nil? value) (let ((value (default-proc))) (hashtable-set! hashtable key value) value) value)))) (define hashtable-copy (case-lambda ((hashtable) (hashtable-copy hashtable #f #f)) ((hashtable mutable) (hashtable-copy hashtable mutable #f)) ((hashtable mutable weakness) (when weakness (error 'hashtable-copy "No weak or ephemeral tables supported.")) (rnrs:hashtable-copy hashtable mutable)))) (define hashtable-clear! (case-lambda ((hashtable) (rnrs:hashtable-clear! hashtable)) ((hashtable capacity) (if capacity (cond-expand (ikarus (rnrs:hashtable-clear! hashtable)) (else (rnrs:hashtable-clear! hashtable capacity))) (rnrs:hashtable-clear! hashtable))))) (define hashtable-empty-copy (case-lambda ((hashtable) (hashtable-empty-copy hashtable #f)) ((hashtable capacity) (make-hashtable (hashtable-hash-function hashtable) (hashtable-equivalence-function hashtable) (if (eq? #t capacity) (hashtable-size hashtable) capacity) (hashtable-weakness hashtable))))) #;(define hashtable-keys rnrs:hashtable-keys) ;;; Defined in helpers.sls ;; (define (hashtable-values hashtable) ;; (let-values (((keys values) (hashtable-entries hashtable))) ;; values)) #;(define hashtable-entries rnrs:hashtable-entries) (define (hashtable-key-list hashtable) (hashtable-map->lset hashtable (lambda (key value) key))) (define (hashtable-value-list hashtable) (hashtable-map->lset hashtable (lambda (key value) value))) (define (hashtable-entry-lists hashtable) (let ((keys '()) (vals '())) (hashtable-walk hashtable (lambda (key val) (set! keys (cons key keys)) (set! vals (cons val vals)))) (values keys vals))) ;;; XXX The procedures hashtable-walk, hashtable-update-all!, hashtable-prune!, ;;; and hashtable-sum should be implemented more efficiently at the platform ;;; level. In particular, they should not allocate intermediate vectors or ;;; lists to hold the keys or values that are being operated on. (define (hashtable-walk hashtable proc) (let-values (((keys values) (hashtable-entries hashtable))) (vector-for-each proc keys values))) (define (hashtable-update-all! hashtable proc) (let-values (((keys values) (hashtable-entries hashtable))) (vector-for-each (lambda (key value) (hashtable-set! hashtable key (proc key value))) keys values))) (define (hashtable-prune! hashtable proc) (let-values (((keys values) (hashtable-entries hashtable))) (vector-for-each (lambda (key value) (when (proc key value) (hashtable-delete! hashtable key))) keys values))) (define (hashtable-merge! hashtable-dest hashtable-source) (let-values (((keys values) (hashtable-entries hashtable-source))) (vector-for-each (lambda (key value) (hashtable-set! hashtable-dest key value)) keys values)) hashtable-dest) (define (hashtable-sum hashtable init proc) (let-values (((keys vals) (hashtable-entries hashtable))) (let ((size (vector-length keys))) (let loop ((i 0) (result init)) (if (fx>=? i size) result (loop (fx+ i 1) (proc (vector-ref keys i) (vector-ref vals i) result))))))) (define (hashtable-map->lset hashtable proc) (let-values (((keys vals) (hashtable-entries hashtable))) (let ((size (vector-length keys))) (let loop ((i 0) (accumulator '())) (if (fx>=? i size) accumulator (loop (fx+ i 1) (cons (proc (vector-ref keys i) (vector-ref vals i)) accumulator))))))) ;;; XXX If available, let-escape-continuation might be more efficient than ;;; call/cc here. (define (hashtable-find hashtable proc) (call/cc (lambda (return) (hashtable-walk hashtable (lambda (key value) (when (proc key value) (return key value #t)))) (return #f #f #f)))) (define (hashtable-empty? hashtable) (fxzero? (hashtable-size hashtable))) ;;; XXX A platform-level implementation could avoid allocating the constant true ;;; function and the lookup for the key in the delete operation. (define (hashtable-pop! hashtable) (if (hashtable-empty? hashtable) (error "Cannot pop from empty hashtable." hashtable) (let-values (((key value found?) (hashtable-find hashtable (lambda (k v) #t)))) (hashtable-delete! hashtable key) (values key value)))) (define hashtable-inc! (case-lambda ((hashtable key) (hashtable-inc! hashtable key 1)) ((hashtable key number) (hashtable-update! hashtable key (lambda (v) (+ v number)) 0)))) (define hashtable-dec! (case-lambda ((hashtable key) (hashtable-dec! hashtable key 1)) ((hashtable key number) (hashtable-update! hashtable key (lambda (v) (- v number)) 0)))) #;(define hashtable-equivalence-function rnrs:hashtable-equivalence-function) #;(define hashtable-hash-function rnrs-hashtable-hash-function) ;;; Defined in helpers.sls #;(define (hashtable-weakness hashtable) #f) #;(define hashtable-mutable? rnrs-hashtable-mutable?) (define *hash-salt* (let ((seed (get-environment-variable "SRFI_126_HASH_SEED"))) (if (or (not seed) (string=? seed "")) (random-integer (greatest-fixnum)) (mod (string-hash seed) (greatest-fixnum))))) (define (hash-salt) *hash-salt*) #;(define equal-hash rnrs-equal-hash) #;(define string-hash rnrs-string-hash) #;(define string-ci-hash rnrs-string-ci-hash) #;(define symbol-hash rnrs-symbol-hash) ;; Local Variables: ;; eval: (put 'hashtable-walk 'scheme-indent-function 1) ;; eval: (put 'hashtable-update-all! 'scheme-indent-function 1) ;; eval: (put 'hashtable-prune! 'scheme-indent-function 1) ;; eval: (put 'hashtable-sum 'scheme-indent-function 2) ;; eval: (put 'hashtable-map->lset 'scheme-indent-function 1) ;; eval: (put 'hashtable-find 'scheme-indent-function 1) ;; End: chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a126/helpers/000077500000000000000000000000001375154206600211655ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a126/helpers/helpers.chezscheme.sls000066400000000000000000000110041375154206600254630ustar00rootroot00000000000000(library (srfi :126 helpers helpers) (export make-weak-eq-hashtable-procedure weak-eq-hashtables-supported make-weak-eqv-hashtable-procedure weak-eqv-hashtables-supported make-weak-hashtable-procedure weak-hashtables-supported make-ephemeral-eq-hashtable-procedure ephemeral-eq-hashtables-supported make-ephemeral-eqv-hashtable-procedure ephemeral-eqv-hashtables-supported make-ephemeral-hashtable-procedure ephemeral-hashtables-supported hashtable-values hashtable-weakness hashtable-cell-support hashtable-cell hashtable-cell-key hashtable-cell-value set-hashtable-cell-value! get-environment-variable random-integer) (import (rename (chezscheme) (getenv get-environment-variable))) (define (make-weak-eq-hashtable-procedure weakness) (if (eq? weakness 'weak-key) make-weak-eq-hashtable (error 'make-weak-eq-hashtable "weakness not supported" weakness))) (define-syntax weak-eq-hashtables-supported (syntax-rules () ((weak-eq-hashtables-supported) '(weak-key)))) (define (make-weak-eqv-hashtable-procedure weakness) (if (eq? weakness 'weak-key) make-weak-eqv-hashtable (error 'make-weak-eqv-hashtable "weakness not supported" weakness))) (define-syntax weak-eqv-hashtables-supported (syntax-rules () ((weak-eqv-hashtables-supported) '(weak-key)))) (define (make-weak-hashtable-procedure weakness) (error 'make-weak-hashtable "weak hashtables not supported")) (define-syntax weak-hashtables-supported (syntax-rules () ((weak-hashtables-supported) '()))) (meta-cond ((let-values (((major minor sub-minor) (scheme-version-number))) (or (> major 9) (and (= major 9) (>= minor 5)))) ;; has ephemeral eq- and eqv-hashtables (define (make-ephemeral-eq-hashtable-procedure weakness) (if (eq? weakness 'ephemeral-key) make-ephemeron-eq-hashtable (error 'make-ephemeral-eq-hashtable "weakness not supported" weakness))) (define-syntax ephemeral-eq-hashtables-supported (syntax-rules () ((ephemeral-eq-hashtables-supported) '(ephemeral-key)))) (define (make-ephemeral-eqv-hashtable-procedure weakness) (if (eq? weakness 'ephemeral-key) make-ephemeron-eqv-hashtable (error 'make-ephemeral-eqv-hashtable "weakness not supported" weakness))) (define-syntax ephemeral-eqv-hashtables-supported (syntax-rules () ((ephemeral-eqv-hashtables-supported) '(ephemeral-key)))) (define (make-ephemeral-hashtable-procedure weakness) (error 'make-ephemeral-hashtable "weakness not supported" weakness)) (define-syntax ephemeral-hashtables-supported (syntax-rules () ((ephemeral-hashtables-supported) '(ephemeral-key)))) (define (hashtable-weakness hashtable) (cond ((hashtable-weak? hashtable) 'weak-key) ((hashtable-ephemeron? hashtable) 'ephemeral-key) (else #f)))) (else ; no ephemeral hashtables (define (make-ephemeral-eq-hashtable-procedure weakness) (error 'make-ephemeral-hashtable "ephemeral eq hashtables not supported")) (define-syntax ephemeral-eq-hashtables-supported (syntax-rules () ((ephemeral-eq-hashtables-supported) '()))) (define (make-ephemeral-eqv-hashtable-procedure weakness) (error 'make-ephemeral-hashtable "ephemeral eqv hashtables not supported")) (define-syntax ephemeral-eqv-hashtables-supported (syntax-rules () ((ephemeral-eqv-hashtables-supported) '()))) (define (make-ephemeral-hashtable-procedure weakness) (error 'make-ephemeral-hashtable "ephemeral hashtables not supported")) (define-syntax ephemeral-hashtables-supported (syntax-rules () ((ephemeral-hashtables-supported) '()))) (define (hashtable-weakness hashtable) (cond ((hashtable-weak? hashtable) 'weak-key) (else #f))))) ;; Support for hashtable cells (define-syntax hashtable-cell-support (syntax-rules () ((hashtable-cell-support) #t))) (define hashtable-cell-key car) (define hashtable-cell-value cdr) (define set-hashtable-cell-value! set-cdr!) (define (random-integer seed) (fxmod (fxxor (random seed) (fx* 3 (fxdiv (random (time-nanosecond (current-time))) 4))) seed))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a126/helpers/helpers.sls000066400000000000000000000057371375154206600233660ustar00rootroot00000000000000(library (srfi :126 helpers helpers) (export make-weak-eq-hashtable-procedure weak-eq-hashtables-supported make-weak-eqv-hashtable-procedure weak-eqv-hashtables-supported make-weak-hashtable-procedure weak-hashtables-supported make-ephemeral-eq-hashtable-procedure ephemeral-eq-hashtables-supported make-ephemeral-eqv-hashtable-procedure ephemeral-eqv-hashtables-supported make-ephemeral-hashtable-procedure ephemeral-hashtables-supported hashtable-values hashtable-weakness hashtable-cell-support hashtable-cell hashtable-cell-key hashtable-cell-value set-hashtable-cell-value! get-environment-variable random-integer) (import (rnrs) (srfi :39) (only (srfi :27) random-integer) (only (srfi :98) get-environment-variable)) (define (make-weak-eq-hashtable-procedure weakness) (error 'make-weak-eq-hashtable "weak eq hashtables not supported")) (define-syntax weak-eq-hashtables-supported (syntax-rules () ((weak-eq-hashtables-supported) '()))) (define (make-weak-eqv-hashtable-procedure weakness) (error 'make-weak-eqv-hashtable "weak eqv hashtables not supported")) (define-syntax weak-eqv-hashtables-supported (syntax-rules () ((weak-eqv-hashtables-supported) '()))) (define (make-weak-hashtable-procedure weakness) (error 'make-weak-hashtable "weak hashtables not supported")) (define-syntax weak-hashtables-supported (syntax-rules () ((weak-hashtables-supported) '()))) (define (make-ephemeral-eq-hashtable-procedure weakness) (error 'make-ephemeral-hashtable "ephemeral eq hashtables not supported")) (define-syntax ephemeral-eq-hashtables-supported (syntax-rules () ((ephemeral-eq-hashtables-supported) '()))) (define (make-ephemeral-eqv-hashtable-procedure weakness) (error 'make-ephemeral-hashtable "ephemeral eqv hashtables not supported")) (define-syntax ephemeral-eqv-hashtables-supported (syntax-rules () ((ephemeral-eqv-hashtables-supported) '()))) (define (make-ephemeral-hashtable-procedure weakness) (error 'make-ephemeral-hashtable "ephemeral hashtables not supported")) (define-syntax ephemeral-hashtables-supported (syntax-rules () ((ephemeral-hashtables-supported) '()))) (define (hashtable-values hashtable) (let-values (((keys values) (hashtable-entries hashtable))) values)) (define (hashtable-weakness hashtable) #f) (define-syntax hashtable-cell-support (syntax-rules () ((hashtable-cell-support) #f))) (define (hashtable-cell hashtable) (error 'hashtable-cell "hashtable cells not supported")) (define (hashtable-cell-key cell) (error 'hashtable-cell "hashtable cells not supported")) (define (hashtable-cell-value cell) (error 'hashtable-cell "hashtable cells not supported")) (define (set-hashtable-cell-value! cell value) (error 'hashtable-cell "hashtable cells not supported"))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a126/r6rs-hashtables.sls000066400000000000000000000027641375154206600232670ustar00rootroot00000000000000(library (srfi :126 r6rs-hashtables) (export make-eq-hashtable make-eqv-hashtable make-hashtable alist->eq-hashtable alist->eqv-hashtable alist->hashtable weakness hashtable? hashtable-size hashtable-ref hashtable-set! hashtable-delete! hashtable-contains? hashtable-lookup hashtable-update! hashtable-intern! hashtable-copy hashtable-clear! hashtable-empty-copy hashtable-keys hashtable-values hashtable-entries hashtable-key-list hashtable-value-list hashtable-entry-lists hashtable-walk hashtable-update-all! hashtable-prune! hashtable-merge! hashtable-sum hashtable-map->lset hashtable-find hashtable-empty? hashtable-pop! hashtable-inc! hashtable-dec! hashtable-equivalence-function hashtable-hash-function hashtable-weakness hashtable-mutable? hash-salt equal-hash string-hash string-ci-hash symbol-hash) (import (rename (rnrs) (make-eq-hashtable rnrs:make-eq-hashtable) (make-eqv-hashtable rnrs:make-eqv-hashtable) (make-hashtable rnrs:make-hashtable) (hashtable-ref rnrs:hashtable-ref) (hashtable-update! rnrs:hashtable-update!) (hashtable-copy rnrs:hashtable-copy) (hashtable-clear! rnrs:hashtable-clear!)) (srfi :0 cond-expand) (srfi :126 helpers helpers) (srfi private include)) (include/resolve ("srfi" "%3a126") "126.body.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a127.sls000066400000000000000000000007051375154206600202510ustar00rootroot00000000000000(library (srfi :127) (export generator->lseq lseq? lseq=? lseq-car lseq-first lseq-cdr lseq-rest lseq-ref lseq-take lseq-drop lseq-realize lseq->generator lseq-length lseq-append lseq-zip lseq-map lseq-for-each lseq-filter lseq-remove lseq-find lseq-find-tail lseq-take-while lseq-drop-while lseq-any lseq-every lseq-index lseq-member lseq-memq lseq-memv) (import (srfi :127 lazy-sequences))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a127/000077500000000000000000000000001375154206600175245ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a127/lazy-sequences.sls000066400000000000000000000010441375154206600232160ustar00rootroot00000000000000(library (srfi :127 lazy-sequences) (export generator->lseq lseq? lseq=? lseq-car lseq-first lseq-cdr lseq-rest lseq-ref lseq-take lseq-drop lseq-realize lseq->generator lseq-length lseq-append lseq-zip lseq-map lseq-for-each lseq-filter lseq-remove lseq-find lseq-find-tail lseq-take-while lseq-drop-while lseq-any lseq-every lseq-index lseq-member lseq-memq lseq-memv) (import (rnrs) (rnrs mutable-pairs) (srfi private include)) (include/resolve ("srfi" "%3a127") "lseqs-impl.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a127/lseqs-impl.scm000066400000000000000000000172651375154206600223310ustar00rootroot00000000000000;; Helper returns #t if any element of list is null or #f if none (define (any-null? list) (cond ((null? list) #f) ((null? (car list)) #t) (else (any-null? (cdr list))))) ;; gappend procedure cloned from SRFI 121 (define (gappend . args) (lambda () (if (null? args) (eof-object) (let loop ((v ((car args)))) (if (eof-object? v) (begin (set! args (cdr args)) (if (null? args) (eof-object) (loop ((car args))))) v))))) ;;; Convert a generator (procedure with no arguments) to an lseq ;;; This is the basic constructor for lseqs, since every proper list ;;; is already an lseq and so list->lseq is not needed (define (generator->lseq gen) (let ((value (gen))) ;; See what starts off the generator: ;; if it's already exhausted, the lseq is empty, ;; otherwise, return an improper list with one value and the generator ;; in the tail, which is how we represent unrealized lseqs (if (eof-object? value) '() (cons value gen)))) ;;; Car on lseqs is the same as on lists (define (lseq-car lseq) (car lseq)) (define (lseq-first lseq) (car lseq)) ;;; Lseq-cdr expands the generator if it's there, or falls back to regular cdr (define (lseq-cdr lseq) ;; We assume lseq is a pair, because it is an error if it isn't ;; If it's a procedure, we assume it's a generator and invoke it (if (procedure? (cdr lseq)) (let ((obj ((cdr lseq)))) (cond ;; If the generator is exhausted, replace it with () and return () ((eof-object? obj) (set-cdr! lseq '()) '()) ;; Otherwise, make a new pair of the value and the generator ;; and patch it in to the cdr (else (let ((result (cons obj (cdr lseq)))) (set-cdr! lseq result) result)))) ;; If there is no procedure, return the ordinary cdr (cdr lseq))) (define (lseq-rest lseq) (lseq-cdr lseq)) ;;; Returns #t if argument is an lseq ;;; Note that without arity inspection, we can't be sure a procedure in the ;;; tail is really a generator, so we assume it is (define (lseq? obj) (cond ;; null list is a lseq ((null? obj) #t) ;; non-list is not an lseq ((not (pair? obj)) #f) ;; improper list with procedure in the tail is (presumed to be) an lseq ((procedure? (cdr obj)) #t) ;; otherwise keep looking (else (lseq? (cdr obj))))) ;;; Compare lseqs for equality (define (lseq=? = lseq1 lseq2) (cond ((and (null? lseq1) (null? lseq2)) #t) ((or (null? lseq1) (null? lseq2)) #f) ((= (lseq-car lseq1) (lseq-car lseq2)) (lseq=? = (lseq-cdr lseq1) (lseq-cdr lseq2))) (else #f))) ;;; Take the first n elements of lseq and return as a list (define (lseq-take lseq i) (generator->lseq (lambda () (if (= i 0) (eof-object) (let ((result (lseq-car lseq))) (set! lseq (lseq-cdr lseq)) (set! i (- i 1)) result))))) ;; Drop the first n arguments of lseq ;; No reason not to do it eagerly (define (lseq-drop lseq i) (let loop ((i i) (lseq lseq)) (if (= i 0) lseq (loop (- i 1) (lseq-cdr lseq))))) ;; Get the nth argument of lseq (define (lseq-ref lseq i) (lseq-car (lseq-drop lseq i))) ;;; Convert lseq to a list by lseq-cdr-ing down it to the end (define (lseq-realize lseq) (let loop ((next lseq)) (if (null? next) lseq (loop (lseq-cdr next))))) ;;; Realize an lseq and return its length (define (lseq-length lseq) (length (lseq-realize lseq))) ;; Return a generator that steps through the elements of the lseq (define (lseq->generator lseq) (lambda () (if (null? lseq) (eof-object) (let ((result (lseq-car lseq))) (set! lseq (lseq-cdr lseq)) result)))) ;; lseq-append converts lseqs to generators and gappends them (define (lseq-append . lseqs) (generator->lseq (apply gappend (map lseq->generator lseqs)))) ;; Safe version of lseq-cdr that returns () if the argument is () (define (safe-lseq-cdr obj) (if (null? obj) obj (lseq-cdr obj))) ;; Lazily map lseqs through a proc to produce another lseq (define (lseq-map proc . lseqs) (generator->lseq (lambda () (if (any-null? lseqs) (eof-object) (let ((result (apply proc (map lseq-car lseqs)))) (set! lseqs (map safe-lseq-cdr lseqs)) result))))) ;; Zip cars of lseqs into a list and return an lseq of those lists (define (lseq-zip . lseqs) (apply lseq-map list lseqs)) ;; Eagerly apply a proc to the elements of lseqs ;; Included because it's a common operation, even though it is trivial (define (lseq-for-each proc . lseqs) (apply for-each proc (map lseq-realize lseqs))) ;; Filter an lseq lazily to include only elements that satisfy pred (define (lseq-filter pred lseq) (generator->lseq (lambda () (let loop ((lseq1 lseq)) (if (null? lseq1) (eof-object) (let ((result (lseq-car lseq1))) (cond ((pred result) (set! lseq (lseq-cdr lseq1)) result) (else (loop (lseq-cdr lseq1)))))))))) ;; Negated filter (define (lseq-remove pred lseq) (lseq-filter (lambda (x) (not (pred x))) lseq)) ;; Find an element that satisfies a pred, or #f if no such element (define (lseq-find pred lseq) (cond ((null? lseq) #f) ((pred (lseq-car lseq)) (lseq-car lseq)) (else (lseq-find pred (lseq-cdr lseq))))) ;; Find the tail of an lseq whose car satisfies a pred, or #f if no such (define (lseq-find-tail pred lseq) (cond ((null? lseq) #f) ((pred (lseq-car lseq)) lseq) (else (lseq-find-tail pred (lseq-cdr lseq))))) ;; Return initial elements of lseq that satisfy pred (define (lseq-take-while pred lseq) (generator->lseq (lambda () (if (not (pred (lseq-car lseq))) (eof-object) (let ((result (lseq-car lseq))) (set! lseq (lseq-cdr lseq)) result))))) ;; Return all but initial of lseq that satisfy pred ;; No reason not to do it eagerly (define (lseq-drop-while pred lseq) (let loop ((lseq lseq)) (if (not (pred (lseq-car lseq))) lseq (loop (lseq-cdr lseq))))) ;; Apply predicate across lseqs, returning result if it is true (define (lseq-any pred . lseqs) (let loop ((lseqs lseqs)) (if (any-null? lseqs) #f (let ((result (apply pred (map lseq-car lseqs)))) (if result result (loop (map lseq-cdr lseqs))))))) ;; Apply predicate across lseqs, returning false if predicate does (define (lseq-every pred . lseqs) (let loop ((lseqs lseqs) (last-result #t)) (if (any-null? lseqs) last-result (let ((result (apply pred (map lseq-car lseqs)))) (if result (loop (map lseq-cdr lseqs) result) #f))))) ;; Return the index of the first element of lseq that satisfies pred (define (lseq-index pred . lseqs) (let loop ((lseqs lseqs) (n 0)) (cond ((any-null? lseqs) #f) ((apply pred (map lseq-car lseqs)) n) (else (loop (map safe-lseq-cdr lseqs) (+ n 1)))))) ;; Return tail of lseq whose first element is x in the sense of = (default equal?) (define lseq-member (case-lambda ((x lseq) (lseq-member x lseq equal?)) ((x lseq =) (cond ((null? lseq) #f) ((= x (lseq-car lseq)) lseq) (else (lseq-member x (lseq-cdr lseq) =)))))) ;; Member using eqv? (define (lseq-memv x lseq) (lseq-member x lseq eqv?)) ;; Member using eq? (define (lseq-memq x lseq) (lseq-member x lseq eq?)) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a128.sls000066400000000000000000000013401375154206600202460ustar00rootroot00000000000000(library (srfi :128) (export comparator? comparator-ordered? comparator-hashable? make-comparator make-pair-comparator make-list-comparator make-vector-comparator make-eq-comparator make-eqv-comparator make-equal-comparator boolean-hash char-hash char-ci-hash string-hash string-ci-hash symbol-hash number-hash make-default-comparator default-hash comparator-register-default! comparator-type-test-predicate comparator-equality-predicate comparator-ordering-predicate comparator-hash-function comparator-test-type comparator-check-type comparator-hash hash-bound hash-salt =? ? <=? >=? comparator-if<=>) (import (srfi :128 comparators))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a128/000077500000000000000000000000001375154206600175255ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a128/128.body1.scm000066400000000000000000000277521375154206600215750ustar00rootroot00000000000000;;; Copyright (C) John Cowan (2015). All Rights Reserved. ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, ;;; copy, modify, merge, publish, distribute, sublicense, and/or ;;; sell copies of the Software, and to permit persons to whom the ;;; Software is furnished to do so, subject to the following ;;; conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES ;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR ;;; OTHER DEALINGS IN THE SOFTWARE. ;;;; Main part of the SRFI 114 reference implementation ;;; "There are two ways of constructing a software design: One way is to ;;; make it so simple that there are obviously no deficiencies, and the ;;; other way is to make it so complicated that there are no *obvious* ;;; deficiencies." --Tony Hoare ;;; Syntax (because syntax must be defined before it is used, contra Dr. Hardcase) ;; Arithmetic if (define-syntax comparator-if<=> (syntax-rules () ((if<=> a b less equal greater) (comparator-if<=> (make-default-comparator) a b less equal greater)) ((comparator-if<=> comparator a b less equal greater) (cond ((=? comparator a b) equal) ((? comparator a b) (binary? comparator a b))) (define (binary>=? comparator a b) (not (binary? comparator a b . objs) (let loop ((a a) (b b) (objs objs)) (and (binary>? comparator a b) (if (null? objs) #t (loop b (car objs) (cdr objs)))))) (define (<=? comparator a b . objs) (let loop ((a a) (b b) (objs objs)) (and (binary<=? comparator a b) (if (null? objs) #t (loop b (car objs) (cdr objs)))))) (define (>=? comparator a b . objs) (let loop ((a a) (b b) (objs objs)) (and (binary>=? comparator a b) (if (null? objs) #t (loop b (car objs) (cdr objs)))))) ;;; Simple ordering and hash functions (define (booleaninteger obj)) (hash-bound))) (define (char-ci-hash obj) (modulo (* (%salt%) (char->integer (char-foldcase obj))) (hash-bound))) (define (number-hash obj) (cond ((nan? obj) (%salt%)) ((and (infinite? obj) (positive? obj)) (* 2 (%salt%))) ((infinite? obj) (* (%salt%) 3)) ((real? obj) (abs (exact (round obj)))) (else (+ (number-hash (real-part obj)) (number-hash (imag-part obj)))))) ;; Lexicographic ordering of complex numbers (define (complexstring a) (symbol->string b))) ;; already defined in (rnrs hashtables) #;(define (symbol-hash obj) (string-hash (symbol->string obj))) ;;; Wrapped equality predicates ;;; These comparators don't have ordering functions. (define (make-eq-comparator) (make-comparator #t eq? #f default-hash)) (define (make-eqv-comparator) (make-comparator #t eqv? #f default-hash)) (define (make-equal-comparator) (make-comparator #t equal? #f default-hash)) ;;; Sequence ordering and hash functions ;; The hash functions are based on djb2, but ;; modulo 2^25 instead of 2^32 in hopes of sticking to fixnums. (define (make-hasher) (let ((result (%salt%))) (case-lambda (() result) ((n) (set! result (+ (modulo (* result 33) (hash-bound)) n)) result)))) ;;; Pair comparator (define (make-pair-comparator car-comparator cdr-comparator) (make-comparator (make-pair-type-test car-comparator cdr-comparator) (make-pair=? car-comparator cdr-comparator) (make-pair (length a) (length b)) #f) (else (let ((elem=? (comparator-equality-predicate element-comparator)) (eleminteger (string-ref obj n))) (loop (+ n 1))))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a128/128.body2.scm000066400000000000000000000126451375154206600215710ustar00rootroot00000000000000;;; Copyright (C) John Cowan (2015). All Rights Reserved. ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, ;;; copy, modify, merge, publish, distribute, sublicense, and/or ;;; sell copies of the Software, and to permit persons to whom the ;;; Software is furnished to do so, subject to the following ;;; conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES ;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR ;;; OTHER DEALINGS IN THE SOFTWARE. ;;; The default comparator ;;; Standard comparators and their functions ;; The unknown-object comparator, used as a fallback to everything else ;; Everything compares exactly the same and hashes to 0 (define unknown-object-comparator (make-comparator (lambda (obj) #t) (lambda (a b) #t) (lambda (a b) #f) (lambda (obj) 0))) ;; Next index for added comparator (define first-comparator-index 9) (define *next-comparator-index* 9) (define *registered-comparators* (list unknown-object-comparator)) ;; Register a new comparator for use by the default comparator. (define (comparator-register-default! comparator) (set! *registered-comparators* (cons comparator *registered-comparators*)) (set! *next-comparator-index* (+ *next-comparator-index* 1))) ;; Return ordinal for object types: null sorts before pairs, which sort ;; before booleans, etc. Implementations can extend this. ;; People who call comparator-register-default! effectively do extend it. (define (object-type obj) (cond ((null? obj) 0) ((pair? obj) 1) ((boolean? obj) 2) ((char? obj) 3) ((string? obj) 4) ((symbol? obj) 5) ((number? obj) 6) ((vector? obj) 7) ((bytevector? obj) 8) ; Add more here if you want: be sure to update comparator-index variables (else (registered-index obj)))) ;; Return the index for the registered type of obj. (define (registered-index obj) (let loop ((i 0) (registry *registered-comparators*)) (cond ((null? registry) (+ first-comparator-index i)) ((comparator-test-type (car registry) obj) (+ first-comparator-index i)) (else (loop (+ i 1) (cdr registry)))))) ;; Given an index, retrieve a registered conductor. ;; Index must be >= first-comparator-index. (define (registered-comparator i) (list-ref *registered-comparators* (- i first-comparator-index))) (define (dispatch-equality type a b) (case type ((0) #t) ; All empty lists are equal ((1) ((make-pair=? (make-default-comparator) (make-default-comparator)) a b)) ((2) (boolean=? a b)) ((3) (char=? a b)) ((4) (string=? a b)) ((5) (symbol=? a b)) ((6) (= a b)) ((7) ((make-vector=? (make-default-comparator) vector? vector-length vector-ref) a b)) ((8) ((make-vector=? (make-comparator exact-integer? = < default-hash) bytevector? bytevector-length bytevector-u8-ref) a b)) ; Add more here (else (binary=? (registered-comparator type) a b)))) (define (dispatch-ordering type a b) (case type ((0) 0) ; All empty lists are equal ((1) ((make-pair a-type b-type) #f) (else (dispatch-ordering a-type a b))))) (define (default-equality a b) (let ((a-type (object-type a)) (b-type (object-type b))) (if (= a-type b-type) (dispatch-equality a-type a b) #f))) (define (make-default-comparator) (make-comparator (lambda (obj) #t) default-equality default-ordering default-hash)) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a128/comparators.sls000066400000000000000000000020171375154206600226020ustar00rootroot00000000000000(library (srfi :128 comparators) (export comparator? comparator-ordered? comparator-hashable? make-comparator make-pair-comparator make-list-comparator make-vector-comparator make-eq-comparator make-eqv-comparator make-equal-comparator boolean-hash char-hash char-ci-hash string-hash string-ci-hash symbol-hash number-hash make-default-comparator default-hash comparator-register-default! comparator-type-test-predicate comparator-equality-predicate comparator-ordering-predicate comparator-hash-function comparator-test-type comparator-check-type comparator-hash hash-bound hash-salt =? ? <=? >=? comparator-if<=>) (import (except (rnrs) define-record-type) (srfi :99) (srfi :39) (only (rnrs r5rs) modulo) (srfi private include)) (define (exact-integer? x) (and (integer? x) (exact? x))) (include/resolve ("srfi" "%3a128") "128.body1.scm") (include/resolve ("srfi" "%3a128") "128.body2.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a129.sls000066400000000000000000000001631375154206600202510ustar00rootroot00000000000000(library (srfi :129) (export char-title-case? char-titlecase string-titlecase) (import (srfi :129 titlecase))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a129/000077500000000000000000000000001375154206600175265ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a129/titlecase-impl.scm000066400000000000000000000040051375154206600231450ustar00rootroot00000000000000;;;; Implementation of SRFI 129 titlecase functions ;; Returns #t if argument is a titlecase character, #f if not (define (char-title-case? ch) (let* ((codepoint (char->integer ch)) (result (assq codepoint titlecase-chars))) (if result #t #f))) ;; Returns the single-character titlecase mapping of argument (define (char-titlecase ch) (let* ((codepoint (char->integer ch)) (result (assq codepoint title-single-map))) (if result (integer->char (cadr result)) (char-upcase ch)))) ;; Returns #t if a character is caseless, otherwise #f (define (char-caseless? ch) (not (or (char-lower-case? ch) (char-upper-case? ch) (char-title-case? ch)))) ;; Push a list onto another list in reverse order (define (reverse-push new old) (if (null? new) old (reverse-push (cdr new) (cons (car new) old)))) ;; Returns the string titlecase mapping of argument (define (string-titlecase str) (let loop ((n 0) (result '())) (if (= n (string-length str)) (apply string (map integer->char (reverse result))) (let* ((ch (string-ref str n)) (codepoint (char->integer ch))) (if (or (= n 0) (char-caseless? (string-ref str (- n 1)))) ; ch must be titlecased (let ((multi-title (assq codepoint title-multiple-map))) (if multi-title ; ch has multiple- or single-character titlecase mapping (loop (+ n 1) (reverse-push (cdr multi-title) result)) ; ch has single-character uppercase mapping (loop (+ n 1) (reverse-push (list (char->integer (char-upcase ch))) result)))) ; ch must be lowercased (let ((multi-downcase (assq codepoint lower-multiple-map))) (if multi-downcase ; ch has multiple-character lowercase mapping (loop (+ n 1) (reverse-push (cdr multi-downcase) result)) ; ch has single-character lowercase mapping (loop (+ n 1) (reverse-push (list (char->integer (char-downcase ch))) result))))))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a129/titlecase.sls000066400000000000000000000004721375154206600222310ustar00rootroot00000000000000(library (srfi :129 titlecase) (export char-title-case? char-titlecase string-titlecase) (import (except (rnrs) char-titlecase char-title-case? string-titlecase) (srfi private include)) (include/resolve ("srfi" "%3a129") "titlemaps.scm") (include/resolve ("srfi" "%3a129") "titlecase-impl.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a129/titlemaps.scm000066400000000000000000000162541375154206600222440ustar00rootroot00000000000000;;;; Alists for titlecase functions ;;; Assumes that char->integer and integer->char are a subset of Unicode ;;; codepoint mappings rather than some random codes, as R5RS allows ;;; but R[67]RS do not. It may be necessary to remove some lines if ;;; the codepoints referred to don't correspond to characters present ;;; in the implementation. ;;; These maps are valid from Unicode 5.0 to at least Unicode 8.0 ;;; and are expected to be stable for the foreseeable future. ;; Alist mapping titlecase characters to themselves (define titlecase-chars '( (#x01C5 #x01C5) ; LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON (#x01C8 #x01C8) ; LATIN CAPITAL LETTER L WITH SMALL LETTER J (#x01CB #x01CB) ; LATIN CAPITAL LETTER N WITH SMALL LETTER J (#x01F2 #x01F2) ; LATIN CAPITAL LETTER D WITH SMALL LETTER Z (#x1F88 #x1F88) ; GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI (#x1F89 #x1F89) ; GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI (#x1F8A #x1F8A) ; GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI (#x1F8B #x1F8B) ; GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI (#x1F8C #x1F8C) ; GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI (#x1F8D #x1F8D) ; GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI (#x1F8E #x1F8E) ; GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI (#x1F8F #x1F8F) ; GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI (#x1F98 #x1F98) ; GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI (#x1F99 #x1F99) ; GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI (#x1F9A #x1F9A) ; GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI (#x1F9B #x1F9B) ; GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI (#x1F9C #x1F9C) ; GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI (#x1F9D #x1F9D) ; GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI (#x1F9E #x1F9E) ; GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI (#x1F9F #x1F9F) ; GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI (#x1FA8 #x1FA8) ; GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI (#x1FA9 #x1FA9) ; GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI (#x1FAA #x1FAA) ; GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI (#x1FAB #x1FAB) ; GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI (#x1FAC #x1FAC) ; GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI (#x1FAD #x1FAD) ; GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI (#x1FAE #x1FAE) ; GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI (#x1FAF #x1FAF) ; GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI (#x1FBC #x1FBC) ; GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI (#x1FCC #x1FCC) ; GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI (#x1FFC #x1FFC) ; GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI )) ;; Alist mapping characters to their single-letter titlecase equivalents ;; when those are distinct from their uppercase equivalents (define title-single-map (append titlecase-chars '( (#x01C4 #x01C5) ; LATIN CAPITAL LETTER DZ WITH CARON (#x01C6 #x01C5) ; LATIN SMALL LETTER DZ WITH CARON (#x01C7 #x01C8) ; LATIN CAPITAL LETTER LJ (#x01C9 #x01C8) ; LATIN SMALL LETTER LJ (#x01CA #x01CB) ; LATIN CAPITAL LETTER NJ (#x01CC #x01CB) ; LATIN SMALL LETTER NJ (#x01F1 #x01F2) ; LATIN CAPITAL LETTER DZ (#x01F3 #x01F2) ; LATIN SMALL LETTER DZ ))) ;; Alist mapping characters to their multiple-letter titlecase equivalents (define title-multiple-map (append title-single-map '( (#x00DF #x0053 #x0073) ; LATIN SMALL LETTER SHARP S (#xFB00 #x0046 #x0066) ; LATIN SMALL LIGATURE FF (#xFB01 #x0046 #x0069) ; LATIN SMALL LIGATURE FI (#xFB02 #x0046 #x006C) ; LATIN SMALL LIGATURE FL (#xFB03 #x0046 #x0066 #x0069) ; LATIN SMALL LIGATURE FFI (#xFB04 #x0046 #x0066 #x006C) ; LATIN SMALL LIGATURE FFL (#xFB05 #x0053 #x0074) ; LATIN SMALL LIGATURE LONG S T (#xFB06 #x0053 #x0074) ; LATIN SMALL LIGATURE ST (#x0587 #x0535 #x0582) ; ARMENIAN SMALL LIGATURE ECH YIWN (#xFB13 #x0544 #x0576) ; ARMENIAN SMALL LIGATURE MEN NOW (#xFB14 #x0544 #x0565) ; ARMENIAN SMALL LIGATURE MEN ECH (#xFB15 #x0544 #x056B) ; ARMENIAN SMALL LIGATURE MEN INI (#xFB16 #x054E #x0576) ; ARMENIAN SMALL LIGATURE VEW NOW (#xFB17 #x0544 #x056D) ; ARMENIAN SMALL LIGATURE MEN XEH (#x0149 #x02BC #x004E) ; LATIN SMALL LETTER N PRECEDED BY APOSTROPHE (#x0390 #x0399 #x0308 #x0301) ; GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS (#x03B0 #x03A5 #x0308 #x0301) ; GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS (#x01F0 #x004A #x030C) ; LATIN SMALL LETTER J WITH CARON (#x1E96 #x0048 #x0331) ; LATIN SMALL LETTER H WITH LINE BELOW (#x1E97 #x0054 #x0308) ; LATIN SMALL LETTER T WITH DIAERESIS (#x1E98 #x0057 #x030A) ; LATIN SMALL LETTER W WITH RING ABOVE (#x1E99 #x0059 #x030A) ; LATIN SMALL LETTER Y WITH RING ABOVE (#x1E9A #x0041 #x02BE) ; LATIN SMALL LETTER A WITH RIGHT HALF RING (#x1F50 #x03A5 #x0313) ; GREEK SMALL LETTER UPSILON WITH PSILI (#x1F52 #x03A5 #x0313 #x0300) ; GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA (#x1F54 #x03A5 #x0313 #x0301) ; GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA (#x1F56 #x03A5 #x0313 #x0342) ; GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI (#x1FB6 #x0391 #x0342) ; GREEK SMALL LETTER ALPHA WITH PERISPOMENI (#x1FC6 #x0397 #x0342) ; GREEK SMALL LETTER ETA WITH PERISPOMENI (#x1FD2 #x0399 #x0308 #x0300) ; GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA (#x1FD3 #x0399 #x0308 #x0301) ; GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA (#x1FD6 #x0399 #x0342) ; GREEK SMALL LETTER IOTA WITH PERISPOMENI (#x1FD7 #x0399 #x0308 #x0342) ; GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI (#x1FE2 #x03A5 #x0308 #x0300) ; GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA (#x1FE3 #x03A5 #x0308 #x0301) ; GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA (#x1FE4 #x03A1 #x0313) ; GREEK SMALL LETTER RHO WITH PSILI (#x1FE6 #x03A5 #x0342) ; GREEK SMALL LETTER UPSILON WITH PERISPOMENI (#x1FE7 #x03A5 #x0308 #x0342) ; GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI (#x1FF6 #x03A9 #x0342) ; GREEK SMALL LETTER OMEGA WITH PERISPOMENI (#x1FB2 #x1FBA #x0345) ; GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI (#x1FB4 #x0386 #x0345) ; GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI (#x1FC2 #x1FCA #x0345) ; GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI (#x1FC4 #x0389 #x0345) ; GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI (#x1FF2 #x1FFA #x0345) ; GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI (#x1FF4 #x038F #x0345) ; GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI (#x1FB7 #x0391 #x0342 #x0345) ; GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI (#x1FC7 #x0397 #x0342 #x0345) ; GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI (#x1FF7 #x03A9 #x0342 #x0345) ; GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI ))) ;; Alist mapping characters to their multiple-character lowercase equivalents (define lower-multiple-map '( (#x0130 #x0069 #x0307) ; LATIN CAPITAL LETTER I WITH DOT ABOVE )) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a13.sls000066400000000000000000000033511375154206600201630ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :13) (export list->string make-string reverse-list->string string string->list string-any string-append string-append/shared string-ci< string-ci<= string-ci<> string-ci= string-ci> string-ci>= string-compare string-compare-ci string-concatenate string-concatenate-reverse string-concatenate-reverse/shared string-concatenate/shared string-contains string-contains-ci string-copy string-copy! string-count string-delete string-downcase string-downcase! string-drop string-drop-right string-every string-fill! string-filter string-fold string-fold-right string-for-each string-for-each-index string-hash string-hash-ci string-index string-index-right string-join string-length string-map string-map! string-null? string-pad string-pad-right string-prefix-ci? string-prefix-length string-prefix-length-ci string-prefix? string-ref string-replace string-reverse string-reverse! string-set! string-skip string-skip-right string-suffix-ci? string-suffix-length string-suffix-length-ci string-suffix? string-tabulate string-take string-take-right string-titlecase string-titlecase! string-tokenize string-trim string-trim-both string-trim-right string-unfold string-unfold-right string-upcase string-upcase! string-xcopy! string< string<= string<> string= string> string>= string? substring/shared xsubstring) (import (srfi :13 strings)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a13/000077500000000000000000000000001375154206600174365ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a13/srfi-13.scm000066400000000000000000002301331375154206600213300ustar00rootroot00000000000000;;; SRFI 13 string library reference implementation -*- Scheme -*- ;;; Olin Shivers 7/2000 ;;; ;;; Copyright (c) 1988-1994 Massachusetts Institute of Technology. ;;; Copyright (c) 1998, 1999, 2000 Olin Shivers. All rights reserved. ;;; The details of the copyrights appear at the end of the file. Short ;;; summary: BSD-style open source. ;;; Exports: ;;; string-map string-map! ;;; string-fold string-unfold ;;; string-fold-right string-unfold-right ;;; string-tabulate string-for-each string-for-each-index ;;; string-every string-any ;;; string-hash string-hash-ci ;;; string-compare string-compare-ci ;;; string= string< string> string<= string>= string<> ;;; string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<> ;;; string-downcase string-upcase string-titlecase ;;; string-downcase! string-upcase! string-titlecase! ;;; string-take string-take-right ;;; string-drop string-drop-right ;;; string-pad string-pad-right ;;; string-trim string-trim-right string-trim-both ;;; string-filter string-delete ;;; string-index string-index-right ;;; string-skip string-skip-right ;;; string-count ;;; string-prefix-length string-prefix-length-ci ;;; string-suffix-length string-suffix-length-ci ;;; string-prefix? string-prefix-ci? ;;; string-suffix? string-suffix-ci? ;;; string-contains string-contains-ci ;;; string-copy! substring/shared ;;; string-reverse string-reverse! reverse-list->string ;;; string-concatenate string-concatenate/shared string-concatenate-reverse ;;; string-append/shared ;;; xsubstring string-xcopy! ;;; string-null? ;;; string-join ;;; string-tokenize ;;; string-replace ;;; ;;; R5RS extended: ;;; string->list string-copy string-fill! ;;; ;;; R5RS re-exports: ;;; string? make-string string-length string-ref string-set! ;;; ;;; R5RS re-exports (also defined here but commented-out): ;;; string string-append list->string ;;; ;;; Low-level routines: ;;; make-kmp-restart-vector string-kmp-partial-search kmp-step ;;; string-parse-start+end ;;; string-parse-final-start+end ;;; let-string-start+end ;;; check-substring-spec ;;; substring-spec-ok? ;;; Imports ;;; This is a fairly large library. While it was written for portability, you ;;; must be aware of its dependencies in order to run it in a given scheme ;;; implementation. Here is a complete list of the dependencies it has and the ;;; assumptions it makes beyond stock R5RS Scheme: ;;; ;;; This code has the following non-R5RS dependencies: ;;; - (RECEIVE (var ...) mv-exp body ...) multiple-value binding macro; ;;; ;;; - Various imports from the char-set library for the routines that can ;;; take char-set arguments; ;;; ;;; - An n-ary ERROR procedure; ;;; ;;; - BITWISE-AND for the hash functions; ;;; ;;; - A simple CHECK-ARG procedure for checking parameter values; it is ;;; (lambda (pred val proc) ;;; (if (pred val) val (error "Bad arg" val pred proc))) ;;; ;;; - :OPTIONAL and LET-OPTIONALS* macros for parsing, defaulting & ;;; type-checking optional parameters from a rest argument; ;;; ;;; - CHAR-CASED? and CHAR-TITLECASE for the STRING-TITLECASE & ;;; STRING-TITLECASE! procedures. The former returns true iff a character is ;;; one that has case distinctions; in ASCII it returns true on a-z and A-Z. ;;; CHAR-TITLECASE is analagous to CHAR-UPCASE and CHAR-DOWNCASE. In ASCII & ;;; Latin-1, it is the same as CHAR-UPCASE. ;;; ;;; The code depends upon a small set of core string primitives from R5RS: ;;; MAKE-STRING STRING-REF STRING-SET! STRING? STRING-LENGTH SUBSTRING ;;; (Actually, SUBSTRING is not a primitive, but we assume that an ;;; implementation's native version is probably faster than one we could ;;; define, so we import it from R5RS.) ;;; ;;; The code depends upon a small set of R5RS character primitives: ;;; char? char=? char-ci=? charinteger (for the hash functions) ;;; ;;; We assume the following: ;;; - CHAR-DOWNCASE o CHAR-UPCASE = CHAR-DOWNCASE ;;; - CHAR-CI=? is equivalent to ;;; (lambda (c1 c2) (char=? (char-downcase (char-upcase c1)) ;;; (char-downcase (char-upcase c2)))) ;;; - CHAR-UPCASE, CHAR-DOWNCASE and CHAR-TITLECASE are locale-insensitive ;;; and consistent with Unicode's 1-1 char-mapping spec. ;;; These things are typically true, but if not, you would need to modify ;;; the case-mapping and case-insensitive routines. ;;; Enough introductory blather. On to the source code. (But see the end of ;;; the file for further notes on porting & performance tuning.) ;;; Support for START/END substring specs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This macro parses optional start/end arguments from arg lists, defaulting ;;; them to 0/(string-length s), and checks them for correctness. (define-syntax let-string-start+end (syntax-rules () ((let-string-start+end (start end) proc s-exp args-exp body ...) (receive (start end) (string-parse-final-start+end proc s-exp args-exp) body ...)) ((let-string-start+end (start end rest) proc s-exp args-exp body ...) (receive (rest start end) (string-parse-start+end proc s-exp args-exp) body ...)))) ;;; This one parses out a *pair* of final start/end indices. ;;; Not exported; for internal use. (define-syntax let-string-start+end2 (syntax-rules () ((l-s-s+e2 (start1 end1 start2 end2) proc s1 s2 args body ...) (let ((procv proc)) ; Make sure PROC is only evaluated once. (let-string-start+end (start1 end1 rest) procv s1 args (let-string-start+end (start2 end2) procv s2 rest body ...)))))) ;;; Returns three values: rest start end (define (string-parse-start+end proc s args) (if (not (string? s)) (error "Non-string value" proc s)) (let ((slen (string-length s))) (if (pair? args) (let ((start (car args)) (args (cdr args))) (if (and (integer? start) (exact? start) (>= start 0)) (receive (end args) (if (pair? args) (let ((end (car args)) (args (cdr args))) (if (and (integer? end) (exact? end) (<= end slen)) (values end args) (error "Illegal substring END spec" proc end s))) (values slen args)) (if (<= start end) (values args start end) (error "Illegal substring START/END spec" proc start end s))) (error "Illegal substring START spec" proc start s))) (values '() 0 slen)))) (define (string-parse-final-start+end proc s args) (receive (rest start end) (string-parse-start+end proc s args) (if (pair? rest) (error "Extra arguments to procedure" proc rest) (values start end)))) (define (substring-spec-ok? s start end) (and (string? s) (integer? start) (exact? start) (integer? end) (exact? end) (<= 0 start) (<= start end) (<= end (string-length s)))) (define (check-substring-spec proc s start end) (if (not (substring-spec-ok? s start end)) (error "Illegal substring spec." proc s start end))) ;;; Defined by R5RS, so commented out here. ;(define (string . chars) ; (let* ((len (length chars)) ; (ans (make-string len))) ; (do ((i 0 (+ i 1)) ; (chars chars (cdr chars))) ; ((>= i len)) ; (string-set! ans i (car chars))) ; ans)) ; ;(define (string . chars) (string-unfold null? car cdr chars)) ;;; substring/shared S START [END] ;;; string-copy S [START END] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; All this goop is just arg parsing & checking surrounding a call to the ;;; actual primitive, %SUBSTRING/SHARED. (define (substring/shared s start . maybe-end) (check-arg string? s substring/shared) (let ((slen (string-length s))) (check-arg (lambda (start) (and (integer? start) (exact? start) (<= 0 start))) start substring/shared) (%substring/shared s start (:optional maybe-end slen (lambda (end) (and (integer? end) (exact? end) (<= start end) (<= end slen))))))) ;;; Split out so that other routines in this library can avoid arg-parsing ;;; overhead for END parameter. (define (%substring/shared s start end) (if (and (zero? start) (= end (string-length s))) s (substring s start end))) (define (string-copy s . maybe-start+end) (let-string-start+end (start end) string-copy s maybe-start+end (substring s start end))) ;This library uses the R5RS SUBSTRING, but doesn't export it. ;Here is a definition, just for completeness. ;(define (substring s start end) ; (check-substring-spec substring s start end) ; (let* ((slen (- end start)) ; (ans (make-string slen))) ; (do ((i 0 (+ i 1)) ; (j start (+ j 1))) ; ((>= i slen) ans) ; (string-set! ans i (string-ref s j))))) ;;; Basic iterators and other higher-order abstractions ;;; (string-map proc s [start end]) ;;; (string-map! proc s [start end]) ;;; (string-fold kons knil s [start end]) ;;; (string-fold-right kons knil s [start end]) ;;; (string-unfold p f g seed [base make-final]) ;;; (string-unfold-right p f g seed [base make-final]) ;;; (string-for-each proc s [start end]) ;;; (string-for-each-index proc s [start end]) ;;; (string-every char-set/char/pred s [start end]) ;;; (string-any char-set/char/pred s [start end]) ;;; (string-tabulate proc len) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; You want compiler support for high-level transforms on fold and unfold ops. ;;; You'd at least like a lot of inlining for clients of these procedures. ;;; Don't hold your breath. (define (string-map proc s . maybe-start+end) (check-arg procedure? proc string-map) (let-string-start+end (start end) string-map s maybe-start+end (%string-map proc s start end))) (define (%string-map proc s start end) ; Internal utility (let* ((len (- end start)) (ans (make-string len))) (do ((i (- end 1) (- i 1)) (j (- len 1) (- j 1))) ((< j 0)) (string-set! ans j (proc (string-ref s i)))) ans)) (define (string-map! proc s . maybe-start+end) (check-arg procedure? proc string-map!) (let-string-start+end (start end) string-map! s maybe-start+end (%string-map! proc s start end))) (define (%string-map! proc s start end) (do ((i (- end 1) (- i 1))) ((< i start)) (string-set! s i (proc (string-ref s i))))) (define (string-fold kons knil s . maybe-start+end) (check-arg procedure? kons string-fold) (let-string-start+end (start end) string-fold s maybe-start+end (let lp ((v knil) (i start)) (if (< i end) (lp (kons (string-ref s i) v) (+ i 1)) v)))) (define (string-fold-right kons knil s . maybe-start+end) (check-arg procedure? kons string-fold-right) (let-string-start+end (start end) string-fold-right s maybe-start+end (let lp ((v knil) (i (- end 1))) (if (>= i start) (lp (kons (string-ref s i) v) (- i 1)) v)))) ;;; (string-unfold p f g seed [base make-final]) ;;; This is the fundamental constructor for strings. ;;; - G is used to generate a series of "seed" values from the initial seed: ;;; SEED, (G SEED), (G^2 SEED), (G^3 SEED), ... ;;; - P tells us when to stop -- when it returns true when applied to one ;;; of these seed values. ;;; - F maps each seed value to the corresponding character ;;; in the result string. These chars are assembled into the ;;; string in a left-to-right order. ;;; - BASE is the optional initial/leftmost portion of the constructed string; ;;; it defaults to the empty string "". ;;; - MAKE-FINAL is applied to the terminal seed value (on which P returns ;;; true) to produce the final/rightmost portion of the constructed string. ;;; It defaults to (LAMBDA (X) ""). ;;; ;;; In other words, the following (simple, inefficient) definition holds: ;;; (define (string-unfold p f g seed base make-final) ;;; (string-append base ;;; (let recur ((seed seed)) ;;; (if (p seed) (make-final seed) ;;; (string-append (string (f seed)) ;;; (recur (g seed))))))) ;;; ;;; STRING-UNFOLD is a fairly powerful constructor -- you can use it to ;;; reverse a string, copy a string, convert a list to a string, read ;;; a port into a string, and so forth. Examples: ;;; (port->string port) = ;;; (string-unfold (compose eof-object? peek-char) ;;; read-char values port) ;;; ;;; (list->string lis) = (string-unfold null? car cdr lis) ;;; ;;; (tabulate-string f size) = (string-unfold (lambda (i) (= i size)) f add1 0) ;;; A problem with the following simple formulation is that it pushes one ;;; stack frame for every char in the result string -- an issue if you are ;;; using it to read a 100kchar string. So we don't use it -- but I include ;;; it to give a clear, straightforward description of what the function ;;; does. ;(define (string-unfold p f g seed base make-final) ; (let ((ans (let recur ((seed seed) (i (string-length base))) ; (if (p seed) ; (let* ((final (make-final seed)) ; (ans (make-string (+ i (string-length final))))) ; (string-copy! ans i final) ; ans) ; ; (let* ((c (f seed)) ; (s (recur (g seed) (+ i 1)))) ; (string-set! s i c) ; s))))) ; (string-copy! ans 0 base) ; ans)) ;;; The strategy is to allocate a series of chunks into which we stash the ;;; chars as we generate them. Chunk size goes up in powers of two starting ;;; with 40 and levelling out at 4k, i.e. ;;; 40 40 80 160 320 640 1280 2560 4096 4096 4096 4096 4096... ;;; This should work pretty well for short strings, 1-line (80 char) strings, ;;; and longer ones. When done, we allocate an answer string and copy the ;;; chars over from the chunk buffers. (define (string-unfold p f g seed . base+make-final) (check-arg procedure? p string-unfold) (check-arg procedure? f string-unfold) (check-arg procedure? g string-unfold) (let-optionals* base+make-final ((base "" (string? base)) (make-final (lambda (x) "") (procedure? make-final))) (let lp ((chunks '()) ; Previously filled chunks (nchars 0) ; Number of chars in CHUNKS (chunk (make-string 40)) ; Current chunk into which we write (chunk-len 40) (i 0) ; Number of chars written into CHUNK (seed seed)) (let lp2 ((i i) (seed seed)) (if (not (p seed)) (let ((c (f seed)) (seed (g seed))) (if (< i chunk-len) (begin (string-set! chunk i c) (lp2 (+ i 1) seed)) (let* ((nchars2 (+ chunk-len nchars)) (chunk-len2 (min 4096 nchars2)) (new-chunk (make-string chunk-len2))) (string-set! new-chunk 0 c) (lp (cons chunk chunks) (+ nchars chunk-len) new-chunk chunk-len2 1 seed)))) ;; We're done. Make the answer string & install the bits. (let* ((final (make-final seed)) (flen (string-length final)) (base-len (string-length base)) (j (+ base-len nchars i)) (ans (make-string (+ j flen)))) (%string-copy! ans j final 0 flen) ; Install FINAL. (let ((j (- j i))) (%string-copy! ans j chunk 0 i) ; Install CHUNK[0,I). (let lp ((j j) (chunks chunks)) ; Install CHUNKS. (if (pair? chunks) (let* ((chunk (car chunks)) (chunks (cdr chunks)) (chunk-len (string-length chunk)) (j (- j chunk-len))) (%string-copy! ans j chunk 0 chunk-len) (lp j chunks))))) (%string-copy! ans 0 base 0 base-len) ; Install BASE. ans)))))) (define (string-unfold-right p f g seed . base+make-final) (let-optionals* base+make-final ((base "" (string? base)) (make-final (lambda (x) "") (procedure? make-final))) (let lp ((chunks '()) ; Previously filled chunks (nchars 0) ; Number of chars in CHUNKS (chunk (make-string 40)) ; Current chunk into which we write (chunk-len 40) (i 40) ; Number of chars available in CHUNK (seed seed)) (let lp2 ((i i) (seed seed)) ; Fill up CHUNK from right (if (not (p seed)) ; to left. (let ((c (f seed)) (seed (g seed))) (if (> i 0) (let ((i (- i 1))) (string-set! chunk i c) (lp2 i seed)) (let* ((nchars2 (+ chunk-len nchars)) (chunk-len2 (min 4096 nchars2)) (new-chunk (make-string chunk-len2)) (i (- chunk-len2 1))) (string-set! new-chunk i c) (lp (cons chunk chunks) (+ nchars chunk-len) new-chunk chunk-len2 i seed)))) ;; We're done. Make the answer string & install the bits. (let* ((final (make-final seed)) (flen (string-length final)) (base-len (string-length base)) (chunk-used (- chunk-len i)) (j (+ base-len nchars chunk-used)) (ans (make-string (+ j flen)))) (%string-copy! ans 0 final 0 flen) ; Install FINAL. (%string-copy! ans flen chunk i chunk-len); Install CHUNK[I,). (let lp ((j (+ flen chunk-used)) ; Install CHUNKS. (chunks chunks)) (if (pair? chunks) (let* ((chunk (car chunks)) (chunks (cdr chunks)) (chunk-len (string-length chunk))) (%string-copy! ans j chunk 0 chunk-len) (lp (+ j chunk-len) chunks)) (%string-copy! ans j base 0 base-len))); Install BASE. ans)))))) (define (string-for-each proc s . maybe-start+end) (check-arg procedure? proc string-for-each) (let-string-start+end (start end) string-for-each s maybe-start+end (let lp ((i start)) (if (< i end) (begin (proc (string-ref s i)) (lp (+ i 1))))))) (define (string-for-each-index proc s . maybe-start+end) (check-arg procedure? proc string-for-each-index) (let-string-start+end (start end) string-for-each-index s maybe-start+end (let lp ((i start)) (if (< i end) (begin (proc i) (lp (+ i 1))))))) (define (string-every criterion s . maybe-start+end) (let-string-start+end (start end) string-every s maybe-start+end (cond ((char? criterion) (let lp ((i start)) (or (>= i end) (and (char=? criterion (string-ref s i)) (lp (+ i 1)))))) ((char-set? criterion) (let lp ((i start)) (or (>= i end) (and (char-set-contains? criterion (string-ref s i)) (lp (+ i 1)))))) ((procedure? criterion) ; Slightly funky loop so that (or (= start end) ; final (PRED S[END-1]) call (let lp ((i start)) ; is a tail call. (let ((c (string-ref s i)) (i1 (+ i 1))) (if (= i1 end) (criterion c) ; Tail call. (and (criterion c) (lp i1))))))) (else (error "Second param is neither char-set, char, or predicate procedure." string-every criterion))))) (define (string-any criterion s . maybe-start+end) (let-string-start+end (start end) string-any s maybe-start+end (cond ((char? criterion) (let lp ((i start)) (and (< i end) (or (char=? criterion (string-ref s i)) (lp (+ i 1)))))) ((char-set? criterion) (let lp ((i start)) (and (< i end) (or (char-set-contains? criterion (string-ref s i)) (lp (+ i 1)))))) ((procedure? criterion) ; Slightly funky loop so that (and (< start end) ; final (PRED S[END-1]) call (let lp ((i start)) ; is a tail call. (let ((c (string-ref s i)) (i1 (+ i 1))) (if (= i1 end) (criterion c) ; Tail call (or (criterion c) (lp i1))))))) (else (error "Second param is neither char-set, char, or predicate procedure." string-any criterion))))) (define (string-tabulate proc len) (check-arg procedure? proc string-tabulate) (check-arg (lambda (val) (and (integer? val) (exact? val) (<= 0 val))) len string-tabulate) (let ((s (make-string len))) (do ((i (- len 1) (- i 1))) ((< i 0)) (string-set! s i (proc i))) s)) ;;; string-prefix-length[-ci] s1 s2 [start1 end1 start2 end2] ;;; string-suffix-length[-ci] s1 s2 [start1 end1 start2 end2] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Find the length of the common prefix/suffix. ;;; It is not required that the two substrings passed be of equal length. ;;; This was microcode in MIT Scheme -- a very tightly bummed primitive. ;;; %STRING-PREFIX-LENGTH is the core routine of all string-comparisons, ;;; so should be as tense as possible. (define (%string-prefix-length s1 start1 end1 s2 start2 end2) (let* ((delta (min (- end1 start1) (- end2 start2))) (end1 (+ start1 delta))) (if (and (eq? s1 s2) (= start1 start2)) ; EQ fast path delta (let lp ((i start1) (j start2)) ; Regular path (if (or (>= i end1) (not (char=? (string-ref s1 i) (string-ref s2 j)))) (- i start1) (lp (+ i 1) (+ j 1))))))) (define (%string-suffix-length s1 start1 end1 s2 start2 end2) (let* ((delta (min (- end1 start1) (- end2 start2))) (start1 (- end1 delta))) (if (and (eq? s1 s2) (= end1 end2)) ; EQ fast path delta (let lp ((i (- end1 1)) (j (- end2 1))) ; Regular path (if (or (< i start1) (not (char=? (string-ref s1 i) (string-ref s2 j)))) (- (- end1 i) 1) (lp (- i 1) (- j 1))))))) (define (%string-prefix-length-ci s1 start1 end1 s2 start2 end2) (let* ((delta (min (- end1 start1) (- end2 start2))) (end1 (+ start1 delta))) (if (and (eq? s1 s2) (= start1 start2)) ; EQ fast path delta (let lp ((i start1) (j start2)) ; Regular path (if (or (>= i end1) (not (char-ci=? (string-ref s1 i) (string-ref s2 j)))) (- i start1) (lp (+ i 1) (+ j 1))))))) (define (%string-suffix-length-ci s1 start1 end1 s2 start2 end2) (let* ((delta (min (- end1 start1) (- end2 start2))) (start1 (- end1 delta))) (if (and (eq? s1 s2) (= end1 end2)) ; EQ fast path delta (let lp ((i (- end1 1)) (j (- end2 1))) ; Regular path (if (or (< i start1) (not (char-ci=? (string-ref s1 i) (string-ref s2 j)))) (- (- end1 i) 1) (lp (- i 1) (- j 1))))))) (define (string-prefix-length s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-prefix-length s1 s2 maybe-starts+ends (%string-prefix-length s1 start1 end1 s2 start2 end2))) (define (string-suffix-length s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-suffix-length s1 s2 maybe-starts+ends (%string-suffix-length s1 start1 end1 s2 start2 end2))) (define (string-prefix-length-ci s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-prefix-length-ci s1 s2 maybe-starts+ends (%string-prefix-length-ci s1 start1 end1 s2 start2 end2))) (define (string-suffix-length-ci s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-suffix-length-ci s1 s2 maybe-starts+ends (%string-suffix-length-ci s1 start1 end1 s2 start2 end2))) ;;; string-prefix? s1 s2 [start1 end1 start2 end2] ;;; string-suffix? s1 s2 [start1 end1 start2 end2] ;;; string-prefix-ci? s1 s2 [start1 end1 start2 end2] ;;; string-suffix-ci? s1 s2 [start1 end1 start2 end2] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; These are all simple derivatives of the previous counting funs. (define (string-prefix? s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-prefix? s1 s2 maybe-starts+ends (%string-prefix? s1 start1 end1 s2 start2 end2))) (define (string-suffix? s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-suffix? s1 s2 maybe-starts+ends (%string-suffix? s1 start1 end1 s2 start2 end2))) (define (string-prefix-ci? s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-prefix-ci? s1 s2 maybe-starts+ends (%string-prefix-ci? s1 start1 end1 s2 start2 end2))) (define (string-suffix-ci? s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-suffix-ci? s1 s2 maybe-starts+ends (%string-suffix-ci? s1 start1 end1 s2 start2 end2))) ;;; Here are the internal routines that do the real work. (define (%string-prefix? s1 start1 end1 s2 start2 end2) (let ((len1 (- end1 start1))) (and (<= len1 (- end2 start2)) ; Quick check (= (%string-prefix-length s1 start1 end1 s2 start2 end2) len1)))) (define (%string-suffix? s1 start1 end1 s2 start2 end2) (let ((len1 (- end1 start1))) (and (<= len1 (- end2 start2)) ; Quick check (= len1 (%string-suffix-length s1 start1 end1 s2 start2 end2))))) (define (%string-prefix-ci? s1 start1 end1 s2 start2 end2) (let ((len1 (- end1 start1))) (and (<= len1 (- end2 start2)) ; Quick check (= len1 (%string-prefix-length-ci s1 start1 end1 s2 start2 end2))))) (define (%string-suffix-ci? s1 start1 end1 s2 start2 end2) (let ((len1 (- end1 start1))) (and (<= len1 (- end2 start2)) ; Quick check (= len1 (%string-suffix-length-ci s1 start1 end1 s2 start2 end2))))) ;;; string-compare s1 s2 proc< proc= proc> [start1 end1 start2 end2] ;;; string-compare-ci s1 s2 proc< proc= proc> [start1 end1 start2 end2] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Primitive string-comparison functions. ;;; Continuation order is different from MIT Scheme. ;;; Continuations are applied to s1's mismatch index; ;;; in the case of equality, this is END1. (define (%string-compare s1 start1 end1 s2 start2 end2 proc< proc= proc>) (let ((size1 (- end1 start1)) (size2 (- end2 start2))) (let ((match (%string-prefix-length s1 start1 end1 s2 start2 end2))) (if (= match size1) ((if (= match size2) proc= proc<) end1) ((if (= match size2) proc> (if (char)) (+ match start1)))))) (define (%string-compare-ci s1 start1 end1 s2 start2 end2 proc< proc= proc>) (let ((size1 (- end1 start1)) (size2 (- end2 start2))) (let ((match (%string-prefix-length-ci s1 start1 end1 s2 start2 end2))) (if (= match size1) ((if (= match size2) proc= proc<) end1) ((if (= match size2) proc> (if (char-ci)) (+ start1 match)))))) (define (string-compare s1 s2 proc< proc= proc> . maybe-starts+ends) (check-arg procedure? proc< string-compare) (check-arg procedure? proc= string-compare) (check-arg procedure? proc> string-compare) (let-string-start+end2 (start1 end1 start2 end2) string-compare s1 s2 maybe-starts+ends (%string-compare s1 start1 end1 s2 start2 end2 proc< proc= proc>))) (define (string-compare-ci s1 s2 proc< proc= proc> . maybe-starts+ends) (check-arg procedure? proc< string-compare-ci) (check-arg procedure? proc= string-compare-ci) (check-arg procedure? proc> string-compare-ci) (let-string-start+end2 (start1 end1 start2 end2) string-compare-ci s1 s2 maybe-starts+ends (%string-compare-ci s1 start1 end1 s2 start2 end2 proc< proc= proc>))) ;;; string= string<> string-ci= string-ci<> ;;; string< string> string-ci< string-ci> ;;; string<= string>= string-ci<= string-ci>= ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Simple definitions in terms of the previous comparison funs. ;;; I sure hope the %STRING-COMPARE calls get integrated. (define (string= s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string= s1 s2 maybe-starts+ends (and (= (- end1 start1) (- end2 start2)) ; Quick filter (or (and (eq? s1 s2) (= start1 start2)) ; Fast path (%string-compare s1 start1 end1 s2 start2 end2 ; Real test (lambda (i) #f) values (lambda (i) #f)))))) (define (string<> s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string<> s1 s2 maybe-starts+ends (or (not (= (- end1 start1) (- end2 start2))) ; Fast path (and (not (and (eq? s1 s2) (= start1 start2))) ; Quick filter (%string-compare s1 start1 end1 s2 start2 end2 ; Real test values (lambda (i) #f) values))))) (define (string< s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string< s1 s2 maybe-starts+ends (if (and (eq? s1 s2) (= start1 start2)) ; Fast path (< end1 end2) (%string-compare s1 start1 end1 s2 start2 end2 ; Real test values (lambda (i) #f) (lambda (i) #f))))) (define (string> s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string> s1 s2 maybe-starts+ends (if (and (eq? s1 s2) (= start1 start2)) ; Fast path (> end1 end2) (%string-compare s1 start1 end1 s2 start2 end2 ; Real test (lambda (i) #f) (lambda (i) #f) values)))) (define (string<= s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string<= s1 s2 maybe-starts+ends (if (and (eq? s1 s2) (= start1 start2)) ; Fast path (<= end1 end2) (%string-compare s1 start1 end1 s2 start2 end2 ; Real test values values (lambda (i) #f))))) (define (string>= s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string>= s1 s2 maybe-starts+ends (if (and (eq? s1 s2) (= start1 start2)) ; Fast path (>= end1 end2) (%string-compare s1 start1 end1 s2 start2 end2 ; Real test (lambda (i) #f) values values)))) (define (string-ci= s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-ci= s1 s2 maybe-starts+ends (and (= (- end1 start1) (- end2 start2)) ; Quick filter (or (and (eq? s1 s2) (= start1 start2)) ; Fast path (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test (lambda (i) #f) values (lambda (i) #f)))))) (define (string-ci<> s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-ci<> s1 s2 maybe-starts+ends (or (not (= (- end1 start1) (- end2 start2))) ; Fast path (and (not (and (eq? s1 s2) (= start1 start2))) ; Quick filter (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test values (lambda (i) #f) values))))) (define (string-ci< s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-ci< s1 s2 maybe-starts+ends (if (and (eq? s1 s2) (= start1 start2)) ; Fast path (< end1 end2) (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test values (lambda (i) #f) (lambda (i) #f))))) (define (string-ci> s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-ci> s1 s2 maybe-starts+ends (if (and (eq? s1 s2) (= start1 start2)) ; Fast path (> end1 end2) (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test (lambda (i) #f) (lambda (i) #f) values)))) (define (string-ci<= s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-ci<= s1 s2 maybe-starts+ends (if (and (eq? s1 s2) (= start1 start2)) ; Fast path (<= end1 end2) (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test values values (lambda (i) #f))))) (define (string-ci>= s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-ci>= s1 s2 maybe-starts+ends (if (and (eq? s1 s2) (= start1 start2)) ; Fast path (>= end1 end2) (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test (lambda (i) #f) values values)))) ;;; Hash ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND, with sleaze thrown in ;;; to keep the intermediate values small. (We do the calculation with just ;;; enough bits to represent BOUND, masking off high bits at each step in ;;; calculation. If this screws up any important properties of the hash ;;; function I'd like to hear about it. -Olin) ;;; ;;; If you keep BOUND small enough, the intermediate calculations will ;;; always be fixnums. How small is dependent on the underlying Scheme system; ;;; we use a default BOUND of 2^22 = 4194304, which should hack it in ;;; Schemes that give you at least 29 signed bits for fixnums. The core ;;; calculation that you don't want to overflow is, worst case, ;;; (+ 65535 (* 37 (- bound 1))) ;;; where 65535 is the max character code. Choose the default BOUND to be the ;;; biggest power of two that won't cause this expression to fixnum overflow, ;;; and everything will be copacetic. (define (%string-hash s char->int bound start end) (let ((iref (lambda (s i) (char->int (string-ref s i)))) ;; Compute a 111...1 mask that will cover BOUND-1: (mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh? (if (>= i bound) (- i 1) (lp (+ i i)))))) (let lp ((i start) (ans 0)) (if (>= i end) (modulo ans bound) (lp (+ i 1) (bitwise-and mask (+ (* 37 ans) (iref s i)))))))) (define (string-hash s . maybe-bound+start+end) (let-optionals* maybe-bound+start+end ((bound 4194304 (and (integer? bound) (exact? bound) (<= 0 bound))) rest) (let ((bound (if (zero? bound) 4194304 bound))) ; 0 means default. (let-string-start+end (start end) string-hash s rest (%string-hash s char->integer bound start end))))) (define (string-hash-ci s . maybe-bound+start+end) (let-optionals* maybe-bound+start+end ((bound 4194304 (and (integer? bound) (exact? bound) (<= 0 bound))) rest) (let ((bound (if (zero? bound) 4194304 bound))) ; 0 means default. (let-string-start+end (start end) string-hash-ci s rest (%string-hash s (lambda (c) (char->integer (char-downcase c))) bound start end))))) ;;; Case hacking ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; string-upcase s [start end] ;;; string-upcase! s [start end] ;;; string-downcase s [start end] ;;; string-downcase! s [start end] ;;; ;;; string-titlecase s [start end] ;;; string-titlecase! s [start end] ;;; Capitalize every contiguous alpha sequence: capitalise ;;; first char, lowercase rest. (define (string-upcase s . maybe-start+end) (let-string-start+end (start end) string-upcase s maybe-start+end (%string-map char-upcase s start end))) (define (string-upcase! s . maybe-start+end) (let-string-start+end (start end) string-upcase! s maybe-start+end (%string-map! char-upcase s start end))) (define (string-downcase s . maybe-start+end) (let-string-start+end (start end) string-downcase s maybe-start+end (%string-map char-downcase s start end))) (define (string-downcase! s . maybe-start+end) (let-string-start+end (start end) string-downcase! s maybe-start+end (%string-map! char-downcase s start end))) (define (%string-titlecase! s start end) (let lp ((i start)) (cond ((string-index s char-cased? i end) => (lambda (i) (string-set! s i (char-titlecase (string-ref s i))) (let ((i1 (+ i 1))) (cond ((string-skip s char-cased? i1 end) => (lambda (j) (string-downcase! s i1 j) (lp (+ j 1)))) (else (string-downcase! s i1 end))))))))) (define (string-titlecase! s . maybe-start+end) (let-string-start+end (start end) string-titlecase! s maybe-start+end (%string-titlecase! s start end))) (define (string-titlecase s . maybe-start+end) (let-string-start+end (start end) string-titlecase! s maybe-start+end (let ((ans (substring s start end))) (%string-titlecase! ans 0 (- end start)) ans))) ;;; Cutting & pasting strings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; string-take string nchars ;;; string-drop string nchars ;;; ;;; string-take-right string nchars ;;; string-drop-right string nchars ;;; ;;; string-pad string k [char start end] ;;; string-pad-right string k [char start end] ;;; ;;; string-trim string [char/char-set/pred start end] ;;; string-trim-right string [char/char-set/pred start end] ;;; string-trim-both string [char/char-set/pred start end] ;;; ;;; These trimmers invert the char-set meaning from MIT Scheme -- you ;;; say what you want to trim. (define (string-take s n) (check-arg string? s string-take) (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n (string-length s)))) n string-take) (%substring/shared s 0 n)) (define (string-take-right s n) (check-arg string? s string-take-right) (let ((len (string-length s))) (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len))) n string-take-right) (%substring/shared s (- len n) len))) (define (string-drop s n) (check-arg string? s string-drop) (let ((len (string-length s))) (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len))) n string-drop) (%substring/shared s n len))) (define (string-drop-right s n) (check-arg string? s string-drop-right) (let ((len (string-length s))) (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len))) n string-drop-right) (%substring/shared s 0 (- len n)))) (define (string-trim s . criterion+start+end) (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest) (let-string-start+end (start end) string-trim s rest (cond ((string-skip s criterion start end) => (lambda (i) (%substring/shared s i end))) (else ""))))) (define (string-trim-right s . criterion+start+end) (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest) (let-string-start+end (start end) string-trim-right s rest (cond ((string-skip-right s criterion start end) => (lambda (i) (%substring/shared s 0 (+ 1 i)))) (else ""))))) (define (string-trim-both s . criterion+start+end) (let-optionals* criterion+start+end ((criterion char-set:whitespace) rest) (let-string-start+end (start end) string-trim-both s rest (cond ((string-skip s criterion start end) => (lambda (i) (%substring/shared s i (+ 1 (string-skip-right s criterion i end))))) (else ""))))) (define (string-pad-right s n . char+start+end) (let-optionals* char+start+end ((char #\space (char? char)) rest) (let-string-start+end (start end) string-pad-right s rest (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n))) n string-pad-right) (let ((len (- end start))) (if (<= n len) (%substring/shared s start (+ start n)) (let ((ans (make-string n char))) (%string-copy! ans 0 s start end) ans)))))) (define (string-pad s n . char+start+end) (let-optionals* char+start+end ((char #\space (char? char)) rest) (let-string-start+end (start end) string-pad s rest (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n))) n string-pad) (let ((len (- end start))) (if (<= n len) (%substring/shared s (- end n) end) (let ((ans (make-string n char))) (%string-copy! ans (- n len) s start end) ans)))))) ;;; Filtering strings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; string-delete char/char-set/pred string [start end] ;;; string-filter char/char-set/pred string [start end] ;;; ;;; If the criterion is a char or char-set, we scan the string twice with ;;; string-fold -- once to determine the length of the result string, ;;; and once to do the filtered copy. ;;; If the criterion is a predicate, we don't do this double-scan strategy, ;;; because the predicate might have side-effects or be very expensive to ;;; compute. So we preallocate a temp buffer pessimistically, and only do ;;; one scan over S. This is likely to be faster and more space-efficient ;;; than consing a list. (define (string-delete criterion s . maybe-start+end) (let-string-start+end (start end) string-delete s maybe-start+end (if (procedure? criterion) (let* ((slen (- end start)) (temp (make-string slen)) (ans-len (string-fold (lambda (c i) (if (criterion c) i (begin (string-set! temp i c) (+ i 1)))) 0 s start end))) (if (= ans-len slen) temp (substring temp 0 ans-len))) (let* ((cset (cond ((char-set? criterion) criterion) ((char? criterion) (char-set criterion)) (else (error "string-delete criterion not predicate, char or char-set" criterion)))) (len (string-fold (lambda (c i) (if (char-set-contains? cset c) i (+ i 1))) 0 s start end)) (ans (make-string len))) (string-fold (lambda (c i) (if (char-set-contains? cset c) i (begin (string-set! ans i c) (+ i 1)))) 0 s start end) ans)))) (define (string-filter criterion s . maybe-start+end) (let-string-start+end (start end) string-filter s maybe-start+end (if (procedure? criterion) (let* ((slen (- end start)) (temp (make-string slen)) (ans-len (string-fold (lambda (c i) (if (criterion c) (begin (string-set! temp i c) (+ i 1)) i)) 0 s start end))) (if (= ans-len slen) temp (substring temp 0 ans-len))) (let* ((cset (cond ((char-set? criterion) criterion) ((char? criterion) (char-set criterion)) (else (error "string-delete criterion not predicate, char or char-set" criterion)))) (len (string-fold (lambda (c i) (if (char-set-contains? cset c) (+ i 1) i)) 0 s start end)) (ans (make-string len))) (string-fold (lambda (c i) (if (char-set-contains? cset c) (begin (string-set! ans i c) (+ i 1)) i)) 0 s start end) ans)))) ;;; String search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; string-index string char/char-set/pred [start end] ;;; string-index-right string char/char-set/pred [start end] ;;; string-skip string char/char-set/pred [start end] ;;; string-skip-right string char/char-set/pred [start end] ;;; string-count string char/char-set/pred [start end] ;;; There's a lot of replicated code here for efficiency. ;;; For example, the char/char-set/pred discrimination has ;;; been lifted above the inner loop of each proc. (define (string-index str criterion . maybe-start+end) (let-string-start+end (start end) string-index str maybe-start+end (cond ((char? criterion) (let lp ((i start)) (and (< i end) (if (char=? criterion (string-ref str i)) i (lp (+ i 1)))))) ((char-set? criterion) (let lp ((i start)) (and (< i end) (if (char-set-contains? criterion (string-ref str i)) i (lp (+ i 1)))))) ((procedure? criterion) (let lp ((i start)) (and (< i end) (if (criterion (string-ref str i)) i (lp (+ i 1)))))) (else (error "Second param is neither char-set, char, or predicate procedure." string-index criterion))))) (define (string-index-right str criterion . maybe-start+end) (let-string-start+end (start end) string-index-right str maybe-start+end (cond ((char? criterion) (let lp ((i (- end 1))) (and (>= i start) (if (char=? criterion (string-ref str i)) i (lp (- i 1)))))) ((char-set? criterion) (let lp ((i (- end 1))) (and (>= i start) (if (char-set-contains? criterion (string-ref str i)) i (lp (- i 1)))))) ((procedure? criterion) (let lp ((i (- end 1))) (and (>= i start) (if (criterion (string-ref str i)) i (lp (- i 1)))))) (else (error "Second param is neither char-set, char, or predicate procedure." string-index-right criterion))))) (define (string-skip str criterion . maybe-start+end) (let-string-start+end (start end) string-skip str maybe-start+end (cond ((char? criterion) (let lp ((i start)) (and (< i end) (if (char=? criterion (string-ref str i)) (lp (+ i 1)) i)))) ((char-set? criterion) (let lp ((i start)) (and (< i end) (if (char-set-contains? criterion (string-ref str i)) (lp (+ i 1)) i)))) ((procedure? criterion) (let lp ((i start)) (and (< i end) (if (criterion (string-ref str i)) (lp (+ i 1)) i)))) (else (error "Second param is neither char-set, char, or predicate procedure." string-skip criterion))))) (define (string-skip-right str criterion . maybe-start+end) (let-string-start+end (start end) string-skip-right str maybe-start+end (cond ((char? criterion) (let lp ((i (- end 1))) (and (>= i start) (if (char=? criterion (string-ref str i)) (lp (- i 1)) i)))) ((char-set? criterion) (let lp ((i (- end 1))) (and (>= i start) (if (char-set-contains? criterion (string-ref str i)) (lp (- i 1)) i)))) ((procedure? criterion) (let lp ((i (- end 1))) (and (>= i start) (if (criterion (string-ref str i)) (lp (- i 1)) i)))) (else (error "CRITERION param is neither char-set or char." string-skip-right criterion))))) (define (string-count s criterion . maybe-start+end) (let-string-start+end (start end) string-count s maybe-start+end (cond ((char? criterion) (do ((i start (+ i 1)) (count 0 (if (char=? criterion (string-ref s i)) (+ count 1) count))) ((>= i end) count))) ((char-set? criterion) (do ((i start (+ i 1)) (count 0 (if (char-set-contains? criterion (string-ref s i)) (+ count 1) count))) ((>= i end) count))) ((procedure? criterion) (do ((i start (+ i 1)) (count 0 (if (criterion (string-ref s i)) (+ count 1) count))) ((>= i end) count))) (else (error "CRITERION param is neither char-set or char." string-count criterion))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; string-fill! string char [start end] ;;; ;;; string-copy! to tstart from [fstart fend] ;;; Guaranteed to work, even if s1 eq s2. (define (string-fill! s char . maybe-start+end) (check-arg char? char string-fill!) (let-string-start+end (start end) string-fill! s maybe-start+end (do ((i (- end 1) (- i 1))) ((< i start)) (string-set! s i char)))) (define (string-copy! to tstart from . maybe-fstart+fend) (let-string-start+end (fstart fend) string-copy! from maybe-fstart+fend (check-arg integer? tstart string-copy!) (check-substring-spec string-copy! to tstart (+ tstart (- fend fstart))) (%string-copy! to tstart from fstart fend))) ;;; Library-internal routine (define (%string-copy! to tstart from fstart fend) (if (> fstart tstart) (do ((i fstart (+ i 1)) (j tstart (+ j 1))) ((>= i fend)) (string-set! to j (string-ref from i))) (do ((i (- fend 1) (- i 1)) (j (+ -1 tstart (- fend fstart)) (- j 1))) ((< i fstart)) (string-set! to j (string-ref from i))))) ;;; Returns starting-position in STRING or #f if not true. ;;; This implementation is slow & simple. It is useful as a "spec" or for ;;; comparison testing with fancier implementations. ;;; See below for fast KMP version. ;(define (string-contains string substring . maybe-starts+ends) ; (let-string-start+end2 (start1 end1 start2 end2) ; string-contains string substring maybe-starts+ends ; (let* ((len (- end2 start2)) ; (i-bound (- end1 len))) ; (let lp ((i start1)) ; (and (< i i-bound) ; (if (string= string substring i (+ i len) start2 end2) ; i ; (lp (+ i 1)))))))) ;;; Searching for an occurrence of a substring ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (string-contains text pattern . maybe-starts+ends) (let-string-start+end2 (t-start t-end p-start p-end) string-contains text pattern maybe-starts+ends (%kmp-search pattern text char=? p-start p-end t-start t-end))) (define (string-contains-ci text pattern . maybe-starts+ends) (let-string-start+end2 (t-start t-end p-start p-end) string-contains-ci text pattern maybe-starts+ends (%kmp-search pattern text char-ci=? p-start p-end t-start t-end))) ;;; Knuth-Morris-Pratt string searching ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; See ;;; "Fast pattern matching in strings" ;;; SIAM J. Computing 6(2):323-350 1977 ;;; D. E. Knuth, J. H. Morris and V. R. Pratt ;;; also described in ;;; "Pattern matching in strings" ;;; Alfred V. Aho ;;; Formal Language Theory - Perspectives and Open Problems ;;; Ronald V. Brook (editor) ;;; This algorithm is O(m + n) where m and n are the ;;; lengths of the pattern and string respectively ;;; KMP search source[start,end) for PATTERN. Return starting index of ;;; leftmost match or #f. (define (%kmp-search pattern text c= p-start p-end t-start t-end) (let ((plen (- p-end p-start)) (rv (make-kmp-restart-vector pattern c= p-start p-end))) ;; The search loop. TJ & PJ are redundant state. (let lp ((ti t-start) (pi 0) (tj (- t-end t-start)) ; (- tlen ti) -- how many chars left. (pj plen)) ; (- plen pi) -- how many chars left. (if (= pi plen) (- ti plen) ; Win. (and (<= pj tj) ; Lose. (if (c= (string-ref text ti) ; Search. (string-ref pattern (+ p-start pi))) (lp (+ 1 ti) (+ 1 pi) (- tj 1) (- pj 1)) ; Advance. (let ((pi (vector-ref rv pi))) ; Retreat. (if (= pi -1) (lp (+ ti 1) 0 (- tj 1) plen) ; Punt. (lp ti pi tj (- plen pi)))))))))) ;;; (make-kmp-restart-vector pattern [c= start end]) -> integer-vector ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compute the KMP restart vector RV for string PATTERN. If ;;; we have matched chars 0..i-1 of PATTERN against a search string S, and ;;; PATTERN[i] doesn't match S[k], then reset i := RV[i], and try again to ;;; match S[k]. If RV[i] = -1, then punt S[k] completely, and move on to ;;; S[k+1] and PATTERN[0] -- no possible match of PAT[0..i] contains S[k]. ;;; ;;; In other words, if you have matched the first i chars of PATTERN, but ;;; the i+1'th char doesn't match, RV[i] tells you what the next-longest ;;; prefix of PATTERN is that you have matched. ;;; ;;; - C= (default CHAR=?) is used to compare characters for equality. ;;; Pass in CHAR-CI=? for case-folded string search. ;;; ;;; - START & END restrict the pattern to the indicated substring; the ;;; returned vector will be of length END - START. The numbers stored ;;; in the vector will be values in the range [0,END-START) -- that is, ;;; they are valid indices into the restart vector; you have to add START ;;; to them to use them as indices into PATTERN. ;;; ;;; I've split this out as a separate function in case other constant-string ;;; searchers might want to use it. ;;; ;;; E.g.: ;;; a b d a b x ;;; #(-1 0 0 -1 1 2) (define (make-kmp-restart-vector pattern . maybe-c=+start+end) (let-optionals* maybe-c=+start+end ((c= char=? (procedure? c=)) ((start end) (lambda (args) (string-parse-start+end make-kmp-restart-vector pattern args)))) (let* ((rvlen (- end start)) (rv (make-vector rvlen -1))) (if (> rvlen 0) (let ((rvlen-1 (- rvlen 1)) (c0 (string-ref pattern start))) ;; Here's the main loop. We have set rv[0] ... rv[i]. ;; K = I + START -- it is the corresponding index into PATTERN. (let lp1 ((i 0) (j -1) (k start)) (if (< i rvlen-1) ;; lp2 invariant: ;; pat[(k-j) .. k-1] matches pat[start .. start+j-1] ;; or j = -1. (let lp2 ((j j)) (cond ((= j -1) (let ((i1 (+ 1 i))) (if (not (c= (string-ref pattern (+ k 1)) c0)) (vector-set! rv i1 0)) (lp1 i1 0 (+ k 1)))) ;; pat[(k-j) .. k] matches pat[start..start+j]. ((c= (string-ref pattern k) (string-ref pattern (+ j start))) (let* ((i1 (+ 1 i)) (j1 (+ 1 j))) (vector-set! rv i1 j1) (lp1 i1 j1 (+ k 1)))) (else (lp2 (vector-ref rv j))))))))) rv))) ;;; We've matched I chars from PAT. C is the next char from the search string. ;;; Return the new I after handling C. ;;; ;;; The pattern is (VECTOR-LENGTH RV) chars long, beginning at index PAT-START ;;; in PAT (PAT-START is usually 0). The I chars of the pattern we've matched ;;; are ;;; PAT[PAT-START .. PAT-START + I]. ;;; ;;; It's *not* an oversight that there is no friendly error checking or ;;; defaulting of arguments. This is a low-level, inner-loop procedure ;;; that we want integrated/inlined into the point of call. (define (kmp-step pat rv c i c= p-start) (let lp ((i i)) (if (c= c (string-ref pat (+ i p-start))) ; Match => (+ i 1) ; Done. (let ((i (vector-ref rv i))) ; Back up in PAT. (if (= i -1) 0 ; Can't back up further. (lp i)))))) ; Keep trying for match. ;;; Zip through S[start,end), looking for a match of PAT. Assume we've ;;; already matched the first I chars of PAT when we commence at S[start]. ;;; - <0: If we find a match *ending* at index J, return -J. ;;; - >=0: If we get to the end of the S[start,end) span without finding ;;; a complete match, return the number of chars from PAT we'd matched ;;; when we ran off the end. ;;; ;;; This is useful for searching *across* buffers -- that is, when your ;;; input comes in chunks of text. We hand-integrate the KMP-STEP loop ;;; for speed. (define (string-kmp-partial-search pat rv s i . c=+p-start+s-start+s-end) (check-arg vector? rv string-kmp-partial-search) (let-optionals* c=+p-start+s-start+s-end ((c= char=? (procedure? c=)) (p-start 0 (and (integer? p-start) (exact? p-start) (<= 0 p-start))) ((s-start s-end) (lambda (args) (string-parse-start+end string-kmp-partial-search s args)))) (let ((patlen (vector-length rv))) (check-arg (lambda (i) (and (integer? i) (exact? i) (<= 0 i) (< i patlen))) i string-kmp-partial-search) ;; Enough prelude. Here's the actual code. (let lp ((si s-start) ; An index into S. (vi i)) ; An index into RV. (cond ((= vi patlen) (- si)) ; Win. ((= si s-end) vi) ; Ran off the end. (else ; Match s[si] & loop. (let ((c (string-ref s si))) (lp (+ si 1) (let lp2 ((vi vi)) ; This is just KMP-STEP. (if (c= c (string-ref pat (+ vi p-start))) (+ vi 1) (let ((vi (vector-ref rv vi))) (if (= vi -1) 0 (lp2 vi))))))))))))) ;;; Misc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (string-null? s) ;;; (string-reverse s [start end]) ;;; (string-reverse! s [start end]) ;;; (reverse-list->string clist) ;;; (string->list s [start end]) (define (string-null? s) (zero? (string-length s))) (define (string-reverse s . maybe-start+end) (let-string-start+end (start end) string-reverse s maybe-start+end (let* ((len (- end start)) (ans (make-string len))) (do ((i start (+ i 1)) (j (- len 1) (- j 1))) ((< j 0)) (string-set! ans j (string-ref s i))) ans))) (define (string-reverse! s . maybe-start+end) (let-string-start+end (start end) string-reverse! s maybe-start+end (do ((i (- end 1) (- i 1)) (j start (+ j 1))) ((<= i j)) (let ((ci (string-ref s i))) (string-set! s i (string-ref s j)) (string-set! s j ci))))) (define (reverse-list->string clist) (let* ((len (length clist)) (s (make-string len))) (do ((i (- len 1) (- i 1)) (clist clist (cdr clist))) ((not (pair? clist))) (string-set! s i (car clist))) s)) ;(define (string->list s . maybe-start+end) ; (apply string-fold-right cons '() s maybe-start+end)) (define (string->list s . maybe-start+end) (let-string-start+end (start end) string->list s maybe-start+end (do ((i (- end 1) (- i 1)) (ans '() (cons (string-ref s i) ans))) ((< i start) ans)))) ;;; Defined by R5RS, so commented out here. ;(define (list->string lis) (string-unfold null? car cdr lis)) ;;; string-concatenate string-list -> string ;;; string-concatenate/shared string-list -> string ;;; string-append/shared s ... -> string ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; STRING-APPEND/SHARED has license to return a string that shares storage ;;; with any of its arguments. In particular, if there is only one non-empty ;;; string amongst its parameters, it is permitted to return that string as ;;; its result. STRING-APPEND, by contrast, always allocates new storage. ;;; ;;; STRING-CONCATENATE & STRING-CONCATENATE/SHARED are passed a list of ;;; strings, which they concatenate into a result string. STRING-CONCATENATE ;;; always allocates a fresh string; STRING-CONCATENATE/SHARED may (or may ;;; not) return a result that shares storage with any of its arguments. In ;;; particular, if it is applied to a singleton list, it is permitted to ;;; return the car of that list as its value. (define (string-append/shared . strings) (string-concatenate/shared strings)) (define (string-concatenate/shared strings) (let lp ((strings strings) (nchars 0) (first #f)) (cond ((pair? strings) ; Scan the args, add up total (let* ((string (car strings)) ; length, remember 1st (tail (cdr strings)) ; non-empty string. (slen (string-length string))) (if (zero? slen) (lp tail nchars first) (lp tail (+ nchars slen) (or first strings))))) ((zero? nchars) "") ;; Just one non-empty string! Return it. ((= nchars (string-length (car first))) (car first)) (else (let ((ans (make-string nchars))) (let lp ((strings first) (i 0)) (if (pair? strings) (let* ((s (car strings)) (slen (string-length s))) (%string-copy! ans i s 0 slen) (lp (cdr strings) (+ i slen))))) ans))))) ; Alas, Scheme 48's APPLY blows up if you have many, many arguments. ;(define (string-concatenate strings) (apply string-append strings)) ;;; Here it is written out. I avoid using REDUCE to add up string lengths ;;; to avoid non-R5RS dependencies. (define (string-concatenate strings) (let* ((total (do ((strings strings (cdr strings)) (i 0 (+ i (string-length (car strings))))) ((not (pair? strings)) i))) (ans (make-string total))) (let lp ((i 0) (strings strings)) (if (pair? strings) (let* ((s (car strings)) (slen (string-length s))) (%string-copy! ans i s 0 slen) (lp (+ i slen) (cdr strings))))) ans)) ;;; Defined by R5RS, so commented out here. ;(define (string-append . strings) (string-concatenate strings)) ;;; string-concatenate-reverse string-list [final-string end] -> string ;;; string-concatenate-reverse/shared string-list [final-string end] -> string ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Return ;;; (string-concatenate ;;; (reverse ;;; (cons (substring final-string 0 end) string-list))) (define (string-concatenate-reverse string-list . maybe-final+end) (let-optionals* maybe-final+end ((final "" (string? final)) (end (string-length final) (and (integer? end) (exact? end) (<= 0 end (string-length final))))) (let ((len (let lp ((sum 0) (lis string-list)) (if (pair? lis) (lp (+ sum (string-length (car lis))) (cdr lis)) sum)))) (%finish-string-concatenate-reverse len string-list final end)))) (define (string-concatenate-reverse/shared string-list . maybe-final+end) (let-optionals* maybe-final+end ((final "" (string? final)) (end (string-length final) (and (integer? end) (exact? end) (<= 0 end (string-length final))))) ;; Add up the lengths of all the strings in STRING-LIST; also get a ;; pointer NZLIST into STRING-LIST showing where the first non-zero-length ;; string starts. (let lp ((len 0) (nzlist #f) (lis string-list)) (if (pair? lis) (let ((slen (string-length (car lis)))) (lp (+ len slen) (if (or nzlist (zero? slen)) nzlist lis) (cdr lis))) (cond ((zero? len) (substring/shared final 0 end)) ;; LEN > 0, so NZLIST is non-empty. ((and (zero? end) (= len (string-length (car nzlist)))) (car nzlist)) (else (%finish-string-concatenate-reverse len nzlist final end))))))) (define (%finish-string-concatenate-reverse len string-list final end) (let ((ans (make-string (+ end len)))) (%string-copy! ans len final 0 end) (let lp ((i len) (lis string-list)) (if (pair? lis) (let* ((s (car lis)) (lis (cdr lis)) (slen (string-length s)) (i (- i slen))) (%string-copy! ans i s 0 slen) (lp i lis)))) ans)) ;;; string-replace s1 s2 start1 end1 [start2 end2] -> string ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Replace S1[START1,END1) with S2[START2,END2). (define (string-replace s1 s2 start1 end1 . maybe-start+end) (check-substring-spec string-replace s1 start1 end1) (let-string-start+end (start2 end2) string-replace s2 maybe-start+end (let* ((slen1 (string-length s1)) (sublen2 (- end2 start2)) (alen (+ (- slen1 (- end1 start1)) sublen2)) (ans (make-string alen))) (%string-copy! ans 0 s1 0 start1) (%string-copy! ans start1 s2 start2 end2) (%string-copy! ans (+ start1 sublen2) s1 end1 slen1) ans))) ;;; string-tokenize s [token-set start end] -> list ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Break S up into a list of token strings, where a token is a maximal ;;; non-empty contiguous sequence of chars belonging to TOKEN-SET. ;;; (string-tokenize "hello, world") => ("hello," "world") (define (string-tokenize s . token-chars+start+end) (let-optionals* token-chars+start+end ((token-chars char-set:graphic (char-set? token-chars)) rest) (let-string-start+end (start end) string-tokenize s rest (let lp ((i end) (ans '())) (cond ((and (< start i) (string-index-right s token-chars start i)) => (lambda (tend-1) (let ((tend (+ 1 tend-1))) (cond ((string-skip-right s token-chars start tend-1) => (lambda (tstart-1) (lp tstart-1 (cons (substring s (+ 1 tstart-1) tend) ans)))) (else (cons (substring s start tend) ans)))))) (else ans)))))) ;;; xsubstring s from [to start end] -> string ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; S is a string; START and END are optional arguments that demarcate ;;; a substring of S, defaulting to 0 and the length of S (e.g., the whole ;;; string). Replicate this substring up and down index space, in both the ;; positive and negative directions. For example, if S = "abcdefg", START=3, ;;; and END=6, then we have the conceptual bidirectionally-infinite string ;;; ... d e f d e f d e f d e f d e f d e f d e f ... ;;; ... -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8 9 ... ;;; XSUBSTRING returns the substring of this string beginning at index FROM, ;;; and ending at TO (which defaults to FROM+(END-START)). ;;; ;;; You can use XSUBSTRING in many ways: ;;; - To rotate a string left: (xsubstring "abcdef" 2) => "cdefab" ;;; - To rotate a string right: (xsubstring "abcdef" -2) => "efabcd" ;;; - To replicate a string: (xsubstring "abc" 0 7) => "abcabca" ;;; ;;; Note that ;;; - The FROM/TO indices give a half-open range -- the characters from ;;; index FROM up to, but not including index TO. ;;; - The FROM/TO indices are not in terms of the index space for string S. ;;; They are in terms of the replicated index space of the substring ;;; defined by S, START, and END. ;;; ;;; It is an error if START=END -- although this is allowed by special ;;; dispensation when FROM=TO. (define (xsubstring s from . maybe-to+start+end) (check-arg (lambda (val) (and (integer? val) (exact? val))) from xsubstring) (receive (to start end) (if (pair? maybe-to+start+end) (let-string-start+end (start end) xsubstring s (cdr maybe-to+start+end) (let ((to (car maybe-to+start+end))) (check-arg (lambda (val) (and (integer? val) (exact? val) (<= from val))) to xsubstring) (values to start end))) (let ((slen (string-length (check-arg string? s xsubstring)))) (values (+ from slen) 0 slen))) (let ((slen (- end start)) (anslen (- to from))) (cond ((zero? anslen) "") ((zero? slen) (error "Cannot replicate empty (sub)string" xsubstring s from to start end)) ((= 1 slen) ; Fast path for 1-char replication. (make-string anslen (string-ref s start))) ;; Selected text falls entirely within one span. ((= (floor (/ from slen)) (floor (/ to slen))) (substring s (+ start (modulo from slen)) (+ start (modulo to slen)))) ;; Selected text requires multiple spans. (else (let ((ans (make-string anslen))) (%multispan-repcopy! ans 0 s from to start end) ans)))))) ;;; string-xcopy! target tstart s sfrom [sto start end] -> unspecific ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Exactly the same as xsubstring, but the extracted text is written ;;; into the string TARGET starting at index TSTART. ;;; This operation is not defined if (EQ? TARGET S) -- you cannot copy ;;; a string on top of itself. (define (string-xcopy! target tstart s sfrom . maybe-sto+start+end) (check-arg (lambda (val) (and (integer? val) (exact? val))) sfrom string-xcopy!) (receive (sto start end) (if (pair? maybe-sto+start+end) (let-string-start+end (start end) string-xcopy! s (cdr maybe-sto+start+end) (let ((sto (car maybe-sto+start+end))) (check-arg (lambda (val) (and (integer? val) (exact? val))) sto string-xcopy!) (values sto start end))) (let ((slen (string-length s))) (values (+ sfrom slen) 0 slen))) (let* ((tocopy (- sto sfrom)) (tend (+ tstart tocopy)) (slen (- end start))) (check-substring-spec string-xcopy! target tstart tend) (cond ((zero? tocopy)) ((zero? slen) (error "Cannot replicate empty (sub)string" string-xcopy! target tstart s sfrom sto start end)) ((= 1 slen) ; Fast path for 1-char replication. (string-fill! target (string-ref s start) tstart tend)) ;; Selected text falls entirely within one span. ((= (floor (/ sfrom slen)) (floor (/ sto slen))) (%string-copy! target tstart s (+ start (modulo sfrom slen)) (+ start (modulo sto slen)))) ;; Multi-span copy. (else (%multispan-repcopy! target tstart s sfrom sto start end)))))) ;;; This is the core copying loop for XSUBSTRING and STRING-XCOPY! ;;; Internal -- not exported, no careful arg checking. (define (%multispan-repcopy! target tstart s sfrom sto start end) (let* ((slen (- end start)) (i0 (+ start (modulo sfrom slen))) (total-chars (- sto sfrom))) ;; Copy the partial span @ the beginning (%string-copy! target tstart s i0 end) (let* ((ncopied (- end i0)) ; We've copied this many. (nleft (- total-chars ncopied)) ; # chars left to copy. (nspans (quotient nleft slen))) ; # whole spans to copy ;; Copy the whole spans in the middle. (do ((i (+ tstart ncopied) (+ i slen)) ; Current target index. (nspans nspans (- nspans 1))) ; # spans to copy ((zero? nspans) ;; Copy the partial-span @ the end & we're done. (%string-copy! target i s start (+ start (- total-chars (- i tstart))))) (%string-copy! target i s start end))))); Copy a whole span. ;;; (string-join string-list [delimiter grammar]) => string ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Paste strings together using the delimiter string. ;;; ;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz" ;;; ;;; DELIMITER defaults to a single space " " ;;; GRAMMAR is one of the symbols {prefix, infix, strict-infix, suffix} ;;; and defaults to 'infix. ;;; ;;; I could rewrite this more efficiently -- precompute the length of the ;;; answer string, then allocate & fill it in iteratively. Using ;;; STRING-CONCATENATE is less efficient. (define (string-join strings . delim+grammar) (let-optionals* delim+grammar ((delim " " (string? delim)) (grammar 'infix)) (let ((buildit (lambda (lis final) (let recur ((lis lis)) (if (pair? lis) (cons delim (cons (car lis) (recur (cdr lis)))) final))))) (cond ((pair? strings) (string-concatenate (case grammar ((infix strict-infix) (cons (car strings) (buildit (cdr strings) '()))) ((prefix) (buildit strings '())) ((suffix) (cons (car strings) (buildit (cdr strings) (list delim)))) (else (error "Illegal join grammar" grammar string-join))))) ((not (null? strings)) (error "STRINGS parameter not list." strings string-join)) ;; STRINGS is () ((eq? grammar 'strict-infix) (error "Empty list cannot be joined with STRICT-INFIX grammar." string-join)) (else ""))))) ; Special-cased for infix grammar. ;;; Porting & performance-tuning notes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; See the section at the beginning of this file on external dependencies. ;;; ;;; The biggest issue with respect to porting is the LET-OPTIONALS* macro. ;;; There are many, many optional arguments in this library; the complexity ;;; of parsing, defaulting & type-testing these parameters is handled with the ;;; aid of this macro. There are about 15 uses of LET-OPTIONALS*. You can ;;; rewrite the uses, port the hairy macro definition (which is implemented ;;; using a Clinger-Rees low-level explicit-renaming macro system), or port ;;; the simple, high-level definition, which is less efficient. ;;; ;;; There is a fair amount of argument checking. This is, strictly speaking, ;;; unnecessary -- the actual body of the procedures will blow up if, say, a ;;; START/END index is improper. However, the error message will not be as ;;; good as if the error were caught at the "higher level." Also, a very, very ;;; smart Scheme compiler may be able to exploit having the type checks done ;;; early, so that the actual body of the procedures can assume proper values. ;;; This isn't likely; this kind of compiler technology isn't common any ;;; longer. ;;; ;;; The overhead of optional-argument parsing is irritating. The optional ;;; arguments must be consed into a rest list on entry, and then parsed out. ;;; Function call should be a matter of a few register moves and a jump; it ;;; should not involve heap allocation! Your Scheme system may have a superior ;;; non-R5RS optional-argument system that can eliminate this overhead. If so, ;;; then this is a prime candidate for optimising these procedures, ;;; *especially* the many optional START/END index parameters. ;;; ;;; Note that optional arguments are also a barrier to procedure integration. ;;; If your Scheme system permits you to specify alternate entry points ;;; for a call when the number of optional arguments is known in a manner ;;; that enables inlining/integration, this can provide performance ;;; improvements. ;;; ;;; There is enough *explicit* error checking that *all* string-index ;;; operations should *never* produce a bounds error. Period. Feel like ;;; living dangerously? *Big* performance win to be had by replacing ;;; STRING-REF's and STRING-SET!'s with unsafe equivalents in the loops. ;;; Similarly, fixnum-specific operators can speed up the arithmetic done on ;;; the index values in the inner loops. The only arguments that are not ;;; completely error checked are ;;; - string lists (complete checking requires time proportional to the ;;; length of the list) ;;; - procedure arguments, such as char->char maps & predicates. ;;; There is no way to check the range & domain of procedures in Scheme. ;;; Procedures that take these parameters cannot fully check their ;;; arguments. But all other types to all other procedures are fully ;;; checked. ;;; ;;; This does open up the alternate possibility of simply *removing* these ;;; checks, and letting the safe primitives raise the errors. On a dumb ;;; Scheme system, this would provide speed (by eliminating the redundant ;;; error checks) at the cost of error-message clarity. ;;; ;;; See the comments preceding the hash function code for notes on tuning ;;; the default bound so that the code never overflows your implementation's ;;; fixnum size into bignum calculation. ;;; ;;; In an interpreted Scheme, some of these procedures, or the internal ;;; routines with % prefixes, are excellent candidates for being rewritten ;;; in C. Consider STRING-HASH, %STRING-COMPARE, the ;;; %STRING-{SUF,PRE}FIX-LENGTH routines, STRING-COPY!, STRING-INDEX & ;;; STRING-SKIP (char-set & char cases), SUBSTRING and SUBSTRING/SHARED, ;;; %KMP-SEARCH, and %MULTISPAN-REPCOPY!. ;;; ;;; It would also be nice to have the ability to mark some of these ;;; routines as candidates for inlining/integration. ;;; ;;; All the %-prefixed routines in this source code are written ;;; to be called internally to this library. They do *not* perform ;;; friendly error checks on the inputs; they assume everything is ;;; proper. They also do not take optional arguments. These two properties ;;; save calling overhead and enable procedure integration -- but they ;;; are not appropriate for exported routines. ;;; Copyright details ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The prefix/suffix and comparison routines in this code had (extremely ;;; distant) origins in MIT Scheme's string lib, and was substantially ;;; reworked by Olin Shivers (shivers@ai.mit.edu) 9/98. As such, it is ;;; covered by MIT Scheme's open source copyright. See below for details. ;;; ;;; The KMP string-search code was influenced by implementations written ;;; by Stephen Bevan, Brian Dehneyer and Will Fitzgerald. However, this ;;; version was written from scratch by myself. ;;; ;;; The remainder of this code was written from scratch by myself for scsh. ;;; The scsh copyright is a BSD-style open source copyright. See below for ;;; details. ;;; -Olin Shivers ;;; MIT Scheme copyright terms ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This material was developed by the Scheme project at the Massachusetts ;;; Institute of Technology, Department of Electrical Engineering and ;;; Computer Science. Permission to copy and modify this software, to ;;; redistribute either the original software or a modified version, and ;;; to use this software for any purpose is granted, subject to the ;;; following restrictions and understandings. ;;; ;;; 1. Any copy made of this software must include this copyright notice ;;; in full. ;;; ;;; 2. Users of this software agree to make their best efforts (a) to ;;; return to the MIT Scheme project any improvements or extensions that ;;; they make, so that these may be included in future releases; and (b) ;;; to inform MIT of noteworthy uses of this software. ;;; ;;; 3. All materials developed as a consequence of the use of this ;;; software shall duly acknowledge such use, in accordance with the usual ;;; standards of acknowledging credit in academic research. ;;; ;;; 4. MIT has made no warrantee or representation that the operation of ;;; this software will be error-free, and MIT is under no obligation to ;;; provide any services, by way of maintenance, update, or otherwise. ;;; ;;; 5. In conjunction with products arising from the use of this material, ;;; there shall be no use of the name of the Massachusetts Institute of ;;; Technology nor of any adaptation thereof in any advertising, ;;; promotional, or sales literature without prior written consent from ;;; MIT in each case. ;;; Scsh copyright terms ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; 1. Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; 2. Redistributions in binary form must reproduce the above copyright ;;; notice, this list of conditions and the following disclaimer in the ;;; documentation and/or other materials provided with the distribution. ;;; 3. The name of the authors may not be used to endorse or promote products ;;; derived from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR ;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES ;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. ;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, ;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT ;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a13/strings.sls000066400000000000000000000046641375154206600216640ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :13 strings) (export string-map string-map! string-fold string-unfold string-fold-right string-unfold-right string-tabulate string-for-each string-for-each-index string-every string-any string-hash string-hash-ci string-compare string-compare-ci string= string< string> string<= string>= string<> string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<> string-downcase string-upcase string-titlecase string-downcase! string-upcase! string-titlecase! string-take string-take-right string-drop string-drop-right string-pad string-pad-right string-trim string-trim-right string-trim-both string-filter string-delete string-index string-index-right string-skip string-skip-right string-count string-prefix-length string-prefix-length-ci string-suffix-length string-suffix-length-ci string-prefix? string-prefix-ci? string-suffix? string-suffix-ci? string-contains string-contains-ci string-copy! substring/shared string-reverse string-reverse! reverse-list->string string-concatenate string-concatenate/shared string-concatenate-reverse string-concatenate-reverse/shared string-append/shared xsubstring string-xcopy! string-null? string-join string-tokenize string-replace ; R5RS extended: string->list string-copy string-fill! ; R5RS re-exports: string? make-string string-length string-ref string-set! string string-append list->string ; Low-level routines: #;(make-kmp-restart-vector string-kmp-partial-search kmp-step string-parse-start+end string-parse-final-start+end let-string-start+end check-substring-spec substring-spec-ok?) ) (import (except (rnrs) string-copy string-for-each string->list string-upcase string-downcase string-titlecase string-hash) (except (rnrs mutable-strings) string-fill!) (rnrs r5rs) (srfi :23 error tricks) (srfi :8 receive) (srfi :14 char-sets) (srfi private check-arg) (srfi private let-opt) (srfi private include)) (define (char-cased? c) (char-upper-case? (char-upcase c))) (SRFI-23-error->R6RS "(library (srfi :13 strings))" (include/resolve ("srfi" "%3a13") "srfi-13.scm")) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a130.sls000066400000000000000000000021761375154206600202470ustar00rootroot00000000000000(library (srfi :130) (export string-cursor? string-cursor-start string-cursor-end string-cursor-next string-cursor-prev string-cursor-forward string-cursor-back string-cursor=? string-cursor? string-cursor<=? string-cursor>=? string-cursor-diff string-cursor->index string-index->cursor string-null? string-every string-any string-tabulate string-unfold string-unfold-right string->list/cursors string->vector/cursors reverse-list->string string-join string-ref/cursor substring/cursors string-copy/cursors string-take string-take-right string-drop string-drop-right string-pad string-pad-right string-trim string-trim-right string-trim-both string-prefix-length string-suffix-length string-prefix? string-suffix? string-index string-index-right string-skip string-skip-right string-contains string-contains-right string-reverse string-concatenate string-concatenate-reverse string-fold string-fold-right string-for-each-cursor string-replicate string-count string-replace string-split string-filter string-remove) (import (srfi :130 string-cursors))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a130/000077500000000000000000000000001375154206600175165ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a130/130.body.scm000066400000000000000000000176371375154206600214770ustar00rootroot00000000000000;;; Copyright (C) William D Clinger (2016). ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without ;;; restriction, including without limitation the rights to use, ;;; copy, modify, merge, publish, distribute, sublicense, and/or ;;; sell copies of the Software, and to permit persons to whom the ;;; Software is furnished to do so, subject to the following ;;; conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES ;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR ;;; OTHER DEALINGS IN THE SOFTWARE. ;;; For convenient interoperation with SRFI 13, ;;; cursors ought to be the same as indexes. ;;; Some of the FIXME comments mark procedures that really ought ;;; to do more checking for "is an error" situations. ;; added for chez scheme support (define string->vector (lambda (str) (let ([len (string-length str)]) (let ([v (make-vector len)]) (do ([i (fx- len 1) (fx- i 1)]) ((fx=? i -1)) (vector-set! v i (string-ref str i))) v)))) (define (string-cursor? x) (and (and (integer? x) (exact? x)) (>= x 0))) (define (string-cursor-start s) 0) (define (string-cursor-end s) (string-length s)) (define (string-cursor-next s curs) (+ curs 1)) ; FIXME (define (string-cursor-prev s curs) (- curs 1)) ; FIXME (define (string-cursor-forward s curs n) (+ curs n)) ; FIXME (define (string-cursor-back s curs n) (- curs n)) ; FIXME (define (string-cursor=? curs1 curs2) (= curs1 curs2)) (define (string-cursor? curs1 curs2) (> curs1 curs2)) (define (string-cursor<=? curs1 curs2) (<= curs1 curs2)) (define (string-cursor>=? curs1 curs2) (>= curs1 curs2)) (define (string-cursor-diff s start end) (- end start)) ; FIXME (define (string-cursor->index s curs) curs) (define (string-index->cursor s idx) idx) (define string->list/cursors string->list) (define string->vector/cursors string->vector) (define string-ref/cursor string-ref) (define substring/cursors substring) (define string-copy/cursors string-copy) ;;; The SRFI 13 procedures return #f sometimes, so they can't be the same ;;; even if cursors are the same as indexes. ;;; Furthermore string-index-right and string-skip-right return the ;;; successor of the cursor for the character found. (define string-index (case-lambda ((s pred) (string-index s pred 0 (string-length s))) ((s pred start) (string-index s pred start (string-length s))) ((s pred start end) (or (srfi-13:string-index s pred start end) end)))) (define string-index-right (case-lambda ((s pred) (string-index-right s pred 0 (string-length s))) ((s pred start) (string-index-right s pred start (string-length s))) ((s pred start end) (let ((i (srfi-13:string-index-right s pred start end))) (if i (+ i 1) start))))) (define (string-skip s pred . rest) (apply string-index s (lambda (x) (not (pred x))) rest)) (define (string-skip-right s pred . rest) (apply string-index-right s (lambda (x) (not (pred x))) rest)) ;;; FIXME: inefficient (define string-contains-right (case-lambda ((s1 s2) (string-contains-right s1 s2 0 (string-length s1) 0 (string-length s2))) ((s1 s2 start1) (string-contains-right s1 s2 start1 (string-length s1) 0 (string-length s2))) ((s1 s2 start1 end1) (string-contains-right s1 s2 start1 end1 0 (string-length s2))) ((s1 s2 start1 end1 start2) (string-contains-right s1 s2 start1 end1 start2 (string-length s2))) ((s1 s2 start1 end1 start2 end2) (if (= start2 end2) end1 (let loop ((i #f) (j (string-contains s1 s2 start1 end1 start2 end2))) (if (and j (< j end1)) (loop j (string-contains s1 s2 (+ j 1) end1 start2 end2)) i)))))) (define string-for-each-cursor (case-lambda ((proc s) (string-for-each-cursor proc s 0 (string-length s))) ((proc s start) (string-for-each-cursor proc s start (string-length s))) ((proc s start end) (do ((i start (+ i 1))) ((>= i end)) (proc i))))) (define string-replicate (case-lambda ((s from to start end) (string-replicate (substring s start end) from to)) ((s from to start) (string-replicate (substring s start (string-length s)) from to)) ((s from to) (let* ((n (- to from)) (len (string-length s))) (cond ((= n 0) "") ((or (< n 0) (= len 0)) (assertion-violation 'string-replicate "unexpected arguments" s from to)) (else (let* ((from (mod from len)) ; make from non-negative (to (+ from n))) (do ((replicates '() (cons s replicates)) (replicates-length 0 (+ replicates-length len))) ((>= replicates-length to) (substring (apply string-append replicates) from to)))))))))) (define string-split (case-lambda ((s delimiter grammar limit start end) (string-split (substring s start end) delimiter grammar limit)) ((s delimiter grammar limit start) (string-split (substring s start (string-length s)) delimiter grammar limit)) ((s delimiter) (string-split s delimiter 'infix #f)) ((s delimiter grammar) (string-split s delimiter grammar #f)) ((s delimiter grammar limit) (define (complain) (assertion-violation 'string-split "unexpected arguments" s delimiter grammar limit)) (let* ((limit (or limit (string-length s))) (splits (cond ((= 0 (string-length delimiter)) (string-split-into-characters s limit)) (else (string-split-using-word s delimiter limit))))) (case grammar ((infix strict-infix) (if (= 0 (string-length s)) (if (eq? grammar 'infix) '() (complain)) splits)) ((prefix) (if (and (pair? splits) (= 0 (string-length (car splits)))) (cdr splits) splits)) ((suffix) (if (and (pair? splits) (= 0 (string-length (car (last-pair splits))))) (reverse (cdr (reverse splits))) splits)) (else (complain))))))) (define (string-split-into-characters s limit) (let ((n (string-length s))) (cond ((> n (+ limit 1)) (append (string-split-into-characters (substring s 0 limit) limit) (substring s limit n))) (else (map string (string->list s)))))) ;;; FIXME: inefficient (define (string-split-using-word s sep limit) (cond ((= 0 limit) (list s)) (else (let ((i (string-contains s sep))) (if i (cons (substring s 0 i) (string-split-using-word (substring s (+ i (string-length sep)) (string-length s)) sep (- limit 1))) (list s)))))) (define (string-remove pred s . args) (apply string-filter (lambda (c) (not (pred c))) s args)) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a130/string-cursors.sls000066400000000000000000000041751375154206600232540ustar00rootroot00000000000000(library (srfi :130 string-cursors) (export string-cursor? string-cursor-start string-cursor-end string-cursor-next string-cursor-prev string-cursor-forward string-cursor-back string-cursor=? string-cursor? string-cursor<=? string-cursor>=? string-cursor-diff string-cursor->index string-index->cursor string-null? string-every string-any string-tabulate string-unfold string-unfold-right string->list/cursors string->vector/cursors reverse-list->string string-join string-ref/cursor substring/cursors string-copy/cursors string-take string-take-right string-drop string-drop-right string-pad string-pad-right string-trim string-trim-right string-trim-both string-prefix-length string-suffix-length string-prefix? string-suffix? string-index string-index-right string-skip string-skip-right string-contains string-contains-right string-reverse string-concatenate string-concatenate-reverse string-fold string-fold-right string-for-each-cursor string-replicate string-count string-replace string-split string-filter string-remove) (import (rnrs) (rename (only (srfi :13) string-index string-index-right string-contains string-filter string-replace string-count string-fold-right string-fold string-concatenate-reverse string-concatenate string-reverse string-suffix? string-prefix? string-suffix-length string-prefix-length string-trim-both string-trim-right string-trim string-pad-right string-pad string-drop-right string-drop string-take-right string-take string-join reverse-list->string string-unfold-right string-unfold string-tabulate string-any string-every string-null?) (string-index srfi-13:string-index) (string-index-right srfi-13:string-index-right)) (only (srfi :1) last-pair) (srfi private include)) (include/resolve ("srfi" "%3a130") "130.body.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a131.sls000066400000000000000000000001231375154206600202360ustar00rootroot00000000000000(library (srfi :131) (export define-record-type) (import (srfi :131 records))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a131/000077500000000000000000000000001375154206600175175ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a131/records.sls000066400000000000000000000077721375154206600217200ustar00rootroot00000000000000(library (srfi :131 records) (export define-record-type) (import (except (rnrs) define-record-type) (srfi :99 records procedural)) (define-syntax define-record-type (syntax-rules () ((_ (type-name parent) constructor-spec predicate-spec . field-specs) (define-record-type-helper0 type-name parent constructor-spec predicate-spec . field-specs)) ((_ type-name constructor-spec predicate-spec . field-specs) (define-record-type-helper0 type-name #f constructor-spec predicate-spec . field-specs)))) ;; breaks the field-specs into two separate lists of accessors and mutators (define-syntax define-record-type-helper0 (syntax-rules () ((_ type-name parent constructor-spec predicate-spec . field-specs) (define-record-type-helper1 type-name parent constructor-spec predicate-spec field-specs ())))) ;; reverses the field-specs before delegating to a second helper (define-syntax define-record-type-helper1 (syntax-rules () ((_ type-name parent constructor-spec predicate-spec () revspecs) (define-record-type-helper2 type-name parent constructor-spec predicate-spec revspecs () () ())) ((_ type-name parent constructor-spec predicate-spec (spec . field-specs) revspecs) (define-record-type-helper1 type-name parent constructor-spec predicate-spec field-specs (spec . revspecs))))) (define-syntax define-record-type-helper2 (syntax-rules () ((_ type-name parent constructor-spec predicate-spec () accessors mutators fields) (define-record-type-helper type-name fields parent constructor-spec predicate-spec accessors mutators)) ((_ type-name parent constructor-spec predicate-spec ((field-name accessor-name) . field-specs) accessors mutators fields) (define-record-type-helper2 type-name parent constructor-spec predicate-spec field-specs ((accessor-name field-name) . accessors) mutators (field-name . fields))) ((_ type-name parent constructor-spec predicate-spec ((field-name accessor-name mutator-name) . field-specs) accessors mutators fields) (define-record-type-helper2 type-name parent constructor-spec predicate-spec field-specs ((accessor-name field-name) . accessors) ((mutator-name field-name) . mutators) (field-name . fields))))) ;; Uses the SRFI 99 procedural layer for the real work. (define-syntax define-record-type-helper (syntax-rules () ((_ type-name fields parent #f predicate ((accessor field) ...) ((mutator mutable-field) ...)) (define-record-type-helper type-name fields parent ignored predicate ((accessor field) ...) ((mutator mutable-field) ...))) ((_ type-name fields parent constructor #f ((accessor field) ...) ((mutator mutable-field) ...)) (define-record-type-helper type-name fields parent constructor ignored ((accessor field) ...) ((mutator mutable-field) ...))) ((_ type-name fields parent (constructor args) predicate ((accessor field) ...) ((mutator mutable-field) ...)) (begin (define type-name (make-rtd 'type-name 'fields parent)) (define constructor (rtd-constructor type-name 'args)) (define predicate (rtd-predicate type-name)) (define accessor (rtd-accessor type-name 'field)) ... (define mutator (rtd-mutator type-name 'mutable-field)) ...)) ((_ type-name fields parent constructor predicate ((accessor field) ...) ((mutator mutable-field) ...)) (begin (define type-name (make-rtd 'type-name 'fields parent)) (define constructor (rtd-constructor type-name)) (define predicate (rtd-predicate type-name)) (define accessor (rtd-accessor type-name 'field)) ... (define mutator (rtd-mutator type-name 'mutable-field)) ...))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132.sls000066400000000000000000000006631375154206600202500ustar00rootroot00000000000000(library (srfi :132) (export list-sorted? vector-sorted? list-merge vector-merge list-sort vector-sort list-stable-sort vector-stable-sort list-merge! vector-merge! list-sort! vector-sort! list-stable-sort! vector-stable-sort! list-delete-neighbor-dups vector-delete-neighbor-dups list-delete-neighbor-dups! vector-delete-neighbor-dups! vector-find-median vector-find-median!) (import (srfi :132 sorting))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/000077500000000000000000000000001375154206600175205ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/delndups.scm000066400000000000000000000147201375154206600220460ustar00rootroot00000000000000;;; The sort package -- delete neighboring duplicate elts ;;; Copyright (c) 1998 by Olin Shivers. ;;; This code is open-source; see the end of the file for porting and ;;; more copyright information. ;;; Olin Shivers 11/98. ;;; Problem: ;;; vector-delete-neighbor-dups pushes N stack frames, where N is the number ;;; of elements in the answer vector. This is arguably a very efficient thing ;;; to do, but it might blow out on a system with a limited stack but a big ;;; heap. We could rewrite this to "chunk" up answers in temp vectors if we ;;; push more than a certain number of frames, then allocate a final answer, ;;; copying all the chunks into the answer. But it's much more complex code. ;;; Exports: ;;; (list-delete-neighbor-dups = lis) -> list ;;; (list-delete-neighbor-dups! = lis) -> list ;;; (vector-delete-neighbor-dups = v [start end]) -> vector ;;; (vector-delete-neighbor-dups! = v [start end]) -> end' ;;; These procedures delete adjacent duplicate elements from a list or ;;; a vector, using a given element equality procedure. The first or leftmost ;;; element of a run of equal elements is the one that survives. The list ;;; or vector is not otherwise disordered. ;;; ;;; These procedures are linear time -- much faster than the O(n^2) general ;;; duplicate-elt deletors that do not assume any "bunching" of elements. ;;; If you want to delete duplicate elements from a large list or vector, ;;; sort the elements to bring equal items together, then use one of these ;;; procedures -- for a total time of O(n lg n). ;;; LIST-DELETE-NEIGHBOR-DUPS ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Below are multiple versions of the LIST-DELETE-NEIGHBOR-DUPS procedure, ;;; from simple to complex. RECUR's contract: Strip off any leading X's from ;;; LIS, and return that list neighbor-dup-deleted. ;;; ;;; The final version ;;; - shares a common subtail between the input & output list, up to 1024 ;;; elements; ;;; - Needs no more than 1024 stack frames. #; ;;; Simplest version. ;;; - Always allocates a fresh list / never shares storage. ;;; - Needs N stack frames, if answer is length N. (define (list-delete-neighbor-dups = lis) (if (pair? lis) (let ((x0 (car lis))) (cons x0 (let recur ((x0 x0) (xs (cdr lis))) (if (pair? xs) (let ((x1 (car xs)) (x2+ (cdr xs))) (if (= x0 x1) (recur x0 x2+) ; Loop, actually. (cons x1 (recur x1 x2+)))) xs)))) lis)) ;;; This version tries to use cons cells from input by sharing longest ;;; common tail between input & output. Still needs N stack frames, for ans ;;; of length N. (define (list-delete-neighbor-dups = lis) (if (pair? lis) (let* ((x0 (car lis)) (xs (cdr lis)) (ans (let recur ((x0 x0) (xs xs)) (if (pair? xs) (let ((x1 (car xs)) (x2+ (cdr xs))) (if (= x0 x1) (recur x0 x2+) (let ((ans-tail (recur x1 x2+))) (if (eq? ans-tail x2+) xs (cons x1 ans-tail))))) xs)))) (if (eq? ans xs) lis (cons x0 ans))) lis)) ;;; LIST-DELETE-NEIGHBOR-DUPS! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code runs in constant list space, constant stack, and also ;;; does only the minimum SET-CDR!'s necessary. (define (list-delete-neighbor-dups! = lis) (if (pair? lis) (let lp1 ((prev lis) (prev-elt (car lis)) (lis (cdr lis))) (if (pair? lis) (let ((lis-elt (car lis)) (next (cdr lis))) (if (= prev-elt lis-elt) ;; We found the first elts of a run of dups, so we know ;; we're going to have to do a SET-CDR!. Scan to the end of ;; the run, do the SET-CDR!, and loop on LP1. (let lp2 ((lis next)) (if (pair? lis) (let ((lis-elt (car lis)) (next (cdr lis))) (if (= prev-elt lis-elt) (lp2 next) (begin (set-cdr! prev lis) (lp1 lis lis-elt next)))) (set-cdr! prev lis))) ; Ran off end => quit. (lp1 lis lis-elt next)))))) lis) (define (vector-delete-neighbor-dups elt= v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (if (< start end) (let* ((x (vector-ref v start)) (ans (let recur ((x x) (i start) (j 1)) (if (< i end) (let ((y (vector-ref v i)) (nexti (+ i 1))) (if (elt= x y) (recur x nexti j) (let ((ansvec (recur y nexti (+ j 1)))) (vector-set! ansvec j y) ansvec))) (make-vector j))))) (vector-set! ans 0 x) ans) '#())))) ;;; Packs the surviving elements to the left, in range [start,end'), ;;; and returns END'. (define (vector-delete-neighbor-dups! elt= v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (if (>= start end) end ;; To eliminate unnecessary copying (read elt i then write the value ;; back at index i), we scan until we find the first dup. (let skip ((j start) (vj (vector-ref v start))) (let ((j+1 (+ j 1))) (if (>= j+1 end) end (let ((vj+1 (vector-ref v j+1))) (if (not (elt= vj vj+1)) (skip j+1 vj+1) ;; OK -- j & j+1 are dups, so we're committed to moving ;; data around. In lp2, v[start,j] is what we've done; ;; v[k,end) is what we have yet to handle. (let lp2 ((j j) (vj vj) (k (+ j 2))) (let lp3 ((k k)) (if (>= k end) (+ j 1) ; Done. (let ((vk (vector-ref v k)) (k+1 (+ k 1))) (if (elt= vj vk) (lp3 k+1) (let ((j+1 (+ j 1))) (vector-set! v j+1 vk) (lp2 j+1 vk k+1)))))))))))))))) ;;; Copyright ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code is ;;; Copyright (c) 1998 by Olin Shivers. ;;; The terms are: You may do as you please with this code, as long as ;;; you do not delete this notice or hold me responsible for any outcome ;;; related to its use. ;;; ;;; Blah blah blah. Don't you think source files should contain more lines ;;; of code than copyright notice? ;;; ;;; Code porting ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; If your Scheme has a faster mechanism for handling optional arguments ;;; (e.g., Chez), you should definitely port over to it. Note that argument ;;; defaulting and error-checking are interleaved -- you don't have to ;;; error-check defaulted START/END args to see if they are fixnums that are ;;; legal vector indices for the corresponding vector, etc. chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/lmsort.scm000066400000000000000000000353271375154206600215560ustar00rootroot00000000000000;;; list merge & list merge-sort -*- Scheme -*- ;;; Copyright (c) 1998 by Olin Shivers. ;;; This code is open-source; see the end of the file for porting and ;;; more copyright information. ;;; Olin Shivers ;;; Exports: ;;; (list-merge < lis lis) -> list ;;; (list-merge! < lis lis) -> list ;;; (list-merge-sort < lis) -> list ;;; (list-merge-sort! < lis) -> list ;;; A stable list merge sort of my own device ;;; Two variants: pure & destructive ;;; ;;; This list merge sort is opportunistic (a "natural" sort) -- it exploits ;;; existing order in the input set. Instead of recursing all the way down to ;;; individual elements, the leaves of the merge tree are maximal contiguous ;;; runs of elements from the input list. So the algorithm does very well on ;;; data that is mostly ordered, with a best-case time of O(n) when the input ;;; list is already completely sorted. In any event, worst-case time is ;;; O(n lg n). ;;; ;;; The destructive variant is "in place," meaning that it allocates no new ;;; cons cells at all; it just rearranges the pairs of the input list with ;;; SET-CDR! to order it. ;;; ;;; The interesting control structure is the combination recursion/iteration ;;; of the core GROW function that does an "opportunistic" DFS walk of the ;;; merge tree, adaptively subdividing in response to the length of the ;;; merges, without requiring any auxiliary data structures beyond the ;;; recursion stack. It's actually quite simple -- ten lines of code. ;;; -Olin Shivers 10/20/98 ;;; (mlet ((var-list mv-exp) ...) body ...) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; A LET* form that handles multiple values. Move this into the two clients ;;; if you don't have a module system handy to restrict its visibility... (define-syntax mlet ; Multiple-value LET* (syntax-rules () ((mlet ((() exp) rest ...) body ...) (begin exp (mlet (rest ...) body ...))) ((mlet (((var) exp) rest ...) body ...) (let ((var exp)) (mlet (rest ...) body ...))) ((mlet ((vars exp) rest ...) body ...) (call-with-values (lambda () exp) (lambda vars (mlet (rest ...) body ...)))) ((mlet () body ...) (begin body ...)))) ;;; (list-merge-sort < lis) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; A natural, stable list merge sort. ;;; - natural: picks off maximal contiguous runs of pre-ordered data. ;;; - stable: won't invert the order of equal elements in the input list. (define (list-merge-sort elt< lis) ;; (getrun lis) -> run runlen rest ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Pick a run of non-decreasing data off of non-empty list LIS. ;; Return the length of this run, and the following list. (define (getrun lis) (let lp ((ans '()) (i 1) (prev (car lis)) (xs (cdr lis))) (if (pair? xs) (let ((x (car xs))) (if (elt< x prev) (values (append-reverse ans (cons prev '())) i xs) (lp (cons prev ans) (+ i 1) x (cdr xs)))) (values (append-reverse ans (cons prev '())) i xs)))) (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 (null-list? l) (cond ((pair? l) #f) ((null? l) #t) (else (error "argument out of domain" l)))) ;; (merge a b) -> list ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; List merge -- stably merge lists A (length > 0) & B (length > 0). ;; This version requires up to |a|+|b| stack frames. (define (merge a b) (let recur ((x (car a)) (a a) (y (car b)) (b b)) (if (elt< y x) (cons y (let ((b (cdr b))) (if (pair? b) (recur x a (car b) b) a))) (cons x (let ((a (cdr a))) (if (pair? a) (recur (car a) a y b) b)))))) ;; (grow s ls ls2 u lw) -> [a la unused] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The core routine. Read the next 20 lines of comments & all is obvious. ;; - S is a sorted list of length LS > 1. ;; - LS2 is some power of two <= LS. ;; - U is an unsorted list. ;; - LW is a positive integer. ;; Starting with S, and taking data from U as needed, produce ;; a sorted list of *at least* length LW, if there's enough data ;; (LW <= LS + length(U)), or use all of U if not. ;; ;; GROW takes maximal contiguous runs of data from U at a time; ;; it is allowed to return a list *longer* than LW if it gets lucky ;; with a long run. ;; ;; The key idea: If you want a merge operation to "pay for itself," the two ;; lists being merged should be about the same length. Remember that. ;; ;; Returns: ;; - A: The result list ;; - LA: The length of the result list ;; - UNUSED: The unused tail of U. (define (grow s ls ls2 u lw) ; The core of the sort algorithm. (if (or (<= lw ls) (not (pair? u))) ; Met quota or out of data? (values s ls u) ; If so, we're done. (mlet (((ls2) (let lp ((ls2 ls2)) (let ((ls2*2 (+ ls2 ls2))) (if (<= ls2*2 ls) (lp ls2*2) ls2)))) ;; LS2 is now the largest power of two <= LS. ;; (Just think of it as being roughly LS.) ((r lr u2) (getrun u)) ; Get a run, then ((t lt u3) (grow r lr 1 u2 ls2))) ; grow it up to be T. (grow (merge s t) (+ ls lt) ; Merge S & T, (+ ls2 ls2) u3 lw)))) ; and loop. ;; Note: (LENGTH LIS) or any constant guaranteed ;; to be greater can be used in place of INFINITY. (if (pair? lis) ; Don't sort an empty list. (mlet (((r lr tail) (getrun lis)) ; Pick off an initial run, ((infinity) #o100000000) ; then grow it up maximally. ((a la v) (grow r lr 1 tail infinity))) a) '())) ;;; (list-merge-sort! < lis) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; A natural, stable, destructive, in-place list merge sort. ;;; - natural: picks off maximal contiguous runs of pre-ordered data. ;;; - stable: won't invert the order of equal elements in the input list. ;;; - destructive, in-place: this routine allocates no extra working memory; ;;; it simply rearranges the list with SET-CDR! operations. (define (list-merge-sort! elt< lis) ;; (getrun lis) -> runlen last rest ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Pick a run of non-decreasing data off of non-empty list LIS. ;; Return the length of this run, the last cons cell of the run, ;; and the following list. (define (getrun lis) (let lp ((lis lis) (x (car lis)) (i 1) (next (cdr lis))) (if (pair? next) (let ((y (car next))) (if (elt< y x) (values i lis next) (lp next y (+ i 1) (cdr next)))) (values i lis next)))) ;; (merge! a enda b endb) -> [m endm] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Destructively and stably merge non-empty lists A & B. ;; The last cons of A is ENDA. (The cdr of ENDA can be non-nil.) ;; the last cons of B is ENDB. (The cdr of ENDB can be non-nil.) ;; ;; Return the first and last cons cells of the merged list. ;; This routine is iterative & in-place: it runs in constant stack and ;; doesn't allocate any cons cells. It is also tedious but simple; don't ;; bother reading it unless necessary. (define (merge! a enda b endb) ;; The logic of these two loops is completely driven by these invariants: ;; SCAN-A: (CDR PREV) = A. X = (CAR A). Y = (CAR B). ;; SCAN-B: (CDR PREV) = B. X = (CAR A). Y = (CAR B). (letrec ((scan-a (lambda (prev x a y b) ; Zip down A until we (cond ((elt< y x) ; find an elt > (CAR B). (set-cdr! prev b) (let ((next-b (cdr b))) (if (eq? b endb) (begin (set-cdr! b a) enda) ; Done. (scan-b b x a (car next-b) next-b)))) ((eq? a enda) (maybe-set-cdr! a b) endb) ; Done. (else (let ((next-a (cdr a))) ; Continue scan. (scan-a a (car next-a) next-a y b)))))) (scan-b (lambda (prev x a y b) ; Zip down B while its (cond ((elt< y x) ; elts are < (CAR A). (if (eq? b endb) (begin (set-cdr! b a) enda) ; Done. (let ((next-b (cdr b))) ; Continue scan. (scan-b b x a (car next-b) next-b)))) (else (set-cdr! prev a) (if (eq? a enda) (begin (maybe-set-cdr! a b) endb) ; Done. (let ((next-a (cdr a))) (scan-a a (car next-a) next-a y b))))))) ;; This guy only writes if he has to. Called at most once. ;; Pointer equality rules; pure languages are for momma's boys. (maybe-set-cdr! (lambda (pair val) (if (not (eq? (cdr pair) val)) (set-cdr! pair val))))) (let ((x (car a)) (y (car b))) (if (elt< y x) ;; B starts the answer list. (values b (if (eq? b endb) (begin (set-cdr! b a) enda) (let ((next-b (cdr b))) (scan-b b x a (car next-b) next-b)))) ;; A starts the answer list. (values a (if (eq? a enda) (begin (maybe-set-cdr! a b) endb) (let ((next-a (cdr a))) (scan-a a (car next-a) next-a y b)))))))) ;; (grow s ends ls ls2 u lw) -> [a enda la unused] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; The core routine. ;; - S is a sorted list of length LS > 1, with final cons cell ENDS. ;; (CDR ENDS) doesn't have to be nil. ;; - LS2 is some power of two <= LS. ;; - U is an unsorted list. ;; - LW is a positive integer. ;; Starting with S, and taking data from U as needed, produce ;; a sorted list of *at least* length LW, if there's enough data ;; (LW <= LS + length(U)), or use all of U if not. ;; ;; GROW takes maximal contiguous runs of data from U at a time; ;; it is allowed to return a list *longer* than LW if it gets lucky ;; with a long run. ;; ;; The key idea: If you want a merge operation to "pay for itself," the two ;; lists being merged should be about the same length. Remember that. ;; ;; Returns: ;; - A: The result list (not properly terminated) ;; - ENDA: The last cons cell of the result list. ;; - LA: The length of the result list ;; - UNUSED: The unused tail of U. (define (grow s ends ls ls2 u lw) (if (and (pair? u) (< ls lw)) ;; We haven't met the LW quota but there's still some U data to use. (mlet (((ls2) (let lp ((ls2 ls2)) (let ((ls2*2 (+ ls2 ls2))) (if (<= ls2*2 ls) (lp ls2*2) ls2)))) ;; LS2 is now the largest power of two <= LS. ;; (Just think of it as being roughly LS.) ((lr endr u2) (getrun u)) ; Get a run from U; ((t endt lt u3) (grow u endr lr 1 u2 ls2)) ; grow it up to be T. ((st end-st) (merge! s ends t endt))) ; Merge S & T, (grow st end-st (+ ls lt) (+ ls2 ls2) u3 lw)) ; then loop. (values s ends ls u))) ; Done -- met LW quota or ran out of data. ;; Note: (LENGTH LIS) or any constant guaranteed ;; to be greater can be used in place of INFINITY. (if (pair? lis) (mlet (((lr endr rest) (getrun lis)) ; Pick off an initial run. ((infinity) #o100000000) ; Then grow it up maximally. ((a enda la v) (grow lis endr lr 1 rest infinity))) (set-cdr! enda '()) ; Nil-terminate answer. a) ; We're done. '())) ; Don't sort an empty list. ;;; Merge ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; These two merge procedures are stable -- ties favor list A. (define (list-merge < a b) (cond ((not (pair? a)) b) ((not (pair? b)) a) (else (let recur ((x (car a)) (a a) ; A is a pair; X = (CAR A). (y (car b)) (b b)) ; B is a pair; Y = (CAR B). (if (< y x) (let ((b (cdr b))) (if (pair? b) (cons y (recur x a (car b) b)) (cons y a))) (let ((a (cdr a))) (if (pair? a) (cons x (recur (car a) a y b)) (cons x b)))))))) ;;; This destructive merge does as few SET-CDR!s as it can -- for example, if ;;; the list is already sorted, it does no SET-CDR!s at all. It is also ;;; iterative, running in constant stack. (define (list-merge! < a b) ;; The logic of these two loops is completely driven by these invariants: ;; SCAN-A: (CDR PREV) = A. X = (CAR A). Y = (CAR B). ;; SCAN-B: (CDR PREV) = B. X = (CAR A). Y = (CAR B). (letrec ((scan-a (lambda (prev a x b y) ; Zip down A doing (if (< y x) ; no SET-CDR!s until (let ((next-b (cdr b))) ; we hit a B elt that (set-cdr! prev b) ; has to be inserted. (if (pair? next-b) (scan-b b a x next-b (car next-b)) (set-cdr! b a))) (let ((next-a (cdr a))) (if (pair? next-a) (scan-a a next-a (car next-a) b y) (set-cdr! a b)))))) (scan-b (lambda (prev a x b y) ; Zip down B doing (if (< y x) ; no SET-CDR!s until (let ((next-b (cdr b))) ; we hit an A elt that (if (pair? next-b) ; has to be (scan-b b a x next-b (car next-b)) ; inserted. (set-cdr! b a))) (let ((next-a (cdr a))) (set-cdr! prev a) (if (pair? next-a) (scan-a a next-a (car next-a) b y) (set-cdr! a b))))))) (cond ((not (pair? a)) b) ((not (pair? b)) a) ;; B starts the answer list. ((< (car b) (car a)) (let ((next-b (cdr b))) (if (null? next-b) (set-cdr! b a) (scan-b b a (car a) next-b (car next-b)))) b) ;; A starts the answer list. (else (let ((next-a (cdr a))) (if (null? next-a) (set-cdr! a b) (scan-a a next-a (car next-a) b (car b)))) a)))) ;;; Copyright ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code is ;;; Copyright (c) 1998 by Olin Shivers. ;;; The terms are: You may do as you please with this code, as long as ;;; you do not delete this notice or hold me responsible for any outcome ;;; related to its use. ;;; ;;; Blah blah blah. ;;; Code tuning & porting ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This is very portable code. It's R4RS with the following exceptions: ;;; - The R5RS multiple-value VALUES & CALL-WITH-VALUES procedures for ;;; handling multiple-value return. ;;; ;;; This code is *tightly* bummed as far as I can go in portable Scheme. ;;; ;;; - The fixnum arithmetic in LIST-MERGE-SORT! and COUNTED-LIST-MERGE! ;;; that could be safely switched over to unsafe, fixnum-specific ops, ;;; if you're sure that 2*maxlen is a fixnum, where maxlen is the length ;;; of the longest list you could ever have. ;;; ;;; - I typically write my code in a style such that every CAR and CDR ;;; application is protected by an upstream PAIR?. This is the case in this ;;; code, so all the CAR's and CDR's could safely switched over to unsafe ;;; versions. But check over the code before you do it, in case the source ;;; has been altered since I wrote this. chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/median.scm000066400000000000000000000017211375154206600214620ustar00rootroot00000000000000;;;; Finding the median of a vector ;; This involves sorting the vector, which is why it's part ;; of this package. (define (vector-find-median < v knil . maybe-mean) (define mean (if (null? maybe-mean) (lambda (a b) (/ (+ a b) 2)) (car maybe-mean))) (define len (vector-length v)) (define newv (vector-sort < v)) (cond ((= len 0) knil) ((odd? len) (vector-ref newv (/ (- len 1) 2))) (else (mean (vector-ref newv (- (/ len 2) 1)) (vector-ref newv (/ len 2)))))) (define (vector-find-median! < v knil . maybe-mean) (define mean (if (null? maybe-mean) (lambda (a b) (/ (+ a b) 2)) (car maybe-mean))) (define len (vector-length v)) (define newv (vector-sort! < v)) (cond ((= len 0) knil) ((odd? len) (vector-ref newv (/ (- len 1) 2))) (else (mean (vector-ref newv (- (/ len 2) 1)) (vector-ref newv (/ len 2)))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/merge.scm000066400000000000000000000174611375154206600213340ustar00rootroot00000000000000;;; This file extracts four merge procedures from lmsort.scm and vmsort.scm ;;; files written by Olin Shivers. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Start of code extracted from Olin's lmsort.scm file. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; list merge & list merge-sort -*- Scheme -*- ;;; Copyright (c) 1998 by Olin Shivers. ;;; This code is open-source; see the end of the file for porting and ;;; more copyright information. ;;; Olin Shivers ;;; Exports: ;;; (list-merge < lis lis) -> list ;;; (list-merge! < lis lis) -> list ;;; Merge ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; These two merge procedures are stable -- ties favor list A. (define (list-merge < a b) (cond ((not (pair? a)) b) ((not (pair? b)) a) (else (let recur ((x (car a)) (a a) ; A is a pair; X = (CAR A). (y (car b)) (b b)) ; B is a pair; Y = (CAR B). (if (< y x) (let ((b (cdr b))) (if (pair? b) (cons y (recur x a (car b) b)) (cons y a))) (let ((a (cdr a))) (if (pair? a) (cons x (recur (car a) a y b)) (cons x b)))))))) ;;; This destructive merge does as few SET-CDR!s as it can -- for example, if ;;; the list is already sorted, it does no SET-CDR!s at all. It is also ;;; iterative, running in constant stack. (define (list-merge! < a b) ;; The logic of these two loops is completely driven by these invariants: ;; SCAN-A: (CDR PREV) = A. X = (CAR A). Y = (CAR B). ;; SCAN-B: (CDR PREV) = B. X = (CAR A). Y = (CAR B). (letrec ((scan-a (lambda (prev a x b y) ; Zip down A doing (if (< y x) ; no SET-CDR!s until (let ((next-b (cdr b))) ; we hit a B elt that (set-cdr! prev b) ; has to be inserted. (if (pair? next-b) (scan-b b a x next-b (car next-b)) (set-cdr! b a))) (let ((next-a (cdr a))) (if (pair? next-a) (scan-a a next-a (car next-a) b y) (set-cdr! a b)))))) (scan-b (lambda (prev a x b y) ; Zip down B doing (if (< y x) ; no SET-CDR!s until (let ((next-b (cdr b))) ; we hit an A elt that (if (pair? next-b) ; has to be (scan-b b a x next-b (car next-b)) ; inserted. (set-cdr! b a))) (let ((next-a (cdr a))) (set-cdr! prev a) (if (pair? next-a) (scan-a a next-a (car next-a) b y) (set-cdr! a b))))))) (cond ((not (pair? a)) b) ((not (pair? b)) a) ;; B starts the answer list. ((< (car b) (car a)) (let ((next-b (cdr b))) (if (null? next-b) (set-cdr! b a) (scan-b b a (car a) next-b (car next-b)))) b) ;; A starts the answer list. (else (let ((next-a (cdr a))) (if (null? next-a) (set-cdr! a b) (scan-a a next-a (car next-a) b (car b)))) a)))) ;;; Copyright ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code is ;;; Copyright (c) 1998 by Olin Shivers. ;;; The terms are: You may do as you please with this code, as long as ;;; you do not delete this notice or hold me responsible for any outcome ;;; related to its use. ;;; ;;; Blah blah blah. ;;; Code tuning & porting ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This is very portable code. It's R4RS with the following exceptions: ;;; - The R5RS multiple-value VALUES & CALL-WITH-VALUES procedures for ;;; handling multiple-value return. ;;; ;;; This code is *tightly* bummed as far as I can go in portable Scheme. ;;; ;;; - The fixnum arithmetic in LIST-MERGE-SORT! and COUNTED-LIST-MERGE! ;;; that could be safely switched over to unsafe, fixnum-specific ops, ;;; if you're sure that 2*maxlen is a fixnum, where maxlen is the length ;;; of the longest list you could ever have. ;;; ;;; - I typically write my code in a style such that every CAR and CDR ;;; application is protected by an upstream PAIR?. This is the case in this ;;; code, so all the CAR's and CDR's could safely switched over to unsafe ;;; versions. But check over the code before you do it, in case the source ;;; has been altered since I wrote this. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; End of code extracted from Olin's lmsort.scm file. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Start of code extracted from Olin's vmsort.scm file. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The sort package -- stable vector merge & merge sort -*- Scheme -*- ;;; Copyright (c) 1998 by Olin Shivers. ;;; This code is open-source; see the end of the file for porting and ;;; more copyright information. ;;; Olin Shivers 10/98. ;;; Exports: ;;; (vector-merge < v1 v2 [start1 end1 start2 end2]) -> vector ;;; (vector-merge! < v v1 v2 [start0 start1 end1 start2 end2]) -> unspecific ;;; ;;; (vector-merge-sort < v [start end temp]) -> vector ;;; (vector-merge-sort! < v [start end temp]) -> unspecific ;;; Merge ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (vector-merge < v1 v2 [start1 end1 start2 end2]) -> vector ;;; (vector-merge! < v v1 v2 [start start1 end1 start2 end2]) -> unspecific ;;; ;;; Stable vector merge -- V1's elements come out ahead of equal V2 elements. (define (vector-merge < v1 v2 . maybe-starts+ends) (call-with-values (lambda () (vectors-start+end-2 v1 v2 maybe-starts+ends)) (lambda (start1 end1 start2 end2) (let ((ans (make-vector (+ (- end1 start1) (- end2 start2))))) (%vector-merge! < ans v1 v2 0 start1 end1 start2 end2) ans)))) (define (vector-merge! < v v1 v2 . maybe-starts+ends) (call-with-values (lambda () (if (pair? maybe-starts+ends) (values (car maybe-starts+ends) (cdr maybe-starts+ends)) (values 0 '()))) (lambda (start rest) (call-with-values (lambda () (vectors-start+end-2 v1 v2 rest)) (lambda (start1 end1 start2 end2) (%vector-merge! < v v1 v2 start start1 end1 start2 end2)))))) ;;; This routine is not exported. The code is tightly bummed. ;;; ;;; If these preconditions hold, the routine can be bummed to run with ;;; unsafe vector-indexing and fixnum arithmetic ops: ;;; - V V1 V2 are vectors. ;;; - START START1 END1 START2 END2 are fixnums. ;;; - (<= 0 START END0 (vector-length V), ;;; where end0 = start + (end1 - start1) + (end2 - start2) ;;; - (<= 0 START1 END1 (vector-length V1)) ;;; - (<= 0 START2 END2 (vector-length V2)) ;;; If you put these error checks in the two client procedures above, you can ;;; safely convert this procedure to use unsafe ops -- which is why it isn't ;;; exported. This will provide *huge* speedup. (define (%vector-merge! elt< v v1 v2 start start1 end1 start2 end2) (letrec ((vblit (lambda (fromv j i end) ; Blit FROMV[J,END) to V[I,?]. (let lp ((j j) (i i)) (vector-set! v i (vector-ref fromv j)) (let ((j (+ j 1))) (if (< j end) (lp j (+ i 1)))))))) (cond ((<= end1 start1) (if (< start2 end2) (vblit v2 start2 start end2))) ((<= end2 start2) (vblit v1 start1 start end1)) ;; Invariants: I is next index of V to write; X = V1[J]; Y = V2[K]. (else (let lp ((i start) (j start1) (x (vector-ref v1 start1)) (k start2) (y (vector-ref v2 start2))) (let ((i1 (+ i 1))) ; "i+1" is a complex number in R4RS! (if (elt< y x) (let ((k (+ k 1))) (vector-set! v i y) (if (< k end2) (lp i1 j x k (vector-ref v2 k)) (vblit v1 j i1 end1))) (let ((j (+ j 1))) (vector-set! v i x) (if (< j end1) (lp i1 j (vector-ref v1 j) k y) (vblit v2 k i1 end2)))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; End of code extracted from Olin's vmsort.scm file. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/select.scm000066400000000000000000000240031375154206600215020ustar00rootroot00000000000000;;; Linear-time (average case) algorithms for: ;;; ;;; Selecting the kth smallest element from an unsorted vector. ;;; Selecting the kth and (k+1)st smallest elements from an unsorted vector. ;;; Selecting the median from an unsorted vector. ;;; These procedures are part of SRFI 132 but are missing from ;;; its reference implementation as of 10 March 2016. ;;; SRFI 132 says this procedure runs in O(n) time. ;;; As implemented, however, the worst-case time is O(n^2) because ;;; vector-select is implemented using randomized quickselect. ;;; The average time is O(n), and you'd have to be unlucky ;;; to approach the worst case. (define (vector-find-median < v knil . rest) (let* ((mean (if (null? rest) (lambda (a b) (/ (+ a b) 2)) (car rest))) (n (vector-length v))) (cond ((zero? n) knil) ((odd? n) (%vector-select < v (quotient n 2) 0 n)) (else (call-with-values (lambda () (%vector-select2 < v (- (quotient n 2) 1) 0 n)) (lambda (a b) (mean a b))))))) ;;; For this procedure, the SRFI 132 specification ;;; demands the vector be sorted (by side effect). (define (vector-find-median! < v knil . rest) (let* ((mean (if (null? rest) (lambda (a b) (/ (+ a b) 2)) (car rest))) (n (vector-length v))) (vector-sort! < v) (cond ((zero? n) knil) ((odd? n) (vector-ref v (quotient n 2))) (else (mean (vector-ref v (- (quotient n 2) 1)) (vector-ref v (quotient n 2))))))) ;;; SRFI 132 says this procedure runs in O(n) time. ;;; As implemented, however, the worst-case time is O(n^2). ;;; The average time is O(n), and you'd have to be unlucky ;;; to approach the worst case. ;;; ;;; After rest argument processing, calls the private version defined below. (define (vector-select < v k . rest) (let* ((start (if (null? rest) 0 (car rest))) (end (if (and (pair? rest) (pair? (cdr rest))) (car (cdr rest)) (vector-length v)))) (%vector-select < v k start end))) ;;; The vector-select procedure is needed internally to implement ;;; vector-find-median, but SRFI 132 has been changed (for no good ;;; reason) to export vector-select! instead of vector-select. ;;; Fortunately, vector-select! is not required to have side effects. (define vector-select! vector-select) ;;; This could be made slightly more efficient, but who cares? (define (vector-separate! < v k . rest) (let* ((start (if (null? rest) 0 (car rest))) (end (if (and (pair? rest) (pair? (cdr rest))) (car (cdr rest)) (vector-length v)))) (if (and (> k 0) (> end start)) (let ((pivot (vector-select < v (- k 1) start end))) (call-with-values (lambda () (count-smaller < pivot v start end 0 0)) (lambda (count count2) (let* ((v2 (make-vector count)) (v3 (make-vector (- end start count count2)))) (copy-smaller! < pivot v2 0 v start end) (copy-bigger! < pivot v3 0 v start end) (r7rs-vector-copy! v start v2) (r7rs-vector-fill! v pivot (+ start count) (+ start count count2)) (r7rs-vector-copy! v (+ start count count2) v3)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; For small ranges, sorting may be the fastest way to find the kth element. ;;; This threshold is not at all critical, and may not even be worthwhile. (define just-sort-it-threshold 50) ;;; Given ;;; an irreflexive total order vector l))) ; a vector and sorting that. (vector-heap-sort! < v) (vector->list v))) (define list-sort! list-merge-sort!) (define list-stable-sort list-merge-sort) (define list-stable-sort! list-merge-sort!) (define vector-sort vector-quick-sort) (define vector-sort! vector-quick-sort!) (define vector-stable-sort vector-merge-sort) (define vector-stable-sort! vector-merge-sort!) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/sortfaster.scm000066400000000000000000000031451375154206600224230ustar00rootroot00000000000000;;; SRFI 132 specifies these eight procedures. ;;; ;;; Benchmarking has shown that the (rnrs sorting) procedures ;;; are faster than the sorting procedures defined by SRFI 132's ;;; reference implementation, so the R6RS procedures are used here. ;;; ;;; This file is a plug-and-play alternative to sort.scm in the ;;; same directory. (define list-sort r6rs-list-sort) (define list-sort! r6rs-list-sort) (define list-stable-sort r6rs-list-sort) (define list-stable-sort! r6rs-list-sort) (define (vector-sort < v . rest) (cond ((null? rest) (r6rs-vector-sort < v)) ((null? (cdr rest)) (r6rs-vector-sort < (r7rs-vector-copy v (car rest)))) ((null? (cddr rest)) (r6rs-vector-sort < (r7rs-vector-copy v (car rest) (cadr rest)))) (else (error 'vector-sort "too many arguments" (cons < (cons v rest)))))) (define vector-stable-sort vector-sort) (define (vector-sort! < v . rest) (cond ((null? rest) (r6rs-vector-sort! < v)) ((null? (cdr rest)) (let* ((start (car rest)) (v2 (r7rs-vector-copy v start))) (r6rs-vector-sort! < v2) (r7rs-vector-copy! v start v2 0))) ((null? (cddr rest)) (let* ((start (car rest)) (end (cadr rest)) (v2 (r7rs-vector-copy v start end))) (r6rs-vector-sort! < v2) (r7rs-vector-copy! v start v2 0))) (else (error 'vector-sort! "too many arguments" (cons < (cons v rest)))))) (define vector-stable-sort! vector-sort!) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/sorting-test.scm000066400000000000000000000047141375154206600226740ustar00rootroot00000000000000;;; Little test harness, 'cause I'm paraoid about tricky code. ;;; This code is ;;; Copyright (c) 1998 by Olin Shivers. ;;; The terms are: You may do as you please with this code, as long as ;;; you do not delete this notice or hold me responsible for any outcome ;;; related to its use. ;;; ;;; Blah blah blah. Don't you think source files should contain more lines ;;; of code than copyright notice? (define-test-suite sort-tests) ;; Three-way comparison for numbers (define (my-c x y) (cond ((= x y) 0) ((< x y) -1) (else 1))) ;;; For testing stable sort -- 3 & -3 compare the same. (define (my< x y) (< (abs x) (abs y))) (define (unstable-sort-test v) ; quick & heap vs simple insert (let ((v1 (vector-copy v)) (v2 (vector-copy v)) (v3 (vector-copy v)) (v4 (vector-copy v))) (vector-heap-sort! < v1) (vector-insert-sort! < v2) (vector-quick-sort! < v3) (vector-quick-sort3! my-c v4) (check-that v2 (is v1)) (check-that v3 (is v1)) (check-that v4 (is v1)) (check-that v1 (is (lambda (v) (vector-sorted? < v)))))) (define (stable-sort-test v) ; insert, list & vector merge sorts (let ((v1 (vector-copy v)) (v2 (vector-copy v)) (v3 (list->vector (list-merge-sort! my< (vector->list v)))) (v4 (list->vector (list-merge-sort my< (vector->list v))))) (vector-merge-sort! my< v1) (vector-insert-sort! my< v2) (check-that v1 (is (lambda (v) (vector-sorted? my< v)))) (check-that v2 (is v1)) (check-that v3 (is v1)) (check-that v4 (is v1)))) (define (run-sort-test sort-test count max-size) (let loop ((i 0)) (if (< i count) (begin (sort-test (random-vector (random-integer max-size))) (loop (+ 1 i)))))) (define-test-case stable-sort sort-tests (run-sort-test stable-sort-test 10 4096)) (define-test-case unstable-sort sort-tests (run-sort-test unstable-sort-test 10 4096)) (define (random-vector size) (let ((v (make-vector size))) (fill-vector-randomly! v (* 10 size)) v)) (define (fill-vector-randomly! v range) (let ((half (quotient range 2))) (do ((i (- (vector-length v) 1) (- i 1))) ((< i 0)) (vector-set! v i (- (random-integer range) half))))) (define (vector-portion-copy vec start end) (let* ((len (vector-length vec)) (new-len (- end start)) (new (make-vector new-len))) (do ((i start (+ i 1)) (j 0 (+ j 1))) ((= i end) new) (vector-set! new j (vector-ref vec i))))) (define (vector-copy vec) (vector-portion-copy vec 0 (vector-length vec))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/sorting.sls000066400000000000000000000023771375154206600217410ustar00rootroot00000000000000(library (srfi :132 sorting) (export list-sorted? vector-sorted? list-merge vector-merge list-sort vector-sort list-stable-sort vector-stable-sort list-merge! vector-merge! list-sort! vector-sort! list-stable-sort! vector-stable-sort! list-delete-neighbor-dups vector-delete-neighbor-dups list-delete-neighbor-dups! vector-delete-neighbor-dups! vector-find-median vector-find-median!) (import (except (rnrs) list-sort vector-sort vector-sort!) (rnrs mutable-pairs) (rename (only (srfi :133 vectors) vector-copy! vector-copy) (vector-copy! r7rs-vector-copy!) (vector-copy r7rs-vector-copy)) (only (rnrs r5rs) quotient) (srfi private include)) (include/resolve ("srfi" "%3a132") "delndups.scm") (include/resolve ("srfi" "%3a132") "lmsort.scm") (include/resolve ("srfi" "%3a132") "sortp.scm") (include/resolve ("srfi" "%3a132") "vector-util.scm") (include/resolve ("srfi" "%3a132") "vhsort.scm") (include/resolve ("srfi" "%3a132") "visort.scm") (include/resolve ("srfi" "%3a132") "vmsort.scm") (include/resolve ("srfi" "%3a132") "vqsort2.scm") (include/resolve ("srfi" "%3a132") "median.scm") (include/resolve ("srfi" "%3a132") "sort.scm") ; must be last ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/sortp.scm000066400000000000000000000024601375154206600213750ustar00rootroot00000000000000;;; The sort package -- sorted predicates ;;; Olin Shivers 10/98. ;;; ;;; (list-sorted? < lis) -> boolean ;;; (vector-sorted? < v [start end]) -> boolean (define (list-sorted? < list) (or (not (pair? list)) (let lp ((prev (car list)) (tail (cdr list))) (or (not (pair? tail)) (let ((next (car tail))) (and (not (< next prev)) (lp next (cdr tail)))))))) (define (vector-sorted? elt< v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (or (>= start end) ; Empty range (let lp ((i (+ start 1)) (vi-1 (vector-ref v start))) (or (>= i end) (let ((vi (vector-ref v i))) (and (not (elt< vi vi-1)) (lp (+ i 1) vi))))))))) ;;; Copyright and porting non-notices ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Give me a break. It's fifteen lines of code. I place this code in the ;;; public domain; help yourself. ;;; ;;; If your Scheme has a faster mechanism for handling optional arguments ;;; (e.g., Chez), you should definitely port over to it. Note that argument ;;; defaulting and error-checking are interleaved -- you don't have to ;;; error-check defaulted START/END args to see if they are fixnums that are ;;; legal vector indices for the corresponding vector, etc. chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/vbinsearch.scm000066400000000000000000000023361375154206600223540ustar00rootroot00000000000000;;; The sort package -- binary search -*- Scheme -*- ;;; Copyright (c) 1998 by Olin Shivers. ;;; This code is in the public domain. ;;; Olin Shivers 98/11 ;;; Returns the index of the matching element. ;;; (vector-binary-search < car 4 '#((1 . one) (3 . three) ;;; (4 . four) (25 . twenty-five))) ;;; => 2 (define (vector-binary-search key< elt->key key v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (let lp ((left start) (right end)) ; Search V[left,right). (and (< left right) (let* ((m (quotient (+ left right) 2)) (elt (vector-ref v m)) (elt-key (elt->key elt))) (cond ((key< key elt-key) (lp left m)) ((key< elt-key key) (lp (+ m 1) right)) (else m)))))))) (define (vector-binary-search3 compare v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (let lp ((left start) (right end)) ; Search V[left,right). (and (< left right) (let* ((m (quotient (+ left right) 2)) (sign (compare (vector-ref v m)))) (cond ((> sign 0) (lp left m)) ((< sign 0) (lp (+ m 1) right)) (else m)))))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/vector-util.scm000066400000000000000000000035301375154206600225020ustar00rootroot00000000000000;;; This code is ;;; Copyright (c) 1998 by Olin Shivers. ;;; The terms are: You may do as you please with this code, as long as ;;; you do not delete this notice or hold me responsible for any outcome ;;; related to its use. ;;; ;;; Blah blah blah. Don't you think source files should contain more lines ;;; of code than copyright notice? (define (vector-portion-copy vec start end) (let* ((len (vector-length vec)) (new-len (- end start)) (new (make-vector new-len))) (do ((i start (+ i 1)) (j 0 (+ j 1))) ((= i end) new) (vector-set! new j (vector-ref vec i))))) (define (vector-copy vec) (vector-portion-copy vec 0 (vector-length vec))) (define (vector-portion-copy! target src start end) (let ((len (- end start))) (do ((i (- len 1) (- i 1)) (j (- end 1) (- j 1))) ((< i 0)) (vector-set! target i (vector-ref src j))))) (define (has-element list index) (cond ((zero? index) (if (pair? list) (values #t (car list)) (values #f #f))) ((null? list) (values #f #f)) (else (has-element (cdr list) (- index 1))))) (define (list-ref-or-default list index default) (call-with-values (lambda () (has-element list index)) (lambda (has? maybe) (if has? maybe default)))) (define (vector-start+end vector maybe-start+end) (let ((start (list-ref-or-default maybe-start+end 0 0)) (end (list-ref-or-default maybe-start+end 1 (vector-length vector)))) (values start end))) (define (vectors-start+end-2 vector-1 vector-2 maybe-start+end) (let ((start-1 (list-ref-or-default maybe-start+end 0 0)) (end-1 (list-ref-or-default maybe-start+end 1 (vector-length vector-1))) (start-2 (list-ref-or-default maybe-start+end 2 0)) (end-2 (list-ref-or-default maybe-start+end 3 (vector-length vector-2)))) (values start-1 end-1 start-2 end-2))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/vhsort.scm000066400000000000000000000121151375154206600215510ustar00rootroot00000000000000;;; The sort package -- vector heap sort -*- Scheme -*- ;;; Copyright (c) 2002 by Olin Shivers. ;;; This code is open-source; see the end of the file for porting and ;;; more copyright information. ;;; Olin Shivers 10/98. ;;; Exports: ;;; (vector-heap-sort! elt< v [start end]) -> unspecified ;;; (vector-heap-sort elt< v [start end]) -> vector ;;; Two key facts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; If a heap structure is embedded into a vector at indices [start,end), then: ;;; 1. The two children of index k are start + 2*(k-start) + 1 = k*2-start+1 ;;; and start + 2*(k-start) + 2 = k*2-start+2. ;;; ;;; 2. The first index of a leaf node in the range [start,end) is ;;; first-leaf = floor[(start+end)/2] ;;; (You can deduce this from fact #1 above.) ;;; Any index before FIRST-LEAF is an internal node. (define (really-vector-heap-sort! elt< v start end) ;; Vector V contains a heap at indices [START,END). The heap is in heap ;; order in the range (I,END) -- i.e., every element in this range is >= ;; its children. Bubble HEAP[I] down into the heap to impose heap order on ;; the range [I,END). (define (restore-heap! end i) (let* ((vi (vector-ref v i)) (first-leaf (quotient (+ start end) 2)) ; Can fixnum overflow. (final-k (let lp ((k i)) (if (>= k first-leaf) k ; Leaf, so done. (let* ((k*2-start (+ k (- k start))) ; Don't overflow. (child1 (+ 1 k*2-start)) (child2 (+ 2 k*2-start)) (child1-val (vector-ref v child1))) (call-with-values (lambda () (if (< child2 end) (let ((child2-val (vector-ref v child2))) (if (elt< child2-val child1-val) (values child1 child1-val) (values child2 child2-val))) (values child1 child1-val))) (lambda (max-child max-child-val) (cond ((elt< vi max-child-val) (vector-set! v k max-child-val) (lp max-child)) (else k))))))))) ; Done. (vector-set! v final-k vi))) ;; Put the unsorted subvector V[start,end) into heap order. (let ((first-leaf (quotient (+ start end) 2))) ; Can fixnum overflow. (do ((i (- first-leaf 1) (- i 1))) ((< i start)) (restore-heap! end i))) (do ((i (- end 1) (- i 1))) ((<= i start)) (let ((top (vector-ref v start))) (vector-set! v start (vector-ref v i)) (vector-set! v i top) (restore-heap! i start)))) ;;; Here are the two exported interfaces. (define (vector-heap-sort! elt< v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (really-vector-heap-sort! elt< v start end)))) (define (vector-heap-sort elt< v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (let ((ans (vector-portion-copy v start end))) (really-vector-heap-sort! elt< ans 0 (- end start)) ans)))) ;;; Notes on porting ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Bumming the code for speed ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; If you can use a module system to lock up the internal function ;;; REALLY-VECTOR-HEAP-SORT! so that it can only be called from VECTOR-HEAP-SORT and ;;; VECTOR-HEAP-SORT!, then you can hack the internal functions to run with no safety ;;; checks. The safety checks performed by the exported functions VECTOR-HEAP-SORT & ;;; VECTOR-HEAP-SORT! guarantee that there will be no type errors or array-indexing ;;; errors. In addition, with the exception of the two computations of ;;; FIRST-LEAF, all arithmetic will be fixnum arithmetic that never overflows ;;; into bignums, assuming your Scheme provides that you can't allocate an ;;; array so large you might need a bignum to index an element, which is ;;; definitely the case for every implementation with which I am familiar. ;;; ;;; If you want to code up the first-leaf = (quotient (+ s e) 2) computation ;;; so that it will never fixnum overflow when S & E are fixnums, you can do ;;; it this way: ;;; - compute floor(e/2), which throws away e's low-order bit. ;;; - add e's low-order bit to s, and divide that by two: ;;; floor[(s + e mod 2) / 2] ;;; - add these two parts together. ;;; giving you ;;; (+ (quotient e 2) ;;; (quotient (+ s (modulo e 2)) 2)) ;;; If we know that e & s are fixnums, and that 0 <= s <= e, then this ;;; can only fixnum-overflow when s = e = max-fixnum. Note that the ;;; two divides and one modulo op can be done very quickly with two ;;; right-shifts and a bitwise and. ;;; ;;; I suspect there has never been a heapsort written in the history of ;;; the world in C that got this detail right. ;;; ;;; If your Scheme has a faster mechanism for handling optional arguments ;;; (e.g., Chez), you should definitely port over to it. Note that argument ;;; defaulting and error-checking are interleaved -- you don't have to ;;; error-check defaulted START/END args to see if they are fixnums that are ;;; legal vector indices for the corresponding vector, etc. chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/visort.scm000066400000000000000000000062761375154206600215650ustar00rootroot00000000000000;;; The sort package -- stable vector insertion sort -*- Scheme -*- ;;; Copyright (c) 1998 by Olin Shivers. ;;; This code is open-source; see the end of the file for porting and ;;; more copyright information. ;;; Olin Shivers 10/98. ;;; Exports: ;;; vector-insert-sort < v [start end] -> vector ;;; vector-insert-sort! < v [start end] -> unspecific ;;; ;;; %vector-insert-sort! is also called from vqsort.scm's quick-sort function. (define (vector-insert-sort elt< v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (let ((ans (vector-portion-copy v start end))) (%vector-insert-sort! elt< ans 0 (- end start)) ans)))) (define (vector-insert-sort! < v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (%vector-insert-sort! < v start end)))) (define (%vector-insert-sort! elt< v start end) (do ((i (+ 1 start) (+ i 1))) ; Invariant: [start,i) is sorted. ((>= i end)) (let ((val (vector-ref v i))) (vector-set! v (let lp ((j i)) ; J is the location of the (if (<= j start) start ; "hole" as it bubbles down. (let* ((j-1 (- j 1)) (vj-1 (vector-ref v j-1))) (cond ((elt< val vj-1) (vector-set! v j vj-1) (lp j-1)) (else j))))) val)))) ;;; Copyright ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code is ;;; Copyright (c) 1998 by Olin Shivers. ;;; The terms are: You may do as you please with this code, as long as ;;; you do not delete this notice or hold me responsible for any outcome ;;; related to its use. ;;; ;;; Blah blah blah. Don't you think source files should contain more lines ;;; of code than copyright notice? ;;; Code tuning & porting ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; This code is tightly bummed as far as I can go in portable Scheme. ;;; ;;; The code can be converted to use unsafe vector-indexing and ;;; fixnum-specific arithmetic ops -- the safety checks done on entry ;;; to VECTOR-INSERT-SORT and VECTOR-INSERT-SORT! are sufficient to ;;; guarantee nothing bad will happen. However, note that if you alter ;;; %VECTOR-INSERT-SORT! to use dangerous primitives, you must ensure ;;; it is only called from clients that guarantee to observe its ;;; preconditions. In the implementation, %VECTOR-INSERT-SORT! is only ;;; called from VECTOR-INSERT-SORT! and the quick-sort code in ;;; vqsort.scm, and the preconditions are guaranteed for these two ;;; clients. This should provide *big* speedups. In fact, all the ;;; code bumming I've done pretty much disappears in the noise unless ;;; you have a good compiler and also can dump the vector-index checks ;;; and generic arithmetic -- so I've really just set things up for ;;; you to exploit. ;;; ;;; If your Scheme has a faster mechanism for handling optional arguments ;;; (e.g., Chez), you should definitely port over to it. Note that argument ;;; defaulting and error-checking are interleaved -- you don't have to ;;; error-check defaulted START/END args to see if they are fixnums that are ;;; legal vector indices for the corresponding vector, etc. chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/vmsort.scm000066400000000000000000000223661375154206600215670ustar00rootroot00000000000000;;; The sort package -- stable vector merge & merge sort -*- Scheme -*- ;;; Copyright (c) 1998 by Olin Shivers. ;;; This code is open-source; see the end of the file for porting and ;;; more copyright information. ;;; Olin Shivers 10/98. ;;; Exports: ;;; (vector-merge < v1 v2 [start1 end1 start2 end2]) -> vector ;;; (vector-merge! < v v1 v2 [start0 start1 end1 start2 end2]) -> unspecific ;;; ;;; (vector-merge-sort < v [start end temp]) -> vector ;;; (vector-merge-sort! < v [start end temp]) -> unspecific ;;; Merge ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (vector-merge < v1 v2 [start1 end1 start2 end2]) -> vector ;;; (vector-merge! < v v1 v2 [start start1 end1 start2 end2]) -> unspecific ;;; ;;; Stable vector merge -- V1's elements come out ahead of equal V2 elements. (define (vector-merge < v1 v2 . maybe-starts+ends) (call-with-values (lambda () (vectors-start+end-2 v1 v2 maybe-starts+ends)) (lambda (start1 end1 start2 end2) (let ((ans (make-vector (+ (- end1 start1) (- end2 start2))))) (%vector-merge! < ans v1 v2 0 start1 end1 start2 end2) ans)))) (define (vector-merge! < v v1 v2 . maybe-starts+ends) (call-with-values (lambda () (if (pair? maybe-starts+ends) (values (car maybe-starts+ends) (cdr maybe-starts+ends)) (values 0 '()))) (lambda (start rest) (call-with-values (lambda () (vectors-start+end-2 v1 v2 rest)) (lambda (start1 end1 start2 end2) (%vector-merge! < v v1 v2 start start1 end1 start2 end2)))))) ;;; This routine is not exported. The code is tightly bummed. ;;; ;;; If these preconditions hold, the routine can be bummed to run with ;;; unsafe vector-indexing and fixnum arithmetic ops: ;;; - V V1 V2 are vectors. ;;; - START START1 END1 START2 END2 are fixnums. ;;; - (<= 0 START END0 (vector-length V), ;;; where end0 = start + (end1 - start1) + (end2 - start2) ;;; - (<= 0 START1 END1 (vector-length V1)) ;;; - (<= 0 START2 END2 (vector-length V2)) ;;; If you put these error checks in the two client procedures above, you can ;;; safely convert this procedure to use unsafe ops -- which is why it isn't ;;; exported. This will provide *huge* speedup. (define (%vector-merge! elt< v v1 v2 start start1 end1 start2 end2) (letrec ((vblit (lambda (fromv j i end) ; Blit FROMV[J,END) to V[I,?]. (let lp ((j j) (i i)) (vector-set! v i (vector-ref fromv j)) (let ((j (+ j 1))) (if (< j end) (lp j (+ i 1)))))))) (cond ((<= end1 start1) (if (< start2 end2) (vblit v2 start2 start end2))) ((<= end2 start2) (vblit v1 start1 start end1)) ;; Invariants: I is next index of V to write; X = V1[J]; Y = V2[K]. (else (let lp ((i start) (j start1) (x (vector-ref v1 start1)) (k start2) (y (vector-ref v2 start2))) (let ((i1 (+ i 1))) ; "i+1" is a complex number in R4RS! (if (elt< y x) (let ((k (+ k 1))) (vector-set! v i y) (if (< k end2) (lp i1 j x k (vector-ref v2 k)) (vblit v1 j i1 end1))) (let ((j (+ j 1))) (vector-set! v i x) (if (< j end1) (lp i1 j (vector-ref v1 j) k y) (vblit v2 k i1 end2)))))))))) ;;; (vector-merge-sort < v [start end temp]) -> vector ;;; (vector-merge-sort! < v [start end temp]) -> unspecific ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Stable natural vector merge sort (define (vector-merge-sort! < v . maybe-args) (call-with-values (lambda () (vector-start+end v maybe-args)) (lambda (start end) (let ((temp (if (and (pair? maybe-args) ; kludge (pair? (cdr maybe-args)) (pair? (cddr maybe-args))) (caddr maybe-args) (vector-copy v)))) (%vector-merge-sort! < v start end temp))))) (define (vector-merge-sort < v . maybe-args) (call-with-values (lambda () (vector-start+end v maybe-args)) (lambda (start end) (let ((ans (r7rs-vector-copy v start end))) (vector-merge-sort! < ans) ans)))) ;;; %VECTOR-MERGE-SORT! is not exported. ;;; Preconditions: ;;; V TEMP vectors ;;; START END fixnums ;;; START END legal indices for V and TEMP ;;; If these preconditions are ensured by the cover functions, you ;;; can safely change this code to use unsafe fixnum arithmetic and vector ;;; indexing ops, for *huge* speedup. ;;; This merge sort is "opportunistic" -- the leaves of the merge tree are ;;; contiguous runs of already sorted elements in the vector. In the best ;;; case -- an already sorted vector -- it runs in linear time. Worst case ;;; is still O(n lg n) time. (define (%vector-merge-sort! elt< v0 l r temp0) (define (xor a b) (not (eq? a b))) ;; Merge v1[l,l+len1) and v2[l+len1,l+len1+len2) into target[l,l+len1+len2) ;; Merge left-to-right, so that TEMP may be either V1 or V2 ;; (that this is OK takes a little bit of thought). ;; V2=TARGET? is true if V2 and TARGET are the same, which allows ;; merge to punt the final blit half of the time. (define (merge target v1 v2 l len1 len2 v2=target?) (letrec ((vblit (lambda (fromv j i end) ; Blit FROMV[J,END) to TARGET[I,?] (let lp ((j j) (i i)) ; J < END. The final copy. (vector-set! target i (vector-ref fromv j)) (let ((j (+ j 1))) (if (< j end) (lp j (+ i 1)))))))) (let* ((r1 (+ l len1)) (r2 (+ r1 len2))) ; Invariants: (let lp ((n l) ; N is next index of (j l) (x (vector-ref v1 l)) ; TARGET to write. (k r1) (y (vector-ref v2 r1))) ; X = V1[J] (let ((n+1 (+ n 1))) ; Y = V2[K] (if (elt< y x) (let ((k (+ k 1))) (vector-set! target n y) (if (< k r2) (lp n+1 j x k (vector-ref v2 k)) (vblit v1 j n+1 r1))) (let ((j (+ j 1))) (vector-set! target n x) (if (< j r1) (lp n+1 j (vector-ref v1 j) k y) (if (not v2=target?) (vblit v2 k n+1 r2)))))))))) ;; Might hack GETRUN so that if the run is short it pads it out to length ;; 10 with insert sort... ;; Precondition: l < r. (define (getrun v l r) (let lp ((i (+ l 1)) (x (vector-ref v l))) (if (>= i r) (- i l) (let ((y (vector-ref v i))) (if (elt< y x) (- i l) (lp (+ i 1) y)))))) ;; RECUR: Sort V0[L,L+LEN) for some LEN where 0 < WANT <= LEN <= (R-L). ;; That is, sort *at least* WANT elements in V0 starting at index L. ;; May put the result into either V0[L,L+LEN) or TEMP0[L,L+LEN). ;; Must not alter either vector outside this range. ;; Return: ;; - LEN -- the number of values we sorted ;; - ANSVEC -- the vector holding the value ;; - ANS=V0? -- tells if ANSVEC is V0 or TEMP ;; ;; LP: V[L,L+PFXLEN) holds a sorted prefix of V0. ;; TEMP = if V = V0 then TEMP0 else V0. (I.e., TEMP is the other vec.) ;; PFXLEN2 is a power of 2 <= PFXLEN. ;; Solve RECUR's problem. (if (< l r) ; Don't try to sort an empty range. (call-with-values (lambda () (let recur ((l l) (want (- r l))) (let ((len (- r l))) (let lp ((pfxlen (getrun v0 l r)) (pfxlen2 1) (v v0) (temp temp0) (v=v0? #t)) (if (or (>= pfxlen want) (= pfxlen len)) (values pfxlen v v=v0?) (let ((pfxlen2 (let lp ((j pfxlen2)) (let ((j*2 (+ j j))) (if (<= j pfxlen) (lp j*2) j)))) (tail-len (- len pfxlen))) ;; PFXLEN2 is now the largest power of 2 <= PFXLEN. ;; (Just think of it as being roughly PFXLEN.) (call-with-values (lambda () (recur (+ pfxlen l) pfxlen2)) (lambda (nr-len nr-vec nrvec=v0?) (merge temp v nr-vec l pfxlen nr-len (xor nrvec=v0? v=v0?)) (lp (+ pfxlen nr-len) (+ pfxlen2 pfxlen2) temp v (not v=v0?)))))))))) (lambda (ignored-len ignored-ansvec ansvec=v0?) (if (not ansvec=v0?) (r7rs-vector-copy! v0 l temp0 l r)))))) ;;; Copyright ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code is ;;; Copyright (c) 1998 by Olin Shivers. ;;; The terms are: You may do as you please with this code, as long as ;;; you do not delete this notice or hold me responsible for any outcome ;;; related to its use. ;;; ;;; Blah blah blah. Don't you think source files should contain more lines ;;; of code than copyright notice? ;;; Code tuning & porting ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code is *tightly* bummed as far as I can go in portable Scheme. ;;; ;;; The two internal primitives that do the real work can be converted to ;;; use unsafe vector-indexing and fixnum-specific arithmetic ops *if* you ;;; alter the four small cover functions to enforce the invariants. This should ;;; provide *big* speedups. In fact, all the code bumming I've done pretty ;;; much disappears in the noise unless you have a good compiler and also ;;; can dump the vector-index checks and generic arithmetic -- so I've really ;;; just set things up for you to exploit. ;;; ;;; The optional-arg parsing, defaulting, and error checking is done with a ;;; portable R4RS macro. But if your Scheme has a faster mechanism (e.g., ;;; Chez), you should definitely port over to it. Note that argument defaulting ;;; and error-checking are interleaved -- you don't have to error-check ;;; defaulted START/END args to see if they are fixnums that are legal vector ;;; indices for the corresponding vector, etc. chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/vqsort2.scm000066400000000000000000000175561375154206600216620ustar00rootroot00000000000000;;; The SRFI-32 sort package -- quick sort -*- Scheme -*- ;;; Copyright (c) 2002 by Olin Shivers. ;;; This code is open-source; see the end of the file for porting and ;;; more copyright information. ;;; Olin Shivers 2002/7. ;;; (quick-sort < v [start end]) -> vector ;;; (quick-sort! < v [start end]) -> unspecific ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The algorithm is a standard quicksort, but the partition loop is fancier, ;;; arranging the vector into a left part that is <, a middle region that is ;;; =, and a right part that is > the pivot. Here's how it is done: ;;; The partition loop divides the range being partitioned into five ;;; subranges: ;;; =======<<<<<<<<>>>>>>======= ;;; where = marks a value that is equal the pivot, < marks a value that ;;; is less than the pivot, ? marks a value that hasn't been scanned, and ;;; > marks a value that is greater than the pivot. Let's consider the ;;; left-to-right scan. If it checks a ? value that is <, it keeps scanning. ;;; If the ? value is >, we stop the scan -- we are ready to start the ;;; right-to-left scan and then do a swap. But if the rightward scan checks ;;; a ? value that is =, we swap it *down* to the end of the initial chunk ;;; of ====='s -- we exchange it with the leftmost < value -- and then ;;; continue our rightward scan. The leftwards scan works in a similar ;;; fashion, scanning past > elements, stopping on a < element, and swapping ;;; up = elements. When we are done, we have a picture like this ;;; ========<<<<<<<<<<<<>>>>>>>>>>========= ;;; Then swap the = elements up into the middle of the vector to get ;;; this: ;;; <<<<<<<<<<<<=================>>>>>>>>>> ;;; Then recurse on the <'s and >'s. Work out all the tricky little ;;; boundary cases, and you're done. ;;; ;;; Other tricks: ;;; - This quicksort also makes some effort to pick the pivot well -- it uses ;;; the median of three elements as the partition pivot, so pathological n^2 ;;; run time is much rarer (but not eliminated completely). If you really ;;; wanted to get fancy, you could use a random number generator to choose ;;; pivots. The key to this trick is that you only need to pick one random ;;; number for each *level* of recursion -- i.e. you only need (lg n) random ;;; numbers. ;;; - After the partition, we *recurse* on the smaller of the two pending ;;; regions, then *tail-recurse* (iterate) on the larger one. This guarantees ;;; we use no more than lg(n) stack frames, worst case. ;;; - There are two ways to finish off the sort. ;;; A Recurse down to regions of size 10, then sort each such region using ;;; insertion sort. ;;; B Recurse down to regions of size 10, then sort *the entire vector* ;;; using insertion sort. ;;; We do A. Each choice has a cost. Choice A has more overhead to invoke ;;; all the separate insertion sorts -- choice B only calls insertion sort ;;; once. But choice B will call the comparison function *more times* -- ;;; it will unnecessarily compare elt 9 of one segment to elt 0 of the ;;; following segment. The overhead of choice A is linear in the length ;;; of the vector, but *otherwise independent of the algorithm's parameters*. ;;; I.e., it's a *fixed*, *small* constant factor. The cost of the extra ;;; comparisons made by choice B, however, is dependent on an externality: ;;; the comparison function passed in by the client. This can be made ;;; arbitrarily bad -- that is, the constant factor *isn't* fixed by the ;;; sort algorithm; instead, it's determined by the comparison function. ;;; If your comparison function is very, very slow, you want to eliminate ;;; every single one that you can. Choice A limits the potential badness, ;;; so that is what we do. (define (vector-quick-sort! < v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (%quick-sort! < v start end)))) (define (vector-quick-sort < v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (let ((ans (make-vector (- end start)))) (vector-portion-copy! ans v start end) (%quick-sort! < ans 0 (- end start)) ans)))) ;;; %QUICK-SORT is not exported. ;;; Preconditions: ;;; V vector ;;; START END fixnums ;;; 0 <= START, END <= (vector-length V) ;;; If these preconditions are ensured by the cover functions, you ;;; can safely change this code to use unsafe fixnum arithmetic and vector ;;; indexing ops, for *huge* speedup. ;;; ;;; We bail out to insertion sort for small ranges; feel free to tune the ;;; crossover -- it's just a random guess. If you don't have the insertion ;;; sort routine, just kill that branch of the IF and change the recursion ;;; test to (< 1 (- r l)) -- the code is set up to work that way. (define (%quick-sort! elt< v start end) ;; Swap the N outer pairs of the range [l,r). (define (swap l r n) (if (> n 0) (let ((x (vector-ref v l)) (r-1 (- r 1))) (vector-set! v l (vector-ref v r-1)) (vector-set! v r-1 x) (swap (+ l 1) r-1 (- n 1))))) ;; Choose the median of V[l], V[r], and V[middle] for the pivot. (define (median v1 v2 v3) (call-with-values (lambda () (if (elt< v1 v2) (values v1 v2) (values v2 v1))) (lambda (little big) (if (elt< big v3) big (if (elt< little v3) v3 little))))) (let recur ((l start) (r end)) ; Sort the range [l,r). (if (< 10 (- r l)) ; Ten: the gospel according to Sedgewick. (let ((pivot (median (vector-ref v l) (vector-ref v (quotient (+ l r) 2)) (vector-ref v (- r 1))))) ;; Everything in these loops is driven by the invariants expressed ;; in the little pictures & the corresponding l,i,j,k,m,r indices ;; and the associated ranges. ;; =======<<<<<<<<>>>>>>======= ;; l i j k m r ;; [l,i) [i,j) [j,k] (k,m] (m,r) (letrec ((lscan (lambda (i j k m) ; left-to-right scan (let lp ((i i) (j j)) (if (> j k) (done i j m) (let ((x (vector-ref v j))) (cond ((elt< x pivot) (lp i (+ j 1))) ((elt< pivot x) (rscan i j k m)) (else ; Equal (if (< i j) (begin (vector-set! v j (vector-ref v i)) (vector-set! v i x))) (lp (+ i 1) (+ j 1))))))))) ;; =======<<<<<<<<<>????????>>>>>>>======= ;; l i j k m r ;; [l,i) [i,j) j (j,k] (k,m] (m,r) (rscan (lambda (i j k m) ; right-to-left scan (let lp ((k k) (m m)) (if (<= k j) (done i j m) (let* ((x (vector-ref v k))) (cond ((elt< pivot x) (lp (- k 1) m)) ((elt< x pivot) ; Swap j & k & lscan. (vector-set! v k (vector-ref v j)) (vector-set! v j x) (lscan i (+ j 1) (- k 1) m)) (else ; x=pivot (if (< k m) (begin (vector-set! v k (vector-ref v m)) (vector-set! v m x))) (lp (- k 1) (- m 1))))))))) ;; =======<<<<<<<<<<<<<>>>>>>>>>>>======= ;; l i j m r ;; [l,i) [i,j) [j,m] (m,r) (done (lambda (i j m) (let ((num< (- j i)) (num> (+ 1 (- m j))) (num=l (- i l)) (num=r (- (- r m) 1))) (swap l j (min num< num=l)) ; Swap ='s into (swap j r (min num> num=r)) ; the middle. ;; Recur on the <'s and >'s. Recurring on the ;; smaller range and iterating on the bigger ;; range ensures O(lg n) stack frames, worst case. (cond ((<= num< num>) (recur l (+ l num<)) (recur (- r num>) r)) (else (recur (- r num>) r) (recur l (+ l num<)))))))) (let ((r-1 (- r 1))) (lscan l l r-1 r-1)))) ;; Small segment => punt to insert sort. ;; Use the dangerous subprimitive. (%vector-insert-sort! elt< v l r)))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a132/vqsort3.scm000066400000000000000000000263231375154206600216530ustar00rootroot00000000000000;;; The SRFI-32 sort package -- three-way quick sort -*- Scheme -*- ;;; Copyright (c) 2002 by Olin Shivers. ;;; This code is open-source; see the end of the file for porting and ;;; more copyright information. ;;; Olin Shivers 2002/7. ;;; (quick-sort3! c v [start end]) -> unspecific ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Sort vector V[start,end) using three-way comparison function C: ;;; (c x y) < 0 => x x=y ;;; (c x y) > 0 => x>y ;;; That is, C acts as a sort of "subtraction" procedure; using - for the ;;; comparison function will cause numbers to be sorted into increasing order. ;;; ;;; This algorithm is more efficient than standard, two-way quicksort if there ;;; are many duplicate items in the data set and the comparison function is ;;; relatively expensive (e.g., comparing large strings). It is due to Jon ;;; Bentley & Doug McIlroy; I learned it from Bentley. ;;; ;;; The algorithm is a standard quicksort, but the partition loop is fancier, ;;; arranging the vector into a left part that is <, a middle region that is ;;; =, and a right part that is > the pivot. Here's how it is done: ;;; The partition loop divides the range being partitioned into five ;;; subranges: ;;; =======<<<<<<<<>>>>>>======= ;;; where = marks a value that is equal the pivot, < marks a value that ;;; is less than the pivot, ? marks a value that hasn't been scanned, and ;;; > marks a value that is greater than the pivot. Let's consider the ;;; left-to-right scan. If it checks a ? value that is <, it keeps scanning. ;;; If the ? value is >, we stop the scan -- we are ready to start the ;;; right-to-left scan and then do a swap. But if the rightward scan checks ;;; a ? value that is =, we swap it *down* to the end of the initial chunk ;;; of ====='s -- we exchange it with the leftmost < value -- and then ;;; continue our rightward scan. The leftwards scan works in a similar ;;; fashion, scanning past > elements, stopping on a < element, and swapping ;;; up = elements. When we are done, we have a picture like this ;;; ========<<<<<<<<<<<<>>>>>>>>>>========= ;;; Then swap the = elements up into the middle of the vector to get ;;; this: ;;; <<<<<<<<<<<<=================>>>>>>>>>> ;;; Then recurse on the <'s and >'s. Work out all the tricky little ;;; boundary cases, and you're done. ;;; ;;; Other tricks that make this implementation industrial strength: ;;; - This quicksort makes some effort to pick the pivot well -- it uses the ;;; median of three elements as the partition pivot, so pathological n^2 ;;; run time is much rarer (but not eliminated completely). If you really ;;; wanted to get fancy, you could use a random number generator to choose ;;; pivots. The key to this trick is that you only need to pick one random ;;; number for each *level* of recursion -- i.e. you only need (lg n) random ;;; numbers. ;;; ;;; - After the partition, we *recurse* on the smaller of the two pending ;;; regions, then *tail-recurse* (iterate) on the larger one. This guarantees ;;; we use no more than lg(n) stack frames, worst case. ;;; ;;; - There are two ways to finish off the sort. ;;; A. Recurse down to regions of size 10, then sort each such region using ;;; insertion sort. ;;; B. Recurse down to regions of size 10, then sort *the entire vector* ;;; using insertion sort. ;;; We do A. Each choice has a cost. Choice A has more overhead to invoke ;;; all the separate insertion sorts -- choice B only calls insertion sort ;;; once. But choice B will call the comparison function *more times* -- ;;; it will unnecessarily compare elt 9 of one segment to elt 0 of the ;;; following segment. The overhead of choice A is linear in the length ;;; of the vector, but *otherwise independent of the algorithm's parameters*. ;;; I.e., it's a *fixed*, *small* constant factor. The cost of the extra ;;; comparisons made by choice B, however, is dependent on an externality: ;;; the comparison function passed in by the client. This can be made ;;; arbitrarily bad -- that is, the constant factor *isn't* fixed by the ;;; sort algorithm; instead, it's determined by the comparison function. ;;; If your comparison function is very, very slow, you want to eliminate ;;; every single one that you can. Choice A limits the potential badness, ;;; so that is what we do. (define (vector-quick-sort3! c v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (%quick-sort3! c v start end)))) (define (vector-quick-sort3 c v . maybe-start+end) (call-with-values (lambda () (vector-start+end v maybe-start+end)) (lambda (start end) (let ((ans (make-vector (- end start)))) (vector-portion-copy! ans v start end) (%quick-sort3! c ans 0 (- end start)) ans)))) ;;; %QUICK-SORT3! is not exported. ;;; Preconditions: ;;; V vector ;;; START END fixnums ;;; 0 <= START, END <= (vector-length V) ;;; If these preconditions are ensured by the cover functions, you ;;; can safely change this code to use unsafe fixnum arithmetic and vector ;;; indexing ops, for *huge* speedup. ;;; ;;; We bail out to insertion sort for small ranges; feel free to tune the ;;; crossover -- it's just a random guess. If you don't have the insertion ;;; sort routine, just kill that branch of the IF and change the recursion ;;; test to (< 1 (- r l)) -- the code is set up to work that way. (define (%quick-sort3! c v start end) (define (swap l r n) ; Little utility -- swap the N (if (> n 0) (let ((x (vector-ref v l)) ; outer pairs of the range [l,r). (r-1 (- r 1))) (vector-set! v l (vector-ref v r-1)) (vector-set! v r-1 x) (swap (+ l 1) r-1 (- n 1))))) (define (sort3 v1 v2 v3) (call-with-values (lambda () (if (< (c v1 v2) 0) (values v1 v2) (values v2 v1))) (lambda (little big) (if (< (c big v3) 0) (values little big v3) (if (< (c little v3) 0) (values little v3 big) (values v3 little big)))))) (define (elt< v1 v2) (negative? (c v1 v2))) (let recur ((l start) (r end)) ; Sort the range [l,r). (if (< 10 (- r l)) ; 10: the gospel according to Sedgewick. ;; Choose the median of V[l], V[r-1], and V[middle] for the pivot. ;; We do this by sorting these three elts; call the results LO, PIVOT ;; & HI. Put LO, PIVOT & HI where they should go in the vector. We ;; will kick off the partition step with one elt (PIVOT) in the left= ;; range, one elt (LO) in the < range, one elt (HI) in in the > range ;; & no elts in the right= range. (let* ((r-1 (- r 1)) ; Three handy (mid (quotient (+ l r) 2)) ; common (l+1 (+ l 1)) ; subexpressions (pivot (call-with-values (lambda () (sort3 (vector-ref v l) (vector-ref v mid) (vector-ref v r-1))) (lambda (lo piv hi) (let ((tmp (vector-ref v l+1))) ; Put LO, PIV & HI (vector-set! v l piv) ; back into V (vector-set! v r-1 hi) ; where they belong, (vector-set! v l+1 lo) (vector-set! v mid tmp) piv))))) ; and return PIV as pivot. ;; Everything in these loops is driven by the invariants expressed ;; in the little pictures, the corresponding l,i,j,k,m,r indices, ;; & the associated ranges. ;; =======<<<<<<<<>>>>>>======= (picture) ;; l i j k m r (indices) ;; [l,i) [i,j) [j,k] (k,m] (m,r) (ranges ) (letrec ((lscan (lambda (i j k m) ; left-to-right scan (let lp ((i i) (j j)) (if (> j k) (done i j m) (let* ((x (vector-ref v j)) (sign (c x pivot))) (cond ((< sign 0) (lp i (+ j 1))) ((= sign 0) (if (< i j) (begin (vector-set! v j (vector-ref v i)) (vector-set! v i x))) (lp (+ i 1) (+ j 1))) ((> sign 0) (rscan i j k m)))))))) ;; =======<<<<<<<<<>????????>>>>>>>======= ;; l i j k m r ;; [l,i) [i,j) j (j,k] (k,m] (m,r) (rscan (lambda (i j k m) ; right-to-left scan (let lp ((k k) (m m)) (if (<= k j) (done i j m) (let* ((x (vector-ref v k)) (sign (c x pivot))) (cond ((> sign 0) (lp (- k 1) m)) ((= sign 0) (if (< k m) (begin (vector-set! v k (vector-ref v m)) (vector-set! v m x))) (lp (- k 1) (- m 1))) ((< sign 0) ; Swap j & k & lscan. (vector-set! v k (vector-ref v j)) (vector-set! v j x) (lscan i (+ j 1) (- k 1) m)))))))) ;; =======<<<<<<<<<<<<<>>>>>>>>>>>======= ;; l i j m r ;; [l,i) [i,j) [j,m] (m,r) (done (lambda (i j m) (let ((num< (- j i)) (num> (+ 1 (- m j))) (num=l (- i l)) (num=r (- (- r m) 1))) (swap l j (min num< num=l)) ; Swap ='s into (swap j r (min num> num=r)) ; the middle. ;; Recur on the <'s and >'s. Recurring on the ;; smaller range and iterating on the bigger ;; range ensures O(lg n) stack frames, worst case. (cond ((<= num< num>) (recur l (+ l num<)) (recur (- r num>) r)) (else (recur (- r num>) r) (recur l (+ l num<)))))))) ;; To repeat: We kick off the partition step with one elt (PIVOT) ;; in the left= range, one elt (LO) in the < range, one elt (HI) ;; in the > range & no elts in the right= range. (lscan l+1 (+ l 2) (- r 2) r-1))) ;; Small segment => punt to insert sort. ;; Use the dangerous subprimitive. (%vector-insert-sort! elt< v l r)))) ;;; Copyright ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code is ;;; Copyright (c) 1998 by Olin Shivers. ;;; The terms are: You may do as you please with this code, as long as ;;; you do not delete this notice or hold me responsible for any outcome ;;; related to its use. ;;; ;;; Blah blah blah. ;;; Code tuning & porting ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; - The quicksort recursion bottoms out in a call to an insertion sort ;;; routine, %INSERT-SORT!. But you could even punt this and go with pure ;;; recursion in a pinch. ;;; ;;; This code is *tightly* bummed as far as I can go in portable Scheme. ;;; ;;; The internal primitive %QUICK-SORT! that does the real work can be ;;; converted to use unsafe vector-indexing and fixnum-specific arithmetic ops ;;; *if* you alter the two small cover functions to enforce the invariants. ;;; This should provide *big* speedups. In fact, all the code bumming I've ;;; done pretty much disappears in the noise unless you have a good compiler ;;; and also can dump the vector-index checks and generic arithmetic -- so ;;; I've really just set things up for you to exploit. ;;; ;;; The optional-arg parsing, defaulting, and error checking is done with a ;;; portable R4RS macro. But if your Scheme has a faster mechanism (e.g., ;;; Chez), you should definitely port over to it. Note that argument defaulting ;;; and error-checking are interleaved -- you don't have to error-check ;;; defaulted START/END args to see if they are fixnums that are legal vector ;;; indices for the corresponding vector, etc. chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a133.sls000066400000000000000000000012261375154206600202450ustar00rootroot00000000000000(library (srfi :133) (export ;; Constructors vector-unfold vector-unfold-right vector-reverse-copy vector-concatenate vector-append-subvectors ;; Predicates vector-empty? vector= ;; Iteration vector-fold vector-fold-right vector-map! vector-count vector-cumulate ;; Searching vector-index vector-index-right vector-skip vector-skip-right vector-binary-search vector-any vector-every vector-partition ;; Mutators vector-swap! vector-reverse! vector-reverse-copy! vector-unfold! vector-unfold-right! ;; Conversion reverse-vector->list reverse-list->vector) (import (srfi :133 vectors))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a133/000077500000000000000000000000001375154206600175215ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a133/vectors-impl.scm000077500000000000000000001666411375154206600226720ustar00rootroot00000000000000;;;;;; SRFI 43: Vector library -*- Scheme -*- ;;; ;;; $Id$ ;;; ;;; Taylor Campbell wrote this code; he places it in the public domain. ;;; Will Clinger [wdc] made some corrections, also in the public domain. ;;; John Cowan modified this code for SRFI 133; his changes are also in ;;; the public domain. However, in jurisdictions where it is not possible ;;; to dedicate something to the public domain, the entire implementation ;;; is made available under the same license as SRFI 133. ;;; -------------------- ;;; Exported procedure index ;;; ;;; * Constructors ;;; vector-unfold vector-unfold-right ;;; vector-copy vector-reverse-copy ;;; vector-append vector-concatenate ;;; vector-append-subvectors ;;; ;;; * Predicates ;;; vector-empty? ;;; vector= ;;; ;;; * Iteration ;;; vector-fold vector-fold-right ;;; vector-map vector-map! ;;; vector-for-each ;;; vector-count vector-cumulate ;;; ;;; * Searching ;;; vector-index vector-skip ;;; vector-index-right vector-skip-right ;;; vector-binary-search ;;; vector-any vector-every ;;; vector-partition ;;; ;;; * Mutators ;;; vector-swap! ;;; vector-fill! ;;; vector-reverse! ;;; vector-copy! vector-reverse-copy! ;;; vector-reverse! ;;; vector-unfold! vector-unfold-right! ;;; ;;; * Conversion ;;; vector->list reverse-vector->list ;;; list->vector reverse-list->vector ;;; vector->string string->vector ;;; -------------------- ;;; Commentary on efficiency of the code ;;; This code is somewhat tuned for efficiency. There are several ;;; internal routines that can be optimized greatly to greatly improve ;;; the performance of much of the library. These internal procedures ;;; are already carefully tuned for performance, and lambda-lifted by ;;; hand. Some other routines are lambda-lifted by hand, but only the ;;; loops are lambda-lifted, and only if some routine has two possible ;;; loops -- a fast path and an n-ary case --, whereas _all_ of the ;;; internal routines' loops are lambda-lifted so as to never cons a ;;; closure in their body (VECTOR-PARSE-START+END doesn't have a loop), ;;; even in Scheme systems that perform no loop optimization (which is ;;; most of them, unfortunately). ;;; ;;; Fast paths are provided for common cases in most of the loops in ;;; this library. ;;; ;;; All calls to primitive vector operations are protected by a prior ;;; type check; they can be safely converted to use unsafe equivalents ;;; of the operations, if available. Ideally, the compiler should be ;;; able to determine this, but the state of Scheme compilers today is ;;; not a happy one. ;;; ;;; Efficiency of the actual algorithms is a rather mundane point to ;;; mention; vector operations are rarely beyond being straightforward. ;;; -------------------- ;;; Utilities ;;; SRFI 8, too trivial to put in the dependencies list. (define-syntax receive (syntax-rules () ((receive ?formals ?producer ?body1 ?body2 ...) (call-with-values (lambda () ?producer) (lambda ?formals ?body1 ?body2 ...))))) ;;; Not the best LET*-OPTIONALS, but not the worst, either. Use Olin's ;;; if it's available to you. (define-syntax let*-optionals (syntax-rules () ((let*-optionals (?x ...) ((?var ?default) ...) ?body1 ?body2 ...) (let ((args (?x ...))) (let*-optionals args ((?var ?default) ...) ?body1 ?body2 ...))) ((let*-optionals ?args ((?var ?default) ...) ?body1 ?body2 ...) (let*-optionals:aux ?args ?args ((?var ?default) ...) ?body1 ?body2 ...)))) (define-syntax let*-optionals:aux (syntax-rules () ((aux ?orig-args-var ?args-var () ?body1 ?body2 ...) (if (null? ?args-var) (let () ?body1 ?body2 ...) (error "too many arguments" (length ?orig-args-var) ?orig-args-var))) ((aux ?orig-args-var ?args-var ((?var ?default) ?more ...) ?body1 ?body2 ...) (if (null? ?args-var) (let* ((?var ?default) ?more ...) ?body1 ?body2 ...) (let ((?var (car ?args-var)) (new-args (cdr ?args-var))) (let*-optionals:aux ?orig-args-var new-args (?more ...) ?body1 ?body2 ...)))))) (define (nonneg-int? x) (and (integer? x) (not (negative? x)))) (define (between? x y z) (and (< x y) (<= y z))) (define (unspecified-value) (if #f #f)) ;++ This should be implemented more efficiently. It shouldn't cons a ;++ closure, and the cons cells used in the loops when using this could ;++ be reused. (define (vectors-ref vectors i) (map (lambda (v) (vector-ref v i)) vectors)) ;;; -------------------- ;;; Error checking ;;; Error signalling (not checking) is done in a way that tries to be ;;; as helpful to the person who gets the debugging prompt as possible. ;;; That said, error _checking_ tries to be as unredundant as possible. ;;; I don't use any sort of general condition mechanism; I use simply ;;; SRFI 23's ERROR, even in cases where it might be better to use such ;;; a general condition mechanism. Fix that when porting this to a ;;; Scheme implementation that has its own condition system. ;;; In argument checks, upon receiving an invalid argument, the checker ;;; procedure recursively calls itself, but in one of the arguments to ;;; itself is a call to ERROR; this mechanism is used in the hopes that ;;; the user may be thrown into a debugger prompt, proceed with another ;;; value, and let it be checked again. ;;; Type checking is pretty basic, but easily factored out and replaced ;;; with whatever your implementation's preferred type checking method ;;; is. I doubt there will be many other methods of index checking, ;;; though the index checkers might be better implemented natively. ;;; (CHECK-TYPE ) -> value ;;; Ensure that VALUE satisfies TYPE-PREDICATE?; if not, signal an ;;; error stating that VALUE did not satisfy TYPE-PREDICATE?, showing ;;; that this happened while calling CALLEE. Return VALUE if no ;;; error was signalled. (define (check-type pred? value callee) (if (pred? value) value ;; Recur: when (or if) the user gets a debugger prompt, he can ;; proceed where the call to ERROR was with the correct value. (check-type pred? (error "erroneous value" (list pred? value) `(while calling ,callee)) callee))) ;;; (CHECK-INDEX ) -> index ;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an ;;; error stating that it is not and that this happened in a call to ;;; CALLEE. Return INDEX when it is valid. (Note that this does NOT ;;; check that VECTOR is indeed a vector.) (define (check-index vec index callee) (let ((index (check-type integer? index callee))) (cond ((< index 0) (check-index vec (error "vector index too low" index `(into vector ,vec) `(while calling ,callee)) callee)) ((>= index (vector-length vec)) (check-index vec (error "vector index too high" index `(into vector ,vec) `(while calling ,callee)) callee)) (else index)))) ;;; (CHECK-INDICES ;;; ;;; ;;; ) -> [start end] ;;; Ensure that START and END are valid bounds of a range within ;;; VECTOR; if not, signal an error stating that they are not, with ;;; the message being informative about what the argument names were ;;; called -- by using START-NAME & END-NAME --, and that it occurred ;;; while calling CALLEE. Also ensure that VEC is in fact a vector. ;;; Returns no useful value. (define (check-indices vec start start-name end end-name callee) (let ((lose (lambda things (apply error "vector range out of bounds" (append things `(vector was ,vec) `(,start-name was ,start) `(,end-name was ,end) `(while calling ,callee))))) (start (check-type integer? start callee)) (end (check-type integer? end callee))) (cond ((> start end) ;; I'm not sure how well this will work. The intent is that ;; the programmer tells the debugger to proceed with both a ;; new START & a new END by returning multiple values ;; somewhere. (receive (new-start new-end) (lose `(,end-name < ,start-name)) (check-indices vec new-start start-name new-end end-name callee))) ((< start 0) (check-indices vec (lose `(,start-name < 0)) start-name end end-name callee)) ((>= start (vector-length vec)) (check-indices vec (lose `(,start-name > len) `(len was ,(vector-length vec))) start-name end end-name callee)) ((> end (vector-length vec)) (check-indices vec start start-name (lose `(,end-name > len) `(len was ,(vector-length vec))) end-name callee)) (else (values start end))))) ;;; -------------------- ;;; Internal routines ;;; These should all be integrated, native, or otherwise optimized -- ;;; they're used a _lot_ --. All of the loops and LETs inside loops ;;; are lambda-lifted by hand, just so as not to cons closures in the ;;; loops. (If your compiler can do better than that if they're not ;;; lambda-lifted, then lambda-drop (?) them.) ;;; (VECTOR-PARSE-START+END ;;; ;;; ) ;;; -> [start end] ;;; Return two values, composing a valid range within VECTOR, as ;;; extracted from ARGUMENTS or defaulted from VECTOR -- 0 for START ;;; and the length of VECTOR for END --; START-NAME and END-NAME are ;;; purely for error checking. (define (vector-parse-start+end vec args start-name end-name callee) (let ((len (vector-length vec))) (cond ((null? args) (values 0 len)) ((null? (cdr args)) (check-indices vec (car args) start-name len end-name callee)) ((null? (cddr args)) (check-indices vec (car args) start-name (cadr args) end-name callee)) (else (error "too many arguments" `(extra args were ,(cddr args)) `(while calling ,callee)))))) (define-syntax let-vector-start+end (syntax-rules () ((let-vector-start+end ?callee ?vec ?args (?start ?end) ?body1 ?body2 ...) (let ((?vec (check-type vector? ?vec ?callee))) (receive (?start ?end) (vector-parse-start+end ?vec ?args '?start '?end ?callee) ?body1 ?body2 ...))))) ;;; (%SMALLEST-LENGTH ) ;;; -> exact, nonnegative integer ;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is ;;; the length that is returned if VECTOR-LIST is empty. Common use ;;; of this is in n-ary vector routines: ;;; (define (f vec . vectors) ;;; (let ((vec (check-type vector? vec f))) ;;; ...(%smallest-length vectors (vector-length vec) f)...)) ;;; %SMALLEST-LENGTH takes care of the type checking -- which is what ;;; the CALLEE argument is for --; thus, the design is tuned for ;;; avoiding redundant type checks. (define %smallest-length (letrec ((loop (lambda (vector-list length callee) (if (null? vector-list) length (loop (cdr vector-list) (min (vector-length (check-type vector? (car vector-list) callee)) length) callee))))) loop)) ;;; (%VECTOR-COPY! ) ;;; Copy elements at locations SSTART to SEND from SOURCE to TARGET, ;;; starting at TSTART in TARGET. ;;; ;;; Optimize this! Probably with some combination of: ;;; - Force it to be integrated. ;;; - Let it use unsafe vector element dereferencing routines: bounds ;;; checking already happens outside of it. (Or use a compiler ;;; that figures this out, but Olin Shivers' PhD thesis seems to ;;; have been largely ignored in actual implementations...) ;;; - Implement it natively as a VM primitive: the VM can undoubtedly ;;; perform much faster than it can make Scheme perform, even with ;;; bounds checking. ;;; - Implement it in assembly: you _want_ the fine control that ;;; assembly can give you for this. ;;; I already lambda-lift it by hand, but you should be able to make it ;;; even better than that. (define %vector-copy! (letrec ((loop/l->r (lambda (target source send i j) (cond ((< i send) (vector-set! target j (vector-ref source i)) (loop/l->r target source send (+ i 1) (+ j 1)))))) (loop/r->l (lambda (target source sstart i j) (cond ((>= i sstart) (vector-set! target j (vector-ref source i)) (loop/r->l target source sstart (- i 1) (- j 1))))))) (lambda (target tstart source sstart send) (if (> sstart tstart) ; Make sure we don't copy over ; ourselves. (loop/l->r target source send sstart tstart) (loop/r->l target source sstart (- send 1) (+ -1 tstart send (- sstart))))))) ;;; (%VECTOR-REVERSE-COPY! ) ;;; Copy elements from SSTART to SEND from SOURCE to TARGET, in the ;;; reverse order. (define %vector-reverse-copy! (letrec ((loop (lambda (target source sstart i j) (cond ((>= i sstart) (vector-set! target j (vector-ref source i)) (loop target source sstart (- i 1) (+ j 1))))))) (lambda (target tstart source sstart send) (loop target source sstart (- send 1) tstart)))) ;;; (%VECTOR-REVERSE! ) (define %vector-reverse! (letrec ((loop (lambda (vec i j) (cond ((<= i j) (let ((v (vector-ref vec i))) (vector-set! vec i (vector-ref vec j)) (vector-set! vec j v) (loop vec (+ i 1) (- j 1)))))))) (lambda (vec start end) (loop vec start (- end 1))))) ;;; (%VECTOR-FOLD1 ) -> knil' ;;; (KONS ) -> knil' (define %vector-fold1 (letrec ((loop (lambda (kons knil len vec i) (if (= i len) knil (loop kons (kons knil (vector-ref vec i)) len vec (+ i 1)))))) (lambda (kons knil len vec) (loop kons knil len vec 0)))) ;;; (%VECTOR-FOLD2+ ...) -> knil' ;;; (KONS ...) -> knil' (define %vector-fold2+ (letrec ((loop (lambda (kons knil len vectors i) (if (= i len) knil (loop kons (apply kons knil (vectors-ref vectors i)) len vectors (+ i 1)))))) (lambda (kons knil len vectors) (loop kons knil len vectors 0)))) ;;; (%VECTOR-MAP! ) -> target ;;; (F ) -> elt' (define %vector-map1! (letrec ((loop (lambda (f target vec i) (if (zero? i) target (let ((j (- i 1))) (vector-set! target j (f (vector-ref vec j))) (loop f target vec j)))))) (lambda (f target vec len) (loop f target vec len)))) ;;; (%VECTOR-MAP2+! ) -> target ;;; (F ...) -> elt' (define %vector-map2+! (letrec ((loop (lambda (f target vectors i) (if (zero? i) target (let ((j (- i 1))) (vector-set! target j (apply f (vectors-ref vectors j))) (loop f target vectors j)))))) (lambda (f target vectors len) (loop f target vectors len)))) ;;;;;;;;;;;;;;;;;;;;;;;; ***** vector-lib ***** ;;;;;;;;;;;;;;;;;;;;;;; ;;; -------------------- ;;; Constructors ;;; (VECTOR-UNFOLD ...) -> vector ;;; (F ...) -> [elt seed' ...] ;;; The fundamental vector constructor. Creates a vector whose ;;; length is LENGTH and iterates across each index K between 0 and ;;; LENGTH, applying F at each iteration to the current index and the ;;; current seeds to receive N+1 values: first, the element to put in ;;; the Kth slot and then N new seeds for the next iteration. (define (vector-unfold f length . initial-seeds) (define vec (make-vector length)) (apply vector-unfold! f vec 0 length initial-seeds) vec) ;;; (VECTOR-UNFOLD! ...) -> vector ;;; (F ...) -> [elt seed' ...] ;;; Like VECTOR-UNFOLD, but unfolds onto an existing vector starting ;;; at up to but not including . (define vector-unfold! (letrec ((tabulate! ; Special zero-seed case. (lambda (f vec i len) (cond ((< i len) (vector-set! vec i (f i)) (tabulate! f vec (+ i 1) len))))) (unfold1! ; Fast path for one seed. (lambda (f vec i len seed) (if (< i len) (receive (elt new-seed) (f i seed) (vector-set! vec i elt) (unfold1! f vec (+ i 1) len new-seed))))) (unfold2+! ; Slower variant for N seeds. (lambda (f vec i len seeds) (if (< i len) (receive (elt . new-seeds) (apply f i seeds) (vector-set! vec i elt) (unfold2+! f vec (+ i 1) len new-seeds)))))) (lambda (f vec start end . initial-seeds) (let ((f (check-type procedure? f vector-unfold!)) (start (check-type nonneg-int? start vector-unfold!)) (end (check-type nonneg-int? end vector-unfold!))) (let () (cond ((null? initial-seeds) (tabulate! f vec start end)) ((null? (cdr initial-seeds)) (unfold1! f vec start end (car initial-seeds))) (else (unfold2+! f vec start end initial-seeds)))))))) ;;; (VECTOR-UNFOLD-RIGHT ...) -> vector ;;; (F ...) -> [seed' ...] ;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0 ;;; (still exclusive with LENGTH and inclusive with 0), not 0 to ;;; LENGTH as with VECTOR-UNFOLD. (define (vector-unfold-right f len . initial-seeds) (define vec (make-vector len)) (apply vector-unfold-right! f vec 0 len initial-seeds) vec) ;;; (VECTOR-UNFOLD-RIGHT! ...) -> vector ;;; Like VECTOR-UNFOLD-RIGHT, but unfolds onto an existing vector. (define (vector-unfold-right! f vec start end . initial-seeds) (letrec ((tabulate! (lambda (f vec i) (cond ((>= i start) (vector-set! vec i (f i)) (tabulate! f vec (- i 1)))))) (unfold1! (lambda (f vec i seed) (if (>= i start) (receive (elt new-seed) (f i seed) (vector-set! vec i elt) (unfold1! f vec (- i 1) new-seed))))) (unfold2+! (lambda (f vec i seeds) (if (>= i start) (receive (elt . new-seeds) (apply f i seeds) (vector-set! vec i elt) (unfold2+! f vec (- i 1) new-seeds)))))) (let ((f (check-type procedure? f vector-unfold-right!)) (start (check-type nonneg-int? start vector-unfold-right!)) (end (check-type nonneg-int? end vector-unfold-right!))) (let ((i (- end 1))) (cond ((null? initial-seeds) (tabulate! f vec i)) ((null? (cdr initial-seeds)) (unfold1! f vec i (car initial-seeds))) (else (unfold2+! f vec i initial-seeds))))))) ;;; (VECTOR-COPY [ ]) -> vector ;;; Create a newly allocated vector containing the elements from the ;;; range [START,END) in VECTOR. START defaults to 0; END defaults ;;; to the length of VECTOR. END may be greater than the length of ;;; VECTOR, in which case the vector is enlarged; if FILL is passed, ;;; the new locations from which there is no respective element in ;;; VECTOR are filled with FILL. (define (vector-copy vec . args) (let ((vec (check-type vector? vec vector-copy))) ;; We can't use LET-VECTOR-START+END, because we have one more ;; argument, and we want finer control, too. ;; ;; Olin's implementation of LET*-OPTIONALS would prove useful here: ;; the built-in argument-checks-as-you-go-along produces almost ;; _exactly_ the same code as VECTOR-COPY:PARSE-ARGS. (receive (start end fill) (vector-copy:parse-args vec args) (let ((new-vector (make-vector (- end start) fill))) (%vector-copy! new-vector 0 vec start (if (> end (vector-length vec)) (vector-length vec) end)) new-vector)))) ;;; Auxiliary for VECTOR-COPY. ;;; [wdc] Corrected to allow 0 <= start <= (vector-length vec). (define (vector-copy:parse-args vec args) (define (parse-args start end n fill) (let ((start (check-type nonneg-int? start vector-copy)) (end (check-type nonneg-int? end vector-copy))) (cond ((and (<= 0 start end) (<= start n)) (values start end fill)) (else (error "illegal arguments" `(while calling ,vector-copy) `(start was ,start) `(end was ,end) `(vector was ,vec)))))) (let ((n (vector-length vec))) (cond ((null? args) (parse-args 0 n n (unspecified-value))) ((null? (cdr args)) (parse-args (car args) n n (unspecified-value))) ((null? (cddr args)) (parse-args (car args) (cadr args) n (unspecified-value))) ((null? (cdddr args)) (parse-args (car args) (cadr args) n (caddr args))) (else (error "too many arguments" vector-copy (cdddr args)))))) ;;; (VECTOR-REVERSE-COPY [ ]) -> vector ;;; Create a newly allocated vector whose elements are the reversed ;;; sequence of elements between START and END in VECTOR. START's ;;; default is 0; END's default is the length of VECTOR. (define (vector-reverse-copy vec . maybe-start+end) (let-vector-start+end vector-reverse-copy vec maybe-start+end (start end) (let ((new (make-vector (- end start)))) (%vector-reverse-copy! new 0 vec start end) new))) ;;; (VECTOR-APPEND ...) -> vector ;;; Append VECTOR ... into a newly allocated vector and return that ;;; new vector. (define (vector-append . vectors) (vector-concatenate:aux vectors vector-append)) ;;; (VECTOR-CONCATENATE ) -> vector ;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to ;;; (apply vector-append VECTOR-LIST) ;;; but VECTOR-APPEND tends to be implemented in terms of ;;; VECTOR-CONCATENATE, and some Schemes bork when the list to apply ;;; a function to is too long. ;;; ;;; Actually, they're both implemented in terms of an internal routine. (define (vector-concatenate vector-list) (vector-concatenate:aux vector-list vector-concatenate)) ;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE (define vector-concatenate:aux (letrec ((compute-length (lambda (vectors len callee) (if (null? vectors) len (let ((vec (check-type vector? (car vectors) callee))) (compute-length (cdr vectors) (+ (vector-length vec) len) callee))))) (concatenate! (lambda (vectors target to) (if (null? vectors) target (let* ((vec1 (car vectors)) (len (vector-length vec1))) (%vector-copy! target to vec1 0 len) (concatenate! (cdr vectors) target (+ to len))))))) (lambda (vectors callee) (cond ((null? vectors) ;+++ (make-vector 0)) ((null? (cdr vectors)) ;+++ ;; Blech, we still have to allocate a new one. (let* ((vec (check-type vector? (car vectors) callee)) (len (vector-length vec)) (new (make-vector len))) (%vector-copy! new 0 vec 0 len) new)) (else (let ((new-vector (make-vector (compute-length vectors 0 callee)))) (concatenate! vectors new-vector 0) new-vector)))))) ;;; (VECTOR-APPEND-SUBVECTORS ...) -> vector ;;; Like VECTOR-APPEND but appends subvectors specified by ;;; argument triples. (define (vector-append-subvectors . args) ;; GATHER-ARGS returns three values: vectors, starts, ends (define (gather-args args) (let loop ((args args) (vecs '()) (starts '()) (ends '())) (if (null? args) (values (reverse vecs) (reverse starts) (reverse ends)) (loop (cdddr args) (cons (car args) vecs) (cons (cadr args) starts) (cons (caddr args) ends))))) ;; TOTAL-LENGTH computes the length of all subvectors (define (total-length starts ends) (let loop ((count 0) (starts starts) (ends ends)) (if (null? starts) count (let ((start (car starts)) (end (car ends))) (loop (+ count (- end start)) (cdr starts) (cdr ends)))))) ;; COPY-EACH! copies each subvector into a result vector (define (copy-each! result vecs starts ends) (let loop ((at 0) (vecs vecs) (starts starts) (ends ends)) (if (null? vecs) result (let ((vec (car vecs)) (start (car starts)) (end (car ends))) (%vector-copy! result at vec start end) (loop (+ at (- end start)) (cdr vecs) (cdr starts) (cdr ends)))))) ;; put them all together, they spell VECTOR-APPEND-SUBVECTORS (receive (vecs starts ends) (gather-args args) (define result (make-vector (total-length starts ends))) (copy-each! result vecs starts ends))) ;;; -------------------- ;;; Predicates ;;; (VECTOR-EMPTY? ) -> boolean ;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length ;;; is 0, and #F if not. (define (vector-empty? vec) (let ((vec (check-type vector? vec vector-empty?))) (zero? (vector-length vec)))) ;;; (VECTOR= ...) -> boolean ;;; (ELT=? ) -> boolean ;;; Determine vector equality generalized across element comparators. ;;; Vectors A and B are equal iff their lengths are the same and for ;;; each respective elements E_a and E_b (element=? E_a E_b) returns ;;; a true value. ELT=? is always applied to two arguments. Element ;;; comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b) ;;; results in a true value, then (ELEMENT=? E_a E_b) must result in a ;;; true value. This may be exploited to avoid multiple unnecessary ;;; element comparisons. (This implementation does, but does not deal ;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary ;;; comparisons, but I believe this optimization is probably fairly ;;; insignificant.) ;;; ;;; If the number of vector arguments is zero or one, then #T is ;;; automatically returned. If there are N vector arguments, ;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are ;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N ;;; are compared. The precise order in which ELT=? is applied is not ;;; specified. (define (vector= elt=? . vectors) (let ((elt=? (check-type procedure? elt=? vector=))) (cond ((null? vectors) #t) ((null? (cdr vectors)) (check-type vector? (car vectors) vector=) #t) (else (let loop ((vecs vectors)) (let ((vec1 (check-type vector? (car vecs) vector=)) (vec2+ (cdr vecs))) (or (null? vec2+) (and (binary-vector= elt=? vec1 (car vec2+)) (loop vec2+))))))))) (define (binary-vector= elt=? vector-a vector-b) (or (eq? vector-a vector-b) ;+++ (let ((length-a (vector-length vector-a)) (length-b (vector-length vector-b))) (letrec ((loop (lambda (i) (or (= i length-a) (and (< i length-b) (test (vector-ref vector-a i) (vector-ref vector-b i) i))))) (test (lambda (elt-a elt-b i) (and (or (eq? elt-a elt-b) ;+++ (elt=? elt-a elt-b)) (loop (+ i 1)))))) (and (= length-a length-b) (loop 0)))))) ;;; -------------------- ;;; Selectors ;;; -------------------- ;;; Iteration ;;; (VECTOR-FOLD ...) -> knil ;;; (KONS ...) -> knil' ; N vectors -> N+1 args ;;; The fundamental vector iterator. KONS is iterated over each ;;; index in all of the vectors in parallel, stopping at the end of ;;; the shortest; KONS is applied to an argument list of (list I ;;; STATE (vector-ref VEC I) ...), where STATE is the current state ;;; value -- the state value begins with KNIL and becomes whatever ;;; KONS returned at the respective iteration --, and I is the ;;; current index in the iteration. The iteration is strictly left- ;;; to-right. ;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N)) ;;; <=> ;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N) (define (vector-fold kons knil vec . vectors) (let ((kons (check-type procedure? kons vector-fold)) (vec (check-type vector? vec vector-fold))) (if (null? vectors) (%vector-fold1 kons knil (vector-length vec) vec) (%vector-fold2+ kons knil (%smallest-length vectors (vector-length vec) vector-fold) (cons vec vectors))))) ;;; (VECTOR-FOLD-RIGHT ...) -> knil ;;; (KONS ...) -> knil' ; N vectors => N+1 args ;;; The fundamental vector recursor. Iterates in parallel across ;;; VECTOR ... right to left, applying KONS to the elements and the ;;; current state value; the state value becomes what KONS returns ;;; at each next iteration. KNIL is the initial state value. ;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N)) ;;; <=> ;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1) ;;; ;;; Not implemented in terms of a more primitive operations that might ;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very ;;; useful elsewhere. (define vector-fold-right (letrec ((loop1 (lambda (kons knil vec i) (if (negative? i) knil (loop1 kons (kons knil (vector-ref vec i)) vec (- i 1))))) (loop2+ (lambda (kons knil vectors i) (if (negative? i) knil (loop2+ kons (apply kons knil (vectors-ref vectors i)) vectors (- i 1)))))) (lambda (kons knil vec . vectors) (let ((kons (check-type procedure? kons vector-fold-right)) (vec (check-type vector? vec vector-fold-right))) (if (null? vectors) (loop1 kons knil vec (- (vector-length vec) 1)) (loop2+ kons knil (cons vec vectors) (- (%smallest-length vectors (vector-length vec) vector-fold-right) 1))))))) ;;; (VECTOR-MAP ...) -> vector ;;; (F ...) -> value ; N vectors -> N args ;;; Constructs a new vector of the shortest length of the vector ;;; arguments. Each element at index I of the new vector is mapped ;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The ;;; dynamic order of application of F is unspecified. ;;; provided by (rnrs base) #;(define (vector-map f vec . vectors) (let ((f (check-type procedure? f vector-map)) (vec (check-type vector? vec vector-map))) (if (null? vectors) (let ((len (vector-length vec))) (%vector-map1! f (make-vector len) vec len)) (let ((len (%smallest-length vectors (vector-length vec) vector-map))) (%vector-map2+! f (make-vector len) (cons vec vectors) len))))) ;;; (VECTOR-MAP! ...) -> unspecified ;;; (F ...) -> element' ; N vectors -> N args ;;; Similar to VECTOR-MAP, but rather than mapping the new elements ;;; into a new vector, the new mapped elements are destructively ;;; inserted into the first vector. Again, the dynamic order of ;;; application of F is unspecified, so it is dangerous for F to ;;; manipulate the first VECTOR. (define (vector-map! f vec . vectors) (let ((f (check-type procedure? f vector-map!)) (vec (check-type vector? vec vector-map!))) (if (null? vectors) (%vector-map1! f vec vec (vector-length vec)) (%vector-map2+! f vec (cons vec vectors) (%smallest-length vectors (vector-length vec) vector-map!))) (unspecified-value))) ;;; (VECTOR-FOR-EACH ...) -> unspecified ;;; (F ...) ; N vectors -> N args ;;; Simple vector iterator: applies F to each index in the range [0, ;;; LENGTH), where LENGTH is the length of the smallest vector ;;; argument passed, and the respective element at that index. In ;;; contrast with VECTOR-MAP, F is reliably applied to each ;;; subsequent elements, starting at index 0 from left to right, in ;;; the vectors. ;;; provided by (rnrs base) #;(define vector-for-each (letrec ((for-each1 (lambda (f vec i len) (cond ((< i len) (f (vector-ref vec i)) (for-each1 f vec (+ i 1) len))))) (for-each2+ (lambda (f vecs i len) (cond ((< i len) (apply f (vectors-ref vecs i)) (for-each2+ f vecs (+ i 1) len)))))) (lambda (f vec . vectors) (let ((f (check-type procedure? f vector-for-each)) (vec (check-type vector? vec vector-for-each))) (if (null? vectors) (for-each1 f vec 0 (vector-length vec)) (for-each2+ f (cons vec vectors) 0 (%smallest-length vectors (vector-length vec) vector-for-each))))))) ;;; (VECTOR-COUNT ...) ;;; -> exact, nonnegative integer ;;; (PREDICATE? ...) ; N vectors -> N args ;;; PREDICATE? is applied element-wise to the elements of VECTOR ..., ;;; and a count is tallied of the number of elements for which a ;;; true value is produced by PREDICATE?. This count is returned. (define (vector-count pred? vec . vectors) (let ((pred? (check-type procedure? pred? vector-count)) (vec (check-type vector? vec vector-count))) (if (null? vectors) (%vector-fold1 (lambda (count elt) (if (pred? elt) (+ count 1) count)) 0 (vector-length vec) vec) (%vector-fold2+ (lambda (count . elts) (if (apply pred? elts) (+ count 1) count)) 0 (%smallest-length vectors (vector-length vec) vector-count) (cons vec vectors))))) ;;; (VECTOR-CUMULATE ) ;;; -> vector ;;; Returns a ly allocated vector with the same length as ;;; . Each element of is set to the result of invoking on ;;; [i-1] and [i], except that for the first call on , the first ;;; argument is . The vector is returned. (define (vector-cumulate f vec knil) (let* ((len (vector-length vec)) (result (make-vector len))) (let loop ((i 0) (left knil)) (if (= i len) result (let* ((right (vector-ref vec i)) (r (f left right))) (vector-set! result i r) (loop (+ i 1) r)))))) ;;; -------------------- ;;; Searching ;;; (VECTOR-INDEX ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args ;;; Search left-to-right across VECTOR ... in parallel, returning the ;;; index of the first set of values VALUE ... such that (PREDICATE? ;;; VALUE ...) returns a true value; if no such set of elements is ;;; reached, return #F. (define (vector-index pred? vec . vectors) (vector-index/skip pred? vec vectors vector-index)) ;;; (VECTOR-SKIP ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args ;;; (vector-index (lambda elts (not (apply PREDICATE? elts))) ;;; VECTOR ...) ;;; Like VECTOR-INDEX, but find the index of the first set of values ;;; that do _not_ satisfy PREDICATE?. (define (vector-skip pred? vec . vectors) (vector-index/skip (lambda elts (not (apply pred? elts))) vec vectors vector-skip)) ;;; Auxiliary for VECTOR-INDEX & VECTOR-SKIP (define vector-index/skip (letrec ((loop1 (lambda (pred? vec len i) (cond ((= i len) #f) ((pred? (vector-ref vec i)) i) (else (loop1 pred? vec len (+ i 1)))))) (loop2+ (lambda (pred? vectors len i) (cond ((= i len) #f) ((apply pred? (vectors-ref vectors i)) i) (else (loop2+ pred? vectors len (+ i 1))))))) (lambda (pred? vec vectors callee) (let ((pred? (check-type procedure? pred? callee)) (vec (check-type vector? vec callee))) (if (null? vectors) (loop1 pred? vec (vector-length vec) 0) (loop2+ pred? (cons vec vectors) (%smallest-length vectors (vector-length vec) callee) 0)))))) ;;; (VECTOR-INDEX-RIGHT ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args ;;; Right-to-left variant of VECTOR-INDEX. (define (vector-index-right pred? vec . vectors) (vector-index/skip-right pred? vec vectors vector-index-right)) ;;; (VECTOR-SKIP-RIGHT ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? ...) -> boolean ; N vectors -> N args ;;; Right-to-left variant of VECTOR-SKIP. (define (vector-skip-right pred? vec . vectors) (vector-index/skip-right (lambda elts (not (apply pred? elts))) vec vectors vector-index-right)) (define vector-index/skip-right (letrec ((loop1 (lambda (pred? vec i) (cond ((negative? i) #f) ((pred? (vector-ref vec i)) i) (else (loop1 pred? vec (- i 1)))))) (loop2+ (lambda (pred? vectors i) (cond ((negative? i) #f) ((apply pred? (vectors-ref vectors i)) i) (else (loop2+ pred? vectors (- i 1))))))) (lambda (pred? vec vectors callee) (let ((pred? (check-type procedure? pred? callee)) (vec (check-type vector? vec callee))) (if (null? vectors) (loop1 pred? vec (- (vector-length vec) 1)) (loop2+ pred? (cons vec vectors) (- (%smallest-length vectors (vector-length vec) callee) 1))))))) ;;; (VECTOR-BINARY-SEARCH [ ]) ;;; -> exact, nonnegative integer or #F ;;; (CMP ) -> integer ;;; positive -> VALUE1 > VALUE2 ;;; zero -> VALUE1 = VALUE2 ;;; negative -> VALUE1 < VALUE2 ;;; Perform a binary search through VECTOR for VALUE, comparing each ;;; element to VALUE with CMP. (define (vector-binary-search vec value cmp . maybe-start+end) (let ((cmp (check-type procedure? cmp vector-binary-search))) (let-vector-start+end vector-binary-search vec maybe-start+end (start end) (let loop ((start start) (end end) (j #f)) (let ((i (div (+ start end) 2))) (if (or (= start end) (and j (= i j))) #f (let ((comparison (check-type integer? (cmp (vector-ref vec i) value) `(,cmp for ,vector-binary-search)))) (cond ((zero? comparison) i) ((positive? comparison) (loop start i i)) (else (loop i end i)))))))))) ;;; (VECTOR-ANY ...) -> value ;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED? ;;; should ever return a true value, immediately stop and return that ;;; value; otherwise, when the shortest vector runs out, return #F. ;;; The iteration and order of application of PRED? across elements ;;; is of the vectors is strictly left-to-right. (define vector-any (letrec ((loop1 (lambda (pred? vec i len len-1) (and (not (= i len)) (if (= i len-1) (pred? (vector-ref vec i)) (or (pred? (vector-ref vec i)) (loop1 pred? vec (+ i 1) len len-1)))))) (loop2+ (lambda (pred? vectors i len len-1) (and (not (= i len)) (if (= i len-1) (apply pred? (vectors-ref vectors i)) (or (apply pred? (vectors-ref vectors i)) (loop2+ pred? vectors (+ i 1) len len-1))))))) (lambda (pred? vec . vectors) (let ((pred? (check-type procedure? pred? vector-any)) (vec (check-type vector? vec vector-any))) (if (null? vectors) (let ((len (vector-length vec))) (loop1 pred? vec 0 len (- len 1))) (let ((len (%smallest-length vectors (vector-length vec) vector-any))) (loop2+ pred? (cons vec vectors) 0 len (- len 1)))))))) ;;; (VECTOR-EVERY ...) -> value ;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED? ;;; should ever return #F, immediately stop and return #F; otherwise, ;;; if PRED? should return a true value for each element, stopping at ;;; the end of the shortest vector, return the last value that PRED? ;;; returned. In the case that there is an empty vector, return #T. ;;; The iteration and order of application of PRED? across elements ;;; is of the vectors is strictly left-to-right. (define vector-every (letrec ((loop1 (lambda (pred? vec i len len-1) (or (= i len) (if (= i len-1) (pred? (vector-ref vec i)) (and (pred? (vector-ref vec i)) (loop1 pred? vec (+ i 1) len len-1)))))) (loop2+ (lambda (pred? vectors i len len-1) (or (= i len) (if (= i len-1) (apply pred? (vectors-ref vectors i)) (and (apply pred? (vectors-ref vectors i)) (loop2+ pred? vectors (+ i 1) len len-1))))))) (lambda (pred? vec . vectors) (let ((pred? (check-type procedure? pred? vector-every)) (vec (check-type vector? vec vector-every))) (if (null? vectors) (let ((len (vector-length vec))) (loop1 pred? vec 0 len (- len 1))) (let ((len (%smallest-length vectors (vector-length vec) vector-every))) (loop2+ pred? (cons vec vectors) 0 len (- len 1)))))))) ;;; (VECTOR-PARTITION ) -> vector ;;; A vector the same size as is newly allocated and filled with ;;; all the elements of that satisfy in their original ;;; order followed by all the elements that do not satisfy , ;;; also in their original order. ;;; Two values are returned, the newly allocated vector and the index ;;; of the leftmost element that does not satisfy . (define (vector-partition pred? vec) (let* ((len (vector-length vec)) (cnt (vector-count pred? vec)) (result (make-vector len))) (let loop ((i 0) (yes 0) (no cnt)) (if (= i len) (values result cnt) (let ((elem (vector-ref vec i))) (if (pred? elem) (begin (vector-set! result yes elem) (loop (+ i 1) (+ yes 1) no)) (begin (vector-set! result no elem) (loop (+ i 1) yes (+ no 1))))))))) ;;; -------------------- ;;; Mutators ;;; (VECTOR-SWAP! ) -> unspecified ;;; Swap the values in the locations at INDEX1 and INDEX2. (define (vector-swap! vec i j) (let ((vec (check-type vector? vec vector-swap!))) (let ((i (check-index vec i vector-swap!)) (j (check-index vec j vector-swap!))) (let ((x (vector-ref vec i))) (vector-set! vec i (vector-ref vec j)) (vector-set! vec j x))))) ;;; helper for case-lambda-based versions (define $check-types (case-lambda [(who v start) (check-type vector? v who) (check-indices v start 'start (vector-length v) 'end who)] [(who v start end) (check-type vector? v who) (check-indices v start 'start end 'end who)])) ;;; (VECTOR-FILL! [ ]) -> unspecified ;;; [R5RS+] Fill the locations in VECTOR between START, whose default ;;; is 0, and END, whose default is the length of VECTOR, with VALUE. ;;; ;;; This one can probably be made really fast natively. (define vector-fill! (let () (define $vector-fill! (lambda (vec value start end) (do ((i start (+ i 1))) ((= i end)) (vector-set! vec i value)))) (case-lambda [(vec value) (rnrs:vector-fill! vec value)] [(vec value start) ($check-types 'vector-fill! vec start) ($vector-fill! vec value start (vector-length vec))] [(vec value start end) ($check-types 'vector-fill! vec start end) ($vector-fill! vec value start end)]))) ;;; (VECTOR-COPY! [ ]) ;;; -> unspecified ;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to ;;; to TARGET, starting at TSTART in TARGET. ;;; [wdc] Corrected to allow 0 <= sstart <= send <= (vector-length source). (define (vector-copy! target tstart source . maybe-sstart+send) (define (doit! sstart send source-length) (let ((tstart (check-type nonneg-int? tstart vector-copy!)) (sstart (check-type nonneg-int? sstart vector-copy!)) (send (check-type nonneg-int? send vector-copy!))) (cond ((and (<= 0 sstart send source-length) (<= (+ tstart (- send sstart)) (vector-length target))) (%vector-copy! target tstart source sstart send)) (else (error "illegal arguments" `(while calling ,vector-copy!) `(target was ,target) `(target-length was ,(vector-length target)) `(tstart was ,tstart) `(source was ,source) `(source-length was ,source-length) `(sstart was ,sstart) `(send was ,send)))))) (let ((n (vector-length source))) (cond ((null? maybe-sstart+send) (doit! 0 n n)) ((null? (cdr maybe-sstart+send)) (doit! (car maybe-sstart+send) n n)) ((null? (cddr maybe-sstart+send)) (doit! (car maybe-sstart+send) (cadr maybe-sstart+send) n)) (else (error "too many arguments" vector-copy! (cddr maybe-sstart+send)))))) ;;; (VECTOR-REVERSE-COPY! [ ]) ;;; [wdc] Corrected to allow 0 <= sstart <= send <= (vector-length source). (define (vector-reverse-copy! target tstart source . maybe-sstart+send) (define (doit! sstart send source-length) (let ((tstart (check-type nonneg-int? tstart vector-reverse-copy!)) (sstart (check-type nonneg-int? sstart vector-reverse-copy!)) (send (check-type nonneg-int? send vector-reverse-copy!))) (cond ((and (eq? target source) (or (between? sstart tstart send) (between? tstart sstart (+ tstart (- send sstart))))) (error "vector range for self-copying overlaps" vector-reverse-copy! `(vector was ,target) `(tstart was ,tstart) `(sstart was ,sstart) `(send was ,send))) ((and (<= 0 sstart send source-length) (<= (+ tstart (- send sstart)) (vector-length target))) (%vector-reverse-copy! target tstart source sstart send)) (else (error "illegal arguments" `(while calling ,vector-reverse-copy!) `(target was ,target) `(target-length was ,(vector-length target)) `(tstart was ,tstart) `(source was ,source) `(source-length was ,source-length) `(sstart was ,sstart) `(send was ,send)))))) (let ((n (vector-length source))) (cond ((null? maybe-sstart+send) (doit! 0 n n)) ((null? (cdr maybe-sstart+send)) (doit! (car maybe-sstart+send) n n)) ((null? (cddr maybe-sstart+send)) (doit! (car maybe-sstart+send) (cadr maybe-sstart+send) n)) (else (error "too many arguments" vector-reverse-copy! (cddr maybe-sstart+send)))))) ;;; (VECTOR-REVERSE! [ ]) -> unspecified ;;; Destructively reverse the contents of the sequence of locations ;;; in VECTOR between START, whose default is 0, and END, whose ;;; default is the length of VECTOR. (define (vector-reverse! vec . start+end) (let-vector-start+end vector-reverse! vec start+end (start end) (%vector-reverse! vec start end))) ;;; -------------------- ;;; Conversion ;;; (VECTOR->LIST [ ]) -> list ;;; [R5RS+] Produce a list containing the elements in the locations ;;; between START, whose default is 0, and END, whose default is the ;;; length of VECTOR, from VECTOR. (define vector->list (let () (define ($vector->list vec start end) (do ((i (- end 1) (- i 1)) (result '() (cons (vector-ref vec i) result))) ((< i start) result))) (case-lambda [(vec) (rnrs:vector->list vec)] [(vec start) ($check-types 'vector->list vec start) ($vector->list vec start (vector-length vec))] [(vec start end) ($check-types 'vector->list vec start end) ($vector->list vec start (vector-length vec))]))) ;;; (REVERSE-VECTOR->LIST [ ]) -> list ;;; Produce a list containing the elements in the locations between ;;; START, whose default is 0, and END, whose default is the length ;;; of VECTOR, from VECTOR, in reverse order. (define (reverse-vector->list vec . maybe-start+end) (let-vector-start+end reverse-vector->list vec maybe-start+end (start end) (do ((i start (+ i 1)) (result '() (cons (vector-ref vec i) result))) ((= i end) result)))) ;;; (LIST->VECTOR [ ]) -> vector ;;; [R5RS+] Produce a vector containing the elements in LIST, which ;;; must be a proper list, between START, whose default is 0, & END, ;;; whose default is the length of LIST. It is suggested that if the ;;; length of LIST is known in advance, the START and END arguments ;;; be passed, so that LIST->VECTOR need not call LENGTH to determine ;;; the length. ;;; ;;; This implementation diverges on circular lists, unless LENGTH fails ;;; and causes - to fail as well. Given a LENGTH* that computes the ;;; length of a list's cycle, this wouldn't diverge, and would work ;;; great for circular lists. (define list->vector (case-lambda [(lst) (rnrs:list->vector lst)] [(lst start) (check-type nonneg-int? start list->vector) (rnrs:list->vector (list-tail lst start))] [(lst start end) (check-type nonneg-int? start list->vector) (check-type nonneg-int? end list->vector) ;; NB: should be fxvector "start is greater than end" start end)) (let ([len (- end start)]) (let ([v (make-vector len)]) (let loop ([i 0] [ls (list-tail lst start)]) (unless (= i len) (unless (pair? ls) (if (null? ls) (error 'list->vector "list too short" lst start end) (error 'list->vector "improper list" lst))) (vector-set! v i (car ls)) (loop (fx+ i 1) (cdr ls)))) v))])) ;;; (REVERSE-LIST->VECTOR [ ]) -> vector ;;; Produce a vector containing the elements in LIST, which must be a ;;; proper list, between START, whose default is 0, and END, whose ;;; default is the length of LIST, in reverse order. It is suggested ;;; that if the length of LIST is known in advance, the START and END ;;; arguments be passed, so that REVERSE-LIST->VECTOR need not call ;;; LENGTH to determine the the length. ;;; ;;; This also diverges on circular lists unless, again, LENGTH returns ;;; something that makes - bork. (define (reverse-list->vector lst . maybe-start+end) (let*-optionals maybe-start+end ((start 0) (end (length lst))) ; Ugh -- LENGTH (let ((start (check-type nonneg-int? start reverse-list->vector)) (end (check-type nonneg-int? end reverse-list->vector))) ((lambda (f) (vector-unfold-right f (- end start) (list-tail lst start))) (lambda (index l) (cond ((null? l) (error "list too short" `(list was ,lst) `(attempted end was ,end) `(while calling ,reverse-list->vector))) ((pair? l) (values (car l) (cdr l))) (else (error "erroneous value" (list list? lst) `(while calling ,reverse-list->vector))))))))) ;;; (VECTOR->STRING [ ]) -> string ;;; Produce a string containing the elements in the locations ;;; between START, whose default is 0, and END, whose default is the ;;; length of VECTOR, from VECTOR. (define (vector->string vec . maybe-start+end) (let* ((len (vector-length vec)) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (end (if (null? maybe-start+end) len (if (null? (cdr maybe-start+end)) len (cadr maybe-start+end)))) (size (- end start))) (define result (make-string size)) (let loop ((at 0) (i start)) (if (= i end) result (begin (string-set! result at (vector-ref vec i)) (loop (+ at 1) (+ i 1))))))) ;;; (STRING->VECTOR [ ]) -> vector ;;; Produce a vector containing the elements in STRING ;;; between START, whose default is 0, & END, ;;; whose default is the length of STRING, from STRING. (define (string->vector str . maybe-start+end) (let* ((len (string-length str)) (start (if (null? maybe-start+end) 0 (car maybe-start+end))) (end (if (null? maybe-start+end) len (if (null? (cdr maybe-start+end)) len (cadr maybe-start+end)))) (size (- end start))) (define result (make-vector size)) (let loop ((at 0) (i start)) (if (= i end) result (begin (vector-set! result at (string-ref str i)) (loop (+ at 1) (+ i 1))))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a133/vectors.sls000066400000000000000000000021101375154206600217230ustar00rootroot00000000000000(library (srfi :133 vectors) (export ;;; * Constructors vector-unfold vector-unfold-right vector-copy vector-reverse-copy vector-append vector-concatenate vector-append-subvectors ;;; * Predicates vector-empty? vector= ;;; * Iteration vector-fold vector-fold-right vector-map vector-map! vector-for-each vector-count vector-cumulate ;;; * Searching vector-index vector-skip vector-index-right vector-skip-right vector-binary-search vector-any vector-every vector-partition ;;; * Mutators vector-swap! vector-fill! vector-reverse! vector-copy! vector-reverse-copy! vector-unfold! vector-unfold-right! ;;; * Conversion vector->list reverse-vector->list list->vector reverse-list->vector vector->string string->vector) (import (rename (rnrs) (vector-fill! rnrs:vector-fill!) (vector->list rnrs:vector->list) (list->vector rnrs:list->vector)) (rnrs mutable-strings) (srfi private include)) (include/resolve ("srfi" "%3a133") "vectors-impl.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a133/vectors.sls3a132.sls000066400000000000000000000000001375154206600231710ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14.sls000066400000000000000000000027031375154206600201640ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :14) (export ->char-set char-set char-set->list char-set->string char-set-adjoin char-set-adjoin! char-set-any char-set-complement char-set-complement! char-set-contains? char-set-copy char-set-count char-set-cursor char-set-cursor-next char-set-delete char-set-delete! char-set-diff+intersection char-set-diff+intersection! char-set-difference char-set-difference! char-set-every char-set-filter char-set-filter! char-set-fold char-set-for-each char-set-hash char-set-intersection char-set-intersection! char-set-map char-set-ref char-set-size char-set-unfold char-set-unfold! char-set-union char-set-union! char-set-xor char-set-xor! char-set:ascii char-set:blank char-set:digit char-set:empty char-set:full char-set:graphic char-set:hex-digit char-set:iso-control char-set:letter char-set:letter+digit char-set:lower-case char-set:printing char-set:punctuation char-set:symbol char-set:title-case char-set:upper-case char-set:whitespace char-set<= char-set= char-set? end-of-char-set? list->char-set list->char-set! string->char-set string->char-set! ucs-range->char-set ucs-range->char-set!) (import (srfi :14 char-sets)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/000077500000000000000000000000001375154206600174375ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/COPYING000066400000000000000000000040661375154206600205000ustar00rootroot00000000000000The *.scm files in the SRFI-14 implementation are from Scheme 48. This is an excerpt from Scheme 48's COPYING file. It is distributed under the following terms: Copyright 1986-2001 Richard Kelsey and Jonathan Rees. Copyright 2001-2007 Michael Sperber and Martin Gasbichler. Copyright 2007-2012 Michael Sperber and Marcus Crestani. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notices, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notices, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. The name of the authors may not be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Scheme 48 1.9 derives from Scheme 48 0.58, which was developed by Richard Kelsey and Jonathan Rees and incorporates PreScheme 0.5 by Richard Kelsey. This distribution includes code for processing Unicode text contributed by Basis Technology Corporation, otherwise distributed under the license above. chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/char-sets.sls000066400000000000000000000064541375154206600220640ustar00rootroot00000000000000;; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2018 Göran Weinholt ;; SPDX-License-Identifier: (MIT OR BSD-3-Clause OR LicenseRef-LICENSE) #!r6rs (library (srfi :14 char-sets) (export ; Predicates & comparison char-set? char-set= char-set<= char-set-hash ; Iterating over character sets char-set-cursor char-set-ref char-set-cursor-next end-of-char-set? char-set-fold char-set-unfold char-set-unfold! char-set-for-each char-set-map ; Creating character sets char-set-copy char-set list->char-set string->char-set list->char-set! string->char-set! char-set-filter ucs-range->char-set char-set-filter! ucs-range->char-set! (rename (x->char-set ->char-set)) ; Querying character sets char-set->list char-set->string char-set-size char-set-count char-set-contains? char-set-every char-set-any ; Character-set algebra char-set-adjoin char-set-delete char-set-adjoin! char-set-delete! char-set-complement char-set-union char-set-intersection char-set-complement! char-set-union! char-set-intersection! char-set-difference char-set-xor char-set-diff+intersection char-set-difference! char-set-xor! char-set-diff+intersection! ; Standard character sets char-set:lower-case char-set:upper-case char-set:title-case char-set:letter char-set:digit char-set:letter+digit char-set:graphic char-set:printing char-set:whitespace char-set:iso-control char-set:punctuation char-set:symbol char-set:hex-digit char-set:blank char-set:ascii char-set:empty char-set:full) (import (except (rnrs) define-record-type) (rnrs mutable-strings) (rnrs r5rs) (rename (only (srfi :1 lists) partition) (partition partition-list)) (srfi :9 records) (srfi private include) (srfi private let-opt) (srfi :14 char-sets inversion-list)) (define-syntax define-record-discloser (syntax-rules () ((_ type discloser) (define dummy #f)))) (define (make-immutable! obj) #f) (define char->scalar-value char->integer) (define scalar-value->char integer->char) (define make-byte-vector make-bytevector) (define byte-vector-ref bytevector-u8-ref) (define byte-vector-set! bytevector-u8-set!) (define byte-vector=? bytevector=?) (define copy-bytes! bytevector-copy!) (define byte-vector-length bytevector-length) (define (unspecific) (if #f #f)) (define-syntax opt-lambda (lambda (x) (define (split-args args) (syntax-case args () [(name . rest) (identifier? #'name) (let-values (((names opt-args) (split-args #'rest))) (values (cons #'name names) opt-args))] [(opt-args ...) (values '() #'(opt-args ...))])) (syntax-case x () [(_ (args ...) body ...) (let-values (((fixed-args opt-args) (split-args #'(args ...)))) (with-syntax (((fixed-args ...) fixed-args) ((opt-args ...) opt-args)) #'(lambda (fixed-args ... . rest) (let-optionals* rest (opt-args ...) body ...))))]))) (include/resolve ("srfi" "%3a14") "srfi-14.scm") (include/resolve ("srfi" "%3a14") "srfi-14-base-char-sets.scm") (include/resolve ("srfi" "%3a14") "srfi-14-char-sets.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/char-sets/000077500000000000000000000000001375154206600213305ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/char-sets/inversion-list-check.scm000066400000000000000000000123651375154206600261030ustar00rootroot00000000000000; Part of Scheme 48 1.9. See file COPYING for notices and license. ; Authors: Mike Sperber (define-test-suite inversion-lists-tests) (define-test-case creation/membership inversion-lists-tests (check-that (inversion-list-member? 5 (make-empty-inversion-list 0 1000)) (is-false)) (check (inversion-list-member? 5 (number->inversion-list 0 1000 5))) (check-that (inversion-list-member? 4 (number->inversion-list 0 1000 5)) (is-false)) (check-that (inversion-list-member? 6 (number->inversion-list 0 1000 5)) (is-false)) (check-that (inversion-list-member? 6 (range->inversion-list 0 1000 500 1000)) (is-false)) (check-that (inversion-list-member? 499 (range->inversion-list 0 1000 500 1000)) (is-false)) (check (inversion-list-member? 500 (range->inversion-list 0 1000 500 1000))) (check (inversion-list-member? 1000 (range->inversion-list 0 1000 500 1000)))) (define-test-case complement/1 inversion-lists-tests (check-that (inversion-list-complement (inversion-list-complement (range->inversion-list 0 1000 5 10))) (is inversion-list=? (range->inversion-list 0 1000 5 10)))) (define-test-case complement/2 inversion-lists-tests (check-that (inversion-list-complement (inversion-list-complement (range->inversion-list 0 1000 0 1000))) (is inversion-list=? (range->inversion-list 0 1000 0 1000)))) (define-test-case union/1 inversion-lists-tests (check-that (inversion-list-union (range->inversion-list 0 1000 5 10) (range->inversion-list 0 1000 20 30)) (is inversion-list=? (ranges->inversion-list 0 1000 '(5 . 10) '(20 . 30))))) (define-test-case union/2 inversion-lists-tests (check-that (inversion-list-union (range->inversion-list 0 1000 5 10) (range->inversion-list 0 1000 7 8)) (is inversion-list=? (range->inversion-list 0 1000 5 10)))) (define-test-case union/3 inversion-lists-tests (check-that (inversion-list-union (range->inversion-list 0 1000 5 10) (range->inversion-list 0 1000 7 15)) (is inversion-list=? (range->inversion-list 0 1000 5 15)))) (define-test-case union/4 inversion-lists-tests (check-that (inversion-list-union (range->inversion-list 0 1000 500 1000) (range->inversion-list 0 1000 0 500)) (is inversion-list=? (range->inversion-list 0 1000 0 1000)))) (define-test-case intersection/1 inversion-lists-tests (check-that (inversion-list-intersection (range->inversion-list 0 1000 5 10) (range->inversion-list 0 1000 20 30)) (is inversion-list=? (make-empty-inversion-list 0 1000)))) (define-test-case intersection/2 inversion-lists-tests (check-that (inversion-list-intersection (range->inversion-list 0 1000 5 10) (range->inversion-list 0 1000 7 8)) (is inversion-list=? (range->inversion-list 0 1000 7 8)))) (define-test-case intersection/3 inversion-lists-tests (check-that (inversion-list-intersection (range->inversion-list 0 1000 5 10) (range->inversion-list 0 1000 7 15)) (is inversion-list=? (range->inversion-list 0 1000 7 10)))) (define-test-case intersection/4 inversion-lists-tests (check-that (inversion-list-intersection (range->inversion-list 0 1000 500 1000) (range->inversion-list 0 1000 0 501)) (is inversion-list=? (range->inversion-list 0 1000 500 501)))) (define-test-case intersection/5 inversion-lists-tests (check-that (inversion-list-intersection (range->inversion-list 0 1000 500 1000) (range->inversion-list 0 1000 501 505)) (is inversion-list=? (range->inversion-list 0 1000 501 505)))) (define-test-case adjoin inversion-lists-tests (check-that (inversion-list-adjoin (range->inversion-list 0 1000 0 999) 999) (is inversion-list=? (range->inversion-list 0 1000 0 1000)))) (define-test-case remove inversion-lists-tests (check-that (inversion-list-remove (range->inversion-list 0 1000 0 1000) 999) (is inversion-list=? (range->inversion-list 0 1000 0 999)))) (define-test-case size inversion-lists-tests (check (inversion-list-size (ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000))) => 510)) (define-test-case copy inversion-lists-tests (check-that (inversion-list-copy (ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000))) (is inversion-list=? (ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000))))) (define-test-case fold/done? inversion-lists-tests (check (inversion-list-fold/done? (lambda (n sum) (+ n sum)) 0 (lambda (sum) (> sum 250000)) (ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000))) => 250781)) (define (i-list-sum i-list) (let loop ((cursor (inversion-list-cursor i-list)) (sum 0)) (if (inversion-list-cursor-at-end? cursor) sum (loop (inversion-list-cursor-next i-list cursor) (+ (inversion-list-cursor-ref cursor) sum))))) (define-test-case cursor inversion-lists-tests (check (i-list-sum (ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000))) => 374870)) (define-test-case hash inversion-lists-tests (check-that (inversion-list-hash (ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000)) 1031) (opposite (is = (inversion-list-hash (ranges->inversion-list 0 1000 '(5 . 10) '(500 . 1000)) 1031))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/char-sets/inversion-list-impl.scm000066400000000000000000000267671375154206600260020ustar00rootroot00000000000000; Part of Scheme 48 1.9. See file COPYING for notices and license. ; Authors: Mike Sperber ; Copyright (c) 2005-2006 by Basis Technology Corporation. ; Inversion lists are representations for sets of integers, ; represented as sorted sets of ranges. ; This was taken from Chapter 13 of Richard Gillam: Unicode Demystified. ; Mike doesn't know what the original source is. ; This was written as support code for the implementation of SRFI 14, ; which is why there's so many exports here nobody really needs. (define-record-type inversion-list :inversion-list (make-inversion-list min max range-vector) inversion-list? ;; minimum element, needed for complement & difference (min inversion-list-min) ;; maximum element, needed size ;; we pretty much assume consistency for union / intersection for MIN and MAX (max inversion-list-max) ;; consecutive elements are paired to form ranges of the form ;; [ (vector-ref v i) (vector-ref v (+ 1 i)) ) ;; (except the last one, possibly) (range-vector inversion-list-range-vector)) (define-record-discloser :inversion-list (lambda (r) (list 'inversion-list (inversion-list-min r) (inversion-list-max r) (inversion-list-range-vector r)))) (define (make-empty-inversion-list min max) (make-inversion-list min max '#())) (define (inversion-list-member? n i-list) (let ((ranges (inversion-list-range-vector i-list))) (let loop ((low 0) (high (vector-length ranges))) (if (< low high) (let ((mid (quotient (+ low high) 2))) (if (>= n (vector-ref ranges mid)) (loop (+ 1 mid) high) (loop low mid))) (odd? high))))) (define (inversion-list-complement i-list) (let* ((ranges (inversion-list-range-vector i-list)) (min (inversion-list-min i-list)) (max (inversion-list-max i-list)) (size (vector-length ranges))) (make-inversion-list min max (cond ((zero? size) (vector min)) ((not (= min (vector-ref ranges 0))) (if (and (even? size) (= max (vector-ref ranges (- size 1)))) (let ((result (make-vector size))) (vector-set! result 0 min) (vector-copy! ranges 0 result 1 (- size 1)) result) (let ((result (make-vector (+ 1 size)))) (vector-set! result 0 min) (vector-copy! ranges 0 result 1 size) result))) ((and (even? size) (= max (vector-ref ranges (- size 1)))) (let ((result (make-vector (- size 2)))) (vector-copy! ranges 1 result 0 (- size 2)) result)) (else (let ((result (make-vector (- size 1)))) (vector-copy! ranges 1 result 0 (- size 1)) result)))))) (define (make-inversion-list-union/intersection proc-thunk ; for CALL-ERROR write-increment-count write-decrement-count process-first? decrement-count? middle-increment copy-extra-count) (lambda (i-list-1 i-list-2) (if (or (not (= (inversion-list-min i-list-1) (inversion-list-min i-list-2))) (not (= (inversion-list-max i-list-1) (inversion-list-max i-list-2)))) (assertion-violation 'make-inversion-list-union/intersection "min/max mismatch" (proc-thunk) i-list-1 i-list-2)) (let ((ranges-1 (inversion-list-range-vector i-list-1)) (ranges-2 (inversion-list-range-vector i-list-2)) (min (inversion-list-min i-list-1)) (max (inversion-list-max i-list-1))) (let ((size-1 (vector-length ranges-1)) (size-2 (vector-length ranges-2))) (let ((temp (make-vector (+ size-1 size-2)))) (let loop ((index-1 0) (index-2 0) (count 0) (index-result 0)) (if (and (< index-1 size-1) (< index-2 size-2)) (let ((el-1 (vector-ref ranges-1 index-1)) (el-2 (vector-ref ranges-2 index-2))) (call-with-values (lambda () (if (or (< el-1 el-2) (and (= el-1 el-2) (process-first? index-1))) (values index-1 el-1 (+ 1 index-1) index-2) (values index-2 el-2 index-1 (+ 1 index-2)))) (lambda (index el index-1 index-2) (if (even? index) (if (= write-increment-count count) (begin (vector-set! temp index-result el) (loop index-1 index-2 (+ 1 count) (+ 1 index-result))) (loop index-1 index-2 (+ 1 count) index-result)) (if (= write-decrement-count count) (begin (vector-set! temp index-result el) (loop index-1 index-2 (- count 1) (+ 1 index-result))) (loop index-1 index-2 (- count 1) index-result)))))) (let* ((count (if (or (and (not (= index-1 size-1)) (decrement-count? index-1)) (and (not (= index-2 size-2)) (decrement-count? index-2))) (+ count middle-increment) count)) (result-size (if (= copy-extra-count count) (+ index-result (- size-1 index-1) (- size-2 index-2)) index-result)) (result (make-vector result-size))) (vector-copy! temp 0 result 0 index-result) (if (= copy-extra-count count) (begin (vector-copy! ranges-1 index-1 result index-result (- size-1 index-1)) (vector-copy! ranges-2 index-2 result index-result (- size-2 index-2)))) (make-inversion-list min max result))))))))) ; for associative procedures only (define (binary->n-ary proc/2) (lambda (arg-1 . args) (if (and (pair? args) (null? (cdr args))) (proc/2 arg-1 (car args)) (let loop ((args args) (result arg-1)) (if (null? args) result (loop (cdr args) (proc/2 result (car args)))))))) (define inversion-list-union (binary->n-ary (make-inversion-list-union/intersection (lambda () inversion-list-union) 0 1 even? odd? -1 0))) (define inversion-list-intersection (binary->n-ary (make-inversion-list-union/intersection (lambda () inversion-list-intersection) 1 2 odd? even? +1 2))) (define inversion-list-difference (binary->n-ary (lambda (i-list-1 i-list-2) (inversion-list-intersection i-list-1 (inversion-list-complement i-list-2))))) (define (number->inversion-list min max n) (if (or (< n min) (>= n max)) (assertion-violation 'number->inversion-list "invalid number" min max n)) (make-inversion-list min max (if (= n (- max 1)) (vector n) (vector n (+ n 1))))) (define (numbers->inversion-list min max . numbers) (cond ((null? numbers) (make-empty-inversion-list min max)) ((null? (cdr numbers)) (number->inversion-list min max (car numbers))) (else (let loop ((numbers (cdr numbers)) (i-list (number->inversion-list min max (car numbers)))) (if (null? numbers) i-list (loop (cdr numbers) (inversion-list-union i-list (number->inversion-list min max (car numbers))))))))) (define (range->inversion-list min max left right) (if (or (> min max) (> left right) (< left min) (> right max)) (assertion-violation 'range->inversion-list "invalid range" min max left right)) (make-inversion-list min max (if (= right max) (vector left) (vector left right)))) (define (ranges->inversion-list min max . ranges) (let loop ((ranges ranges) (result (make-empty-inversion-list min max))) (if (null? ranges) result (let ((range-pair (car ranges))) (let ((left (car range-pair)) (right (cdr range-pair))) (if (not (and (number? left) (number? right))) (assertion-violation 'ranges->inversion-list "invalid range" min max (cons left right))) (loop (cdr ranges) (inversion-list-union result (range->inversion-list min max left right)))))))) (define (inversion-list-adjoin i-list . numbers) (inversion-list-union i-list (apply numbers->inversion-list (inversion-list-min i-list) (inversion-list-max i-list) numbers))) (define (inversion-list-remove i-list . numbers) (inversion-list-difference i-list (apply numbers->inversion-list (inversion-list-min i-list) (inversion-list-max i-list) numbers))) (define (inversion-list-size i-list) (let* ((ranges (inversion-list-range-vector i-list)) (size (vector-length ranges))) (let loop ((index 0) (count 0)) (cond ((>= index size) count) ((= (+ 1 index) size) (+ count (- (inversion-list-max i-list) (vector-ref ranges index)))) (else (loop (+ 2 index) (+ count (- (vector-ref ranges (+ 1 index)) (vector-ref ranges index))))))))) (define (inversion-list=? i-list-1 i-list-2) (and (= (inversion-list-min i-list-1) (inversion-list-min i-list-2)) (= (inversion-list-max i-list-1) (inversion-list-max i-list-2)) (equal? (inversion-list-range-vector i-list-1) (inversion-list-range-vector i-list-2)))) (define (inversion-list-copy i-list) (make-inversion-list (inversion-list-min i-list) (inversion-list-max i-list) (vector-copy (inversion-list-range-vector i-list)))) ; Iterate over the elements until DONE? (applied to the accumulator) ; returns #t (define (inversion-list-fold/done? kons knil done? i-list) (let* ((ranges (inversion-list-range-vector i-list)) (size (vector-length ranges))) (let loop ((v knil) (i 0)) (if (>= i size) v (let ((left (vector-ref ranges i)) (right (if (< i (- size 1)) (vector-ref ranges (+ 1 i)) (inversion-list-max i-list)))) (let inner-loop ((v v) (n left)) (if (>= n right) (loop v (+ 2 i)) (let ((v (kons n v))) (if (done? v) v (inner-loop v (+ 1 n))))))))))) ; It never ends with Olin (define-record-type inversion-list-cursor :inversion-list-cursor (make-inversion-list-cursor index number) inversion-list-cursor? ;; index into the range vector (always even), #f if we're at the end (index inversion-list-cursor-index) ;; number within that index (number inversion-list-cursor-number)) (define (inversion-list-cursor i-list) (let ((ranges (inversion-list-range-vector i-list))) (if (zero? (vector-length ranges)) (make-inversion-list-cursor #f #f) (make-inversion-list-cursor 0 (vector-ref ranges 0))))) (define (inversion-list-cursor-at-end? cursor) (not (inversion-list-cursor-index cursor))) (define (inversion-list-cursor-next i-list cursor) (let ((index (inversion-list-cursor-index cursor)) (number (inversion-list-cursor-number cursor))) (let* ((ranges (inversion-list-range-vector i-list)) (size (vector-length ranges)) (right (if (>= (+ index 1) size) (inversion-list-max i-list) (vector-ref ranges (+ index 1))))) (cond ((< number (- right 1)) (make-inversion-list-cursor index (+ 1 number))) ((< (+ index 2) size) (make-inversion-list-cursor (+ index 2) (vector-ref ranges (+ index 2)))) (else (make-inversion-list-cursor #f #f)))))) (define (inversion-list-cursor-ref cursor) (inversion-list-cursor-number cursor)) ; Uses the same method as Olin's reference implementation for SRFI 14. (define (inversion-list-hash i-list bound) (let ((mask (let loop ((i #x10000)) ; skip first 16 iterations (if (>= i bound) (- i 1) (loop (+ i i)))))) (let* ((range-vector (inversion-list-range-vector i-list)) (size (vector-length range-vector))) (let loop ((i 0) (ans 0)) (if (>= i size) (modulo ans bound) (loop (+ 1 i) (bitwise-and mask (+ (* 37 ans) (vector-ref range-vector i))))))))) ;; Utilities (define (vector-copy! source source-start dest dest-start count) (let loop ((i 0)) (if (< i count) (begin (vector-set! dest (+ dest-start i) (vector-ref source (+ source-start i))) (loop (+ 1 i)))))) (define (vector-copy v) (let* ((size (vector-length v)) (copy (make-vector size))) (vector-copy! v 0 copy 0 size) copy)) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/char-sets/inversion-list.sls000066400000000000000000000027131375154206600250430ustar00rootroot00000000000000;; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2018 Göran Weinholt ;; SPDX-License-Identifier: (MIT OR BSD-3-Clause OR LicenseRef-LICENSE) #!r6rs (library (srfi :14 char-sets inversion-list) (export inversion-list? make-empty-inversion-list number->inversion-list numbers->inversion-list range->inversion-list ranges->inversion-list inversion-list=? inversion-list-adjoin inversion-list-complement inversion-list-copy inversion-list-difference inversion-list-fold/done? inversion-list-hash inversion-list-intersection inversion-list-member? inversion-list-remove inversion-list-size inversion-list-union inversion-list-cursor inversion-list-cursor? inversion-list-cursor-ref inversion-list-cursor-next inversion-list-cursor-at-end?) (import (except (rnrs) define-record-type) (rnrs r5rs) (srfi :9 records) (srfi private include)) (define-syntax define-record-discloser (syntax-rules () ((_ type discloser) (define dummy #f)))) (let-syntax ((define-record-type (lambda (x) (syntax-case x () ((_ tag typename (constructor field-init* ...) etc ...) #'(define-record-type typename (constructor field-init* ...) etc ...)))))) (include/resolve ("srfi" "%3a14" "char-sets") "inversion-list-impl.scm"))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/srfi-14-base-char-sets.scm000066400000000000000000000406721375154206600241400ustar00rootroot00000000000000; Automatically generated by WRITE-SRFI-14-BASE-CHAR-SETS; do not edit. (define char-set:lower-case (range-vector->char-set '#(97 123 181 182 223 247 248 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 378 379 380 381 382 385 387 388 389 390 392 393 396 398 402 403 405 406 409 412 414 415 417 418 419 420 421 422 424 425 427 428 429 430 432 433 436 437 438 439 441 443 445 446 447 448 454 455 457 458 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 497 499 500 501 502 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 570 572 573 575 577 578 579 583 584 585 586 587 588 589 590 591 610 611 618 619 628 629 630 631 641 642 655 656 660 666 667 669 671 672 673 675 684 686 688 837 838 867 880 891 894 912 913 940 975 976 978 981 983 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1011 1013 1014 1016 1017 1019 1020 1072 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1377 1416 6448 6457 7426 7427 7432 7434 7441 7445 7446 7448 7453 7456 7522 7544 7545 7547 7548 7550 7551 7579 7626 7627 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7836 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7930 7936 7944 7952 7958 7968 7976 7984 7992 8000 8006 8016 8024 8032 8040 8048 8062 8064 8072 8080 8088 8096 8104 8112 8117 8118 8120 8126 8127 8130 8133 8134 8136 8144 8148 8150 8152 8160 8168 8178 8181 8182 8184 64256 64263 64275 64280 65345 65371 66600 66640 917601 917627))) (define char-set:upper-case (range-vector->char-set '#(65 91 192 215 216 223 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 378 379 380 381 382 385 387 388 389 390 392 393 396 398 402 403 405 406 409 412 414 415 417 418 419 420 421 422 424 425 426 428 429 430 432 433 436 437 438 439 441 444 445 452 453 455 456 458 459 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 497 498 500 501 502 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 570 572 573 575 577 578 579 583 584 585 586 587 588 589 590 591 902 903 904 907 908 909 910 912 913 930 931 940 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1012 1013 1015 1016 1017 1019 1021 1072 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1329 1367 4256 4294 7547 7548 7550 7551 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 7819 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7840 7841 7842 7843 7844 7845 7846 7847 7848 7849 7850 7851 7852 7853 7854 7855 7856 7857 7858 7859 7860 7861 7862 7863 7864 7865 7866 7867 7868 7869 7870 7871 7872 7873 7874 7875 7876 7877 7878 7879 7880 7881 7882 7883 7884 7885 7886 7887 7888 7889 7890 7891 7892 7893 7894 7895 7896 7897 7898 7899 7900 7901 7902 7903 7904 7905 7906 7907 7908 7909 7910 7911 7912 7913 7914 7915 7916 7917 7918 7919 7920 7921 7922 7923 7924 7925 7926 7927 7928 7929 7944 7952 7960 7966 7976 7984 7992 8000 8008 8014 8025 8026 8027 8028 8029 8030 8031 8032 8040 8048 8072 8080 8088 8096 8104 8112 8120 8125 8136 8141 8152 8156 8168 8173 8184 8189 65313 65339 66560 66600 917569 917595))) (define char-set:title-case (range-vector->char-set '#(453 454 456 457 459 460 498 499 8072 8080 8088 8096 8104 8112 8124 8125 8140 8141 8188 8189))) (define char-set:letter (range-vector->char-set '#(65 91 97 123 170 171 181 182 186 187 192 215 216 247 248 706 710 722 736 741 750 751 890 894 902 903 904 907 908 909 910 930 931 975 976 1014 1015 1154 1162 1300 1329 1367 1369 1370 1377 1416 1488 1515 1520 1523 1569 1595 1600 1611 1646 1648 1649 1748 1749 1750 1765 1767 1774 1776 1786 1789 1791 1792 1808 1809 1810 1840 1869 1902 1920 1958 1969 1970 1994 2027 2036 2038 2042 2043 2308 2362 2365 2366 2384 2385 2392 2402 2427 2432 2437 2445 2447 2449 2451 2473 2474 2481 2482 2483 2486 2490 2493 2494 2510 2511 2524 2526 2527 2530 2544 2546 2565 2571 2575 2577 2579 2601 2602 2609 2610 2612 2613 2615 2616 2618 2649 2653 2654 2655 2674 2677 2693 2702 2703 2706 2707 2729 2730 2737 2738 2740 2741 2746 2749 2750 2768 2769 2784 2786 2821 2829 2831 2833 2835 2857 2858 2865 2866 2868 2869 2874 2877 2878 2908 2910 2911 2914 2929 2930 2947 2948 2949 2955 2958 2961 2962 2966 2969 2971 2972 2973 2974 2976 2979 2981 2984 2987 2990 3002 3077 3085 3086 3089 3090 3113 3114 3124 3125 3130 3168 3170 3205 3213 3214 3217 3218 3241 3242 3252 3253 3258 3261 3262 3294 3295 3296 3298 3333 3341 3342 3345 3346 3369 3370 3386 3424 3426 3461 3479 3482 3506 3507 3516 3517 3518 3520 3527 3585 3633 3634 3636 3648 3655 3713 3715 3716 3717 3719 3721 3722 3723 3725 3726 3732 3736 3737 3744 3745 3748 3749 3750 3751 3752 3754 3756 3757 3761 3762 3764 3773 3774 3776 3781 3782 3783 3804 3806 3840 3841 3904 3912 3913 3947 3976 3980 4096 4130 4131 4136 4137 4139 4176 4182 4256 4294 4304 4347 4348 4349 4352 4442 4447 4515 4520 4602 4608 4681 4682 4686 4688 4695 4696 4697 4698 4702 4704 4745 4746 4750 4752 4785 4786 4790 4792 4799 4800 4801 4802 4806 4808 4823 4824 4881 4882 4886 4888 4955 4992 5008 5024 5109 5121 5741 5743 5751 5761 5787 5792 5867 5888 5901 5902 5906 5920 5938 5952 5970 5984 5997 5998 6001 6016 6068 6103 6104 6108 6109 6176 6264 6272 6313 6400 6429 6480 6510 6512 6517 6528 6570 6593 6600 6656 6679 6917 6964 6981 6988 7424 7616 7680 7836 7840 7930 7936 7958 7960 7966 7968 8006 8008 8014 8016 8024 8025 8026 8027 8028 8029 8030 8031 8062 8064 8117 8118 8125 8126 8127 8130 8133 8134 8141 8144 8148 8150 8156 8160 8173 8178 8181 8182 8189 8305 8306 8319 8320 8336 8341 8450 8451 8455 8456 8458 8468 8469 8470 8473 8478 8484 8485 8486 8487 8488 8489 8490 8494 8495 8506 8508 8512 8517 8522 8526 8527 8579 8581 11264 11311 11312 11359 11360 11373 11380 11384 11392 11493 11520 11558 11568 11622 11631 11632 11648 11671 11680 11687 11688 11695 11696 11703 11704 11711 11712 11719 11720 11727 11728 11735 11736 11743 12293 12295 12337 12342 12347 12349 12353 12439 12445 12448 12449 12539 12540 12544 12549 12589 12593 12687 12704 12728 12784 12800 13312 19894 19968 40892 40960 42125 42775 42779 43008 43010 43011 43014 43015 43019 43020 43043 43072 43124 44032 55204 63744 64046 64048 64107 64112 64218 64256 64263 64275 64280 64285 64286 64287 64297 64298 64311 64312 64317 64318 64319 64320 64322 64323 64325 64326 64434 64467 64830 64848 64912 64914 64968 65008 65020 65136 65141 65142 65277 65313 65339 65345 65371 65382 65471 65474 65480 65482 65488 65490 65496 65498 65501 65536 65548 65549 65575 65576 65595 65596 65598 65599 65614 65616 65630 65664 65787 66304 66335 66352 66369 66370 66378 66432 66462 66464 66500 66504 66512 66560 66718 67584 67590 67592 67593 67594 67638 67639 67641 67644 67645 67647 67648 67840 67862 68096 68097 68112 68116 68117 68120 68121 68148 73728 74607 119808 119893 119894 119965 119966 119968 119970 119971 119973 119975 119977 119981 119982 119994 119995 119996 119997 120004 120005 120070 120071 120075 120077 120085 120086 120093 120094 120122 120123 120127 120128 120133 120134 120135 120138 120145 120146 120486 120488 120513 120514 120539 120540 120571 120572 120597 120598 120629 120630 120655 120656 120687 120688 120713 120714 120745 120746 120771 120772 120780 131072 173783 194560 195102))) (define char-set:digit (range-vector->char-set '#(48 58 1632 1642 1776 1786 1984 1994 2406 2416 2534 2544 2662 2672 2790 2800 2918 2928 3046 3056 3174 3184 3302 3312 3430 3440 3664 3674 3792 3802 3872 3882 4160 4170 6112 6122 6160 6170 6470 6480 6608 6618 6992 7002 65296 65306 66720 66730 120782 120832))) (define char-set:mark (range-vector->char-set '#(768 880 1155 1159 1160 1162 1425 1470 1471 1472 1473 1475 1476 1478 1479 1480 1552 1558 1611 1631 1648 1649 1750 1757 1758 1765 1767 1769 1770 1774 1809 1810 1840 1867 1958 1969 2027 2036 2305 2308 2364 2365 2366 2382 2385 2389 2402 2404 2433 2436 2492 2493 2494 2501 2503 2505 2507 2510 2519 2520 2530 2532 2561 2564 2620 2621 2622 2627 2631 2633 2635 2638 2672 2674 2689 2692 2748 2749 2750 2758 2759 2762 2763 2766 2786 2788 2817 2820 2876 2877 2878 2884 2887 2889 2891 2894 2902 2904 2946 2947 3006 3011 3014 3017 3018 3022 3031 3032 3073 3076 3134 3141 3142 3145 3146 3150 3157 3159 3202 3204 3260 3261 3262 3269 3270 3273 3274 3278 3285 3287 3298 3300 3330 3332 3390 3396 3398 3401 3402 3406 3415 3416 3458 3460 3530 3531 3535 3541 3542 3543 3544 3552 3570 3572 3633 3634 3636 3643 3655 3663 3761 3762 3764 3770 3771 3773 3784 3790 3864 3866 3893 3894 3895 3896 3897 3898 3902 3904 3953 3973 3974 3976 3984 3992 3993 4029 4038 4039 4140 4147 4150 4154 4182 4186 4959 4960 5906 5909 5938 5941 5970 5972 6002 6004 6070 6100 6109 6110 6155 6158 6313 6314 6432 6444 6448 6460 6576 6593 6600 6602 6679 6684 6912 6917 6964 6981 7019 7028 7616 7627 7678 7680 8400 8432 12330 12336 12441 12443 43010 43011 43014 43015 43019 43020 43043 43048 64286 64287 65024 65040 65056 65060 68097 68100 68101 68103 68108 68112 68152 68155 68159 68160 119141 119146 119149 119155 119163 119171 119173 119180 119210 119214 119362 119365 917760 918000))) (define char-set:separator (range-vector->char-set '#(32 33 160 161 5760 5761 6158 6159 8192 8203 8232 8234 8239 8240 8287 8288 12288 12289))) (define char-set:punctuation (range-vector->char-set '#(33 36 37 43 44 48 58 60 63 65 91 94 95 96 123 124 125 126 161 162 171 172 183 184 187 188 191 192 894 895 903 904 1370 1376 1417 1419 1470 1471 1472 1473 1475 1476 1478 1479 1523 1525 1548 1550 1563 1564 1566 1568 1642 1646 1748 1749 1792 1806 2039 2042 2404 2406 2416 2417 3572 3573 3663 3664 3674 3676 3844 3859 3898 3902 3973 3974 4048 4050 4170 4176 4347 4348 4961 4969 5741 5743 5787 5789 5867 5870 5941 5943 6100 6103 6104 6107 6144 6155 6468 6470 6622 6624 6686 6688 7002 7009 8208 8232 8240 8260 8261 8274 8275 8287 8317 8319 8333 8335 9001 9003 10088 10102 10181 10183 10214 10220 10627 10649 10712 10716 10748 10750 11513 11517 11518 11520 11776 11800 11804 11806 12289 12292 12296 12306 12308 12320 12336 12337 12349 12350 12448 12449 12539 12540 43124 43128 64830 64832 65040 65050 65072 65107 65108 65122 65123 65124 65128 65129 65130 65132 65281 65284 65285 65291 65292 65296 65306 65308 65311 65313 65339 65342 65343 65344 65371 65372 65373 65374 65375 65382 65792 65794 66463 66464 66512 66513 67871 67872 68176 68185 74864 74868))) (define char-set:symbol (range-vector->char-set '#(36 37 43 44 60 63 94 95 96 97 124 125 126 127 162 170 172 173 174 178 180 181 182 183 184 185 215 216 247 248 706 710 722 736 741 750 751 768 884 886 900 902 1014 1015 1154 1155 1547 1548 1550 1552 1769 1770 1789 1791 2038 2039 2546 2548 2554 2555 2801 2802 2928 2929 3059 3067 3313 3315 3647 3648 3841 3844 3859 3864 3866 3872 3892 3893 3894 3895 3896 3897 4030 4038 4039 4045 4047 4048 4960 4961 5008 5018 6107 6108 6464 6465 6624 6656 7009 7019 7028 7037 8125 8126 8127 8130 8141 8144 8157 8160 8173 8176 8189 8191 8260 8261 8274 8275 8314 8317 8330 8333 8352 8374 8448 8450 8451 8455 8456 8458 8468 8469 8470 8473 8478 8484 8485 8486 8487 8488 8489 8490 8494 8495 8506 8508 8512 8517 8522 8526 8592 9001 9003 9192 9216 9255 9280 9291 9372 9450 9472 9885 9888 9907 9985 9989 9990 9994 9996 10024 10025 10060 10061 10062 10063 10067 10070 10071 10072 10079 10081 10088 10132 10133 10136 10160 10161 10175 10176 10181 10183 10187 10192 10214 10224 10627 10649 10712 10716 10748 10750 11035 11040 11044 11493 11499 11904 11930 11931 12020 12032 12246 12272 12284 12292 12293 12306 12308 12320 12321 12342 12344 12350 12352 12443 12445 12688 12690 12694 12704 12736 12752 12800 12831 12842 12868 12880 12881 12896 12928 12938 12977 12992 13055 13056 13312 19904 19968 42128 42183 42752 42775 42784 42786 43048 43052 64297 64298 65020 65022 65122 65123 65124 65127 65129 65130 65284 65285 65291 65292 65308 65311 65342 65343 65344 65345 65372 65373 65374 65375 65504 65511 65512 65519 65532 65534 65794 65795 65847 65856 65913 65930 118784 119030 119040 119079 119082 119141 119146 119149 119171 119173 119180 119210 119214 119262 119296 119362 119365 119366 119552 119639 120513 120514 120539 120540 120571 120572 120597 120598 120629 120630 120655 120656 120687 120688 120713 120714 120745 120746 120771 120772))) (define char-set:space-separator (range-vector->char-set '#(32 33 160 161 5760 5761 6158 6159 8192 8203 8239 8240 8287 8288 12288 12289))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/srfi-14-char-sets.scm000066400000000000000000000036761375154206600232330ustar00rootroot00000000000000; Part of Scheme 48 1.9. See file COPYING for notices and license. ; Authors: Mike Sperber ; This constructs the SRFI 14 char sets from thin air and what's defined in ; srfi-14-base-char-sets.scm. ; Defined there: ; lower-case, upper-case, title-case, letter, digit, punctuation, symbol (define char-set:empty (char-set)) (define char-set:full (char-set-complement char-set:empty)) (define char-set:letter+digit (char-set-union char-set:letter char-set:digit)) (define char-set:graphic (char-set-union char-set:mark char-set:letter char-set:digit char-set:symbol char-set:punctuation)) (define char-set:whitespace (char-set-union char-set:separator (list->char-set (map scalar-value->char '(9 ; tab 10 ; newline 11 ; vtab 12 ; page 13 ; return ))))) (define char-set:printing (char-set-union char-set:whitespace char-set:graphic)) (define char-set:iso-control (char-set-union (ucs-range->char-set 0 #x20) (ucs-range->char-set #x7f #xa0))) (define char-set:blank (char-set-union char-set:space-separator (char-set (scalar-value->char 9)))) ; tab (define char-set:ascii (ucs-range->char-set 0 128)) (define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF")) (make-char-set-immutable! char-set:empty) (make-char-set-immutable! char-set:full) (make-char-set-immutable! char-set:lower-case) (make-char-set-immutable! char-set:upper-case) (make-char-set-immutable! char-set:letter) (make-char-set-immutable! char-set:digit) (make-char-set-immutable! char-set:hex-digit) (make-char-set-immutable! char-set:letter+digit) (make-char-set-immutable! char-set:punctuation) (make-char-set-immutable! char-set:symbol) (make-char-set-immutable! char-set:graphic) (make-char-set-immutable! char-set:whitespace) (make-char-set-immutable! char-set:printing) (make-char-set-immutable! char-set:blank) (make-char-set-immutable! char-set:iso-control) (make-char-set-immutable! char-set:ascii) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/srfi-14-check.scm000066400000000000000000000525071375154206600224140ustar00rootroot00000000000000; Part of Scheme 48 1.9. See file COPYING for notices and license. ; Authors: Mike Sperber, Olin Shivers ; SRFI 14 test suite ;; adapted from Olin's test suite (define (vowel? c) (member c '(#\a #\e #\i #\o #\u))) (define-test-suite srfi-14-tests) (define-test-case char-set? srfi-14-tests (check (not (char-set? 5))) (check (char-set? (char-set #\a #\e #\i #\o #\u)))) (define-test-case char-set= srfi-14-tests (check (char-set=)) (check (char-set= (char-set))) (check (string->char-set "ioeauaiii") (=> char-set=) (char-set #\a #\e #\i #\o #\u)) (check (not (char-set= (string->char-set "ioeauaiii") (char-set #\e #\i #\o #\u))))) (define-test-case char-set<= srfi-14-tests (check (char-set<=)) (check (char-set<= (char-set))) (check (char-set<= (char-set #\a #\e #\i #\o #\u) (string->char-set "ioeauaiii"))) (check (char-set<= (char-set #\e #\i #\o #\u) (string->char-set "ioeauaiii")))) (define-test-case char-set-hash srfi-14-tests (check-that (char-set-hash char-set:graphic 100) (all-of (is (lambda (x) (>= x 0))) (is (lambda (x) (<= x 99)))))) (define-test-case char-set-fold srfi-14-tests (check (char-set-fold (lambda (c i) (+ i 1)) 0 (char-set #\e #\i #\o #\u #\e #\e)) => 4)) ; The following test is ASCII/Latin-1 only, and fails with Unicode ; (char-set= (string->char-set "eiaou2468013579999") ; (char-set-unfold null? car cdr '(#\a #\e #\i #\o #\u #\u #\u) ; char-set:digit)) (define-test-case char-set-unfold srfi-14-tests (check-that (char-set-unfold null? car cdr '(#\a #\e #\i #\o #\u) (string->char-set "0123456789")) (is char-set= (string->char-set "eiaou246801357999")))) (define-test-case char-set-unfold! srfi-14-tests (check-that (char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u) (string->char-set "0123456789")) (opposite (is char-set= (string->char-set "eiaou246801357"))))) (define-test-case char-set-for-each srfi-14-tests (let ((cs (string->char-set "0123456789"))) (char-set-for-each (lambda (c) (set! cs (char-set-delete cs c))) (string->char-set "02468000")) (check-that cs (is char-set= (string->char-set "97531")))) (let ((cs (string->char-set "0123456789"))) (char-set-for-each (lambda (c) (set! cs (char-set-delete cs c))) (string->char-set "02468")) (check-that cs (opposite (is char-set= (string->char-set "7531")))))) (define-test-case char-set-map srfi-14-tests (check-that (char-set-map char-upcase (string->char-set "aeiou")) (is char-set= (string->char-set "IOUAEEEE"))) (check-that (char-set-map char-upcase (string->char-set "aeiou")) (opposite (is char-set= (string->char-set "OUAEEEE"))))) (define-test-case char-set-copy srfi-14-tests (check-that (char-set-copy (string->char-set "aeiou")) (is char-set= (string->char-set "aeiou")))) (define-test-case char-set srfi-14-tests (check-that (char-set #\x #\y) (is char-set= (string->char-set "xy"))) (check-that (char-set #\x #\y #\z) (opposite (is char-set= (string->char-set "xy"))))) (define-test-case list->char-set srfi-14-tests (check-that (list->char-set '(#\x #\y)) (is char-set= (string->char-set "xy"))) (check-that (list->char-set '(#\x #\y)) (opposite (is char-set= (string->char-set "axy")))) (check-that (list->char-set '(#\x #\y) (string->char-set "12345")) (is char-set= (string->char-set "xy12345"))) (check-that (list->char-set '(#\x #\y) (string->char-set "12345")) (opposite (is char-set= (string->char-set "y12345"))))) (define-test-case list->char-set! srfi-14-tests (check-that (list->char-set! '(#\x #\y) (string->char-set "12345")) (is char-set= (string->char-set "xy12345"))) (check-that (list->char-set! '(#\x #\y) (string->char-set "12345")) (opposite (is char-set= (string->char-set "y12345"))))) (define-test-case char-set-filter srfi-14-tests (check-that (char-set-filter vowel? char-set:ascii (string->char-set "12345")) (is char-set= (string->char-set "aeiou12345"))) (check-that (char-set-filter vowel? char-set:ascii (string->char-set "12345")) (opposite (is char-set= (string->char-set "aeou12345"))))) (define-test-case char-set-filter! srfi-14-tests (check-that (char-set-filter! vowel? char-set:ascii (string->char-set "12345")) (is char-set= (string->char-set "aeiou12345"))) (check-that (char-set-filter! vowel? char-set:ascii (string->char-set "12345")) (opposite (is char-set= (string->char-set "aeou12345"))))) (define-test-case ucs-range->char-set srfi-14-tests (check-that (ucs-range->char-set 97 103 #t (string->char-set "12345")) (is char-set= (string->char-set "abcdef12345"))) (check-that (ucs-range->char-set 97 103 #t (string->char-set "12345")) (opposite (is char-set= (string->char-set "abcef12345"))))) (define-test-case ucs-range_>char-set! srfi-14-tests (check-that (ucs-range->char-set! 97 103 #t (string->char-set "12345")) (is char-set= (string->char-set "abcdef12345"))) (check-that (ucs-range->char-set! 97 103 #t (string->char-set "12345")) (opposite (is char-set= (string->char-set "abcef12345"))))) (define-test-case x->char-set srfi-14-tests (check-that (x->char-set #\x) (is char-set= (x->char-set "x"))) (check-that (x->char-set #\x) (is char-set= (x->char-set (char-set #\x)))) (check-that (x->char-set "y") (opposite (is char-set= (x->char-set #\x))))) (define-test-case char-set-size srfi-14-tests (check (char-set-size (char-set-intersection char-set:ascii char-set:digit)) => 10)) (define-test-case char-set-count srfi-14-tests (check (char-set-count vowel? char-set:ascii) => 5)) (define-test-case char-set->list srfi-14-tests (check (char-set->list (char-set #\x)) => '(#\x)) (check-that (char-set->list (char-set #\x)) (opposite (is '(#\X))))) (define-test-case char-set->string srfi-14-tests (check (char-set->string (char-set #\x)) => "x") (check-that (char-set->string (char-set #\x)) (opposite (is "X" )))) (define-test-case char-set-contains? srfi-14-tests (check (char-set-contains? (x->char-set "xyz") #\x)) (check (not (char-set-contains? (x->char-set "xyz") #\a)))) (define-test-case char-set-every srfi-14-tests (check (char-set-every char-lower-case? (x->char-set "abcd"))) (check-that (char-set-every char-lower-case? (x->char-set "abcD")) (is-false))) (define-test-case char-set-any srfi-14-tests (check (char-set-any char-lower-case? (x->char-set "abcd"))) (check-that (char-set-any char-lower-case? (x->char-set "ABCD")) (is-false))) (define-test-case cursors srfi-14-tests (check-that (let ((cs (x->char-set "abcd"))) (let lp ((cur (char-set-cursor cs)) (ans '())) (if (end-of-char-set? cur) (list->char-set ans) (lp (char-set-cursor-next cs cur) (cons (char-upcase (char-set-ref cs cur)) ans))))) (is char-set= (x->char-set "ABCD")))) (define-test-case char-set-adjoin srfi-14-tests (check-that (char-set-adjoin (x->char-set "123") #\x #\a) (is char-set= (x->char-set "123xa"))) (check-that (x->char-set "123x") (opposite (is char-set= (char-set-adjoin (x->char-set "123") #\x #\a))))) (define-test-case char-set-adjoin! srfi-14-tests (check-that (char-set-adjoin! (x->char-set "123") #\x #\a) (is char-set= (x->char-set "123xa"))) (check-that (x->char-set "123x") (opposite (is char-set= (char-set-adjoin! (x->char-set "123") #\x #\a))))) (define-test-case char-set-delete srfi-14-tests (check-that (char-set-delete (x->char-set "123") #\2 #\a #\2) (is char-set= (x->char-set "13"))) (check-that (char-set-delete (x->char-set "123") #\2 #\a #\2) (opposite (is char-set= (x->char-set "13a"))))) (define-test-case char-set-delete! srfi-14-tests (check-that (char-set-delete! (x->char-set "123") #\2 #\a #\2) (is char-set= (x->char-set "13"))) (check-that (char-set-delete! (x->char-set "123") #\2 #\a #\2) (opposite (is char-set= (x->char-set "13a"))))) (define-test-case char-set-intersection srfi-14-tests (check-that (char-set-intersection char-set:hex-digit (char-set-complement char-set:digit)) (is char-set= (x->char-set "abcdefABCDEF")))) (define-test-case char-set-intersection! srfi-14-tests (check-that (char-set-intersection! (char-set-complement! (x->char-set "0123456789")) char-set:hex-digit) (is char-set= (x->char-set "abcdefABCDEF")))) (define-test-case char-set-union srfi-14-tests (check-that (char-set-union char-set:hex-digit (x->char-set "abcdefghijkl")) (is char-set= (x->char-set "abcdefABCDEFghijkl0123456789")))) (define-test-case char-set-union! srfi-14-tests (check-that (char-set-union! (x->char-set "abcdefghijkl") char-set:hex-digit) (is char-set= (x->char-set "abcdefABCDEFghijkl0123456789")))) (define-test-case char-set-difference srfi-14-tests (check-that (char-set-difference (x->char-set "abcdefghijklmn") char-set:hex-digit) (is char-set= (x->char-set "ghijklmn")))) (define-test-case char-set-difference! srfi-14-tests (check-that (char-set-difference! (x->char-set "abcdefghijklmn") char-set:hex-digit) (is char-set= (x->char-set "ghijklmn")))) (define-test-case char-set-xor srfi-14-tests (check-that (char-set-xor (x->char-set "0123456789") char-set:hex-digit) (is char-set= (x->char-set "abcdefABCDEF")))) (define-test-case char-set-xor! srfi-14-tests char-set= (check-that (char-set-xor! (x->char-set "0123456789") char-set:hex-digit) (is char-set= (x->char-set "abcdefABCDEF")))) (define-test-case char-set-diff+intersection srfi-14-tests (call-with-values (lambda () (char-set-diff+intersection char-set:hex-digit char-set:letter)) (lambda (d i) (check-that d (is char-set= (x->char-set "0123456789"))) (check-that i (is char-set= (x->char-set "abcdefABCDEF"))))) (call-with-values (lambda () (char-set-diff+intersection (char-set-union char-set:letter char-set:digit) char-set:letter)) (lambda (d i) (check-that d (is char-set= char-set:digit)) (check-that i (is char-set= char-set:letter))))) (define-test-case char-set-diff+intersection! srfi-14-tests (call-with-values (lambda () (char-set-diff+intersection! (char-set-copy char-set:hex-digit) (char-set-copy char-set:letter))) (lambda (d i) (check-that d (is char-set= (x->char-set "0123456789"))) (check-that i (is char-set= (x->char-set "abcdefABCDEF"))))) (call-with-values (lambda () (char-set-diff+intersection! (char-set-union char-set:letter char-set:digit) (char-set-copy char-set:letter))) (lambda (d i) (check-that d (is char-set= char-set:digit)) (check-that i (is char-set= char-set:letter))))) ; The following stuff was adapted from the suite Matthew Flatt wrote ; for PLT Scheme (define-test-case char-set:lower-case srfi-14-tests (check (char-set-contains? char-set:lower-case #\a)) (check (not (char-set-contains? char-set:lower-case #\A))) (check (char-set-contains? char-set:lower-case (scalar-value->char #x00E0))) (check (not (char-set-contains? char-set:lower-case (scalar-value->char #x00C2)))) (check (char-set-contains? char-set:lower-case (scalar-value->char #x00B5)))) (define-test-case char-set:upper-case srfi-14-tests (check (char-set-contains? char-set:upper-case #\A)) (check (not (char-set-contains? char-set:upper-case #\a))) (check (char-set-contains? char-set:upper-case (scalar-value->char #x00C2))) (check (not (char-set-contains? char-set:upper-case (scalar-value->char #x00E0))))) (define-test-case char-set:title-case srfi-14-tests (check (char-set-contains? char-set:title-case (scalar-value->char #x01C5))) (check (char-set-contains? char-set:title-case (scalar-value->char #x1FA8))) (check (not (char-set-contains? char-set:title-case #\a))) (check (not (char-set-contains? char-set:title-case #\A)))) (define-test-case char-set:letter srfi-14-tests (check (char-set-contains? char-set:letter #\a)) (check (char-set-contains? char-set:letter #\A)) (check (not (char-set-contains? char-set:letter #\1))) (check (char-set-contains? char-set:letter (scalar-value->char #x00AA))) (check (char-set-contains? char-set:letter (scalar-value->char #x00BA)))) (define-test-case char-set:lower-case/2 srfi-14-tests (check (not (char-set-every (lambda (c) (char-set-contains? char-set:lower-case c)) char-set:letter))) (check (char-set-any (lambda (c) (char-set-contains? char-set:lower-case c)) char-set:letter))) (define-test-case char-set:upper-case/2 srfi-14-tests (check (not (char-set-every (lambda (c) (char-set-contains? char-set:upper-case c)) char-set:letter))) (check (char-set-any (lambda (c) (char-set-contains? char-set:upper-case c)) char-set:letter))) ;; Not true? ;; (test #t char-set<= char-set:letter (char-set-union char-set:lower-case char-set:upper-case char-set:title-case)) (define-test-case char-set:digit srfi-14-tests (check (char-set-contains? char-set:digit #\1)) (check (not (char-set-contains? char-set:digit #\a)))) (define-test-case char-set:hex-digit srfi-14-tests (check (char-set-contains? char-set:hex-digit #\1)) (check (char-set-contains? char-set:hex-digit #\a)) (check (char-set-contains? char-set:hex-digit #\A)) (check (not (char-set-contains? char-set:hex-digit #\g)))) (define-test-case char-set:letter+digit srfi-14-tests equal? (check (char-set-contains? char-set:letter+digit #\1)) (check (char-set-contains? char-set:letter+digit #\a)) (check (char-set-contains? char-set:letter+digit #\z)) (check (char-set-contains? char-set:letter+digit #\A)) (check (char-set-contains? char-set:letter+digit #\Z))) (define-test-case char-set:letter/size srfi-14-tests (check (char-set-size char-set:letter) => 92496)) (define-test-case char-set:letter/2 srfi-14-tests (check-that (char-set-union char-set:letter char-set:digit) (is char-set= char-set:letter+digit)) (check (not (char-set-every (lambda (c) (char-set-contains? char-set:letter c)) char-set:letter+digit))) (check (not (char-set-every (lambda (c) (char-set-contains? char-set:digit c)) char-set:letter+digit))) (check (char-set-any (lambda (c) (char-set-contains? char-set:letter c)) char-set:letter+digit))) (define-test-case char-set:letter+digit/2 srfi-14-tests (check (char-set-every (lambda (c) (char-set-contains? char-set:letter+digit c)) char-set:letter)) (check (char-set-every (lambda (c) (char-set-contains? char-set:letter+digit c)) char-set:digit))) (define char-set:latin-1 (ucs-range->char-set 0 256)) (define-test-case char-set:latin-1 srfi-14-tests (check-that (char-set-intersection (char-set-union char-set:letter char-set:digit char-set:punctuation char-set:symbol) char-set:latin-1) (is char-set= (char-set-intersection char-set:graphic char-set:latin-1)))) (define-test-case char-set:printing srfi-14-tests (check-that (char-set-union char-set:graphic char-set:whitespace) (is char-set= char-set:printing))) (define-test-case char-set:whitespace srfi-14-tests (check (char-set-contains? char-set:whitespace (scalar-value->char #x0009))) (check (char-set-contains? char-set:whitespace (scalar-value->char #x000D))) (check (not (char-set-contains? char-set:whitespace #\a)))) (define-test-case char-set:iso-control srfi-14-tests (check-that (char-set-union (ucs-range->char-set #x0000 #x0020) (ucs-range->char-set #x007F #x00A0)) (is char-set= char-set:iso-control))) (define-test-case char-set:punctuation srfi-14-tests (check (char-set-contains? char-set:punctuation #\!)) (check (char-set-contains? char-set:punctuation (scalar-value->char #x00A1))) (check (not (char-set-contains? char-set:punctuation #\a)))) (define-test-case char-set:symbol srfi-14-tests (check (char-set-contains? char-set:symbol #\$)) (check (char-set-contains? char-set:symbol (scalar-value->char #x00A2))) (check (not (char-set-contains? char-set:symbol #\a)))) (define-test-case char-set:blank srfi-14-tests (check (char-set-contains? char-set:blank #\space)) (check (char-set-contains? char-set:blank (scalar-value->char #x3000))) (check (not (char-set-contains? char-set:blank #\a)))) ;; General procedures ---------------------------------------- (define-test-case char-set=/2 srfi-14-tests (check (char-set= char-set:letter char-set:letter char-set:letter)) (check (not (char-set= char-set:letter char-set:digit))) (check (not (char-set= char-set:letter char-set:letter char-set:digit))) (check (not (char-set= char-set:letter char-set:digit char-set:letter)))) (define-test-case char-set<=/2 srfi-14-tests (check (char-set<= char-set:graphic char-set:printing)) (check (not (char-set<= char-set:printing char-set:graphic))) (check (char-set<= char-set:graphic char-set:printing char-set:full)) (check (not (char-set<= char-set:graphic char-set:full char-set:printing)))) (define-test-case char-set-hash/2 srfi-14-tests (check (char-set-hash char-set:graphic) => (char-set-hash char-set:graphic))) ;; Iterating over character sets ---------------------------------------- ;; The number 290 comes from "grep Nd UnicodeData.txt | wc -l" (define-test-case char-set-size/2 srfi-14-tests (check (char-set-size char-set:digit) => 290)) (define-test-case cursors/2 srfi-14-tests (check-that (list->char-set (let loop ((c (char-set-cursor char-set:digit)) (l '())) (if (end-of-char-set? c) l (loop (char-set-cursor-next char-set:digit c) (cons (char-set-ref char-set:digit c) l))))) (is char-set= char-set:digit))) (define (add1 x) (+ 1 x)) (define-test-case char-set-unfold/2 srfi-14-tests (check-that (char-set-unfold (lambda (x) (= x 20)) scalar-value->char add1 10) (is char-set= (ucs-range->char-set 10 20))) (check-that (char-set-unfold (lambda (x) (= x 20)) scalar-value->char add1 10 (char-set (scalar-value->char #x14))) (is char-set= (ucs-range->char-set 10 21)))) (define-test-case char-set-unfold!/2 srfi-14-tests (check-that (char-set-unfold! (lambda (x) (= x 20)) scalar-value->char add1 10 (char-set-copy char-set:empty)) (is char-set= (ucs-range->char-set 10 20)))) (define-test-case char-set-for-each/2 srfi-14-tests (check-that (let ((cs char-set:empty)) (char-set-for-each (lambda (c) (set! cs (char-set-adjoin cs c))) char-set:digit) cs) (is char-set= char-set:digit))) (define-test-case char-set-map/2 srfi-14-tests equal? (check-that (char-set-map (lambda (c) c) char-set:digit) (is char-set= char-set:digit)) (check-that (char-set-map (lambda (c) c) char-set:digit) (is char-set= char-set:digit)) (check-that (char-set-union (char-set-map (lambda (c) c) char-set:digit) (char-set #\A)) (is char-set= (char-set-adjoin char-set:digit #\A)))) ;; Creating character sets ---------------------------------------- (define-test-case char-set-copy/2 srfi-14-tests (check-that (char-set-copy char-set:digit) (is char-set= char-set:digit))) (define-test-case abc srfi-14-tests (let ((abc (char-set #\a #\b #\c))) (check-that (char-set #\c #\a #\b) (is char-set= abc)) (check-that (string->char-set "cba") (is char-set= abc)) (check-that (string->char-set! "cba" (char-set-copy char-set:empty)) (is char-set= abc)) (check-that (string->char-set "cb" (char-set #\a)) (is char-set= abc)) (check-that (char-set-filter (lambda (c) (char=? c #\b)) abc) (is char-set= (char-set #\b))) (check-that (char-set-filter (lambda (c) (char=? c #\b)) abc char-set:empty) (is char-set= (char-set #\b))) (check-that (char-set-filter! (lambda (c) (char=? c #\b)) (char-set-copy abc) (char-set-copy char-set:empty)) (is char-set= (char-set #\b))) (check-that (x->char-set "abc") (is char-set= abc)) (check-that (x->char-set abc) (is char-set= abc)) (check-that (x->char-set #\a) (is char-set= (char-set #\a))))) (define-test-case ucs-range->char/2 srfi-14-tests (check-that (char-set-union (ucs-range->char-set 0 #xD800) (ucs-range->char-set #xE000 #x20000)) (is char-set= (ucs-range->char-set 0 #x20000))) (check-that (ucs-range->char-set 0 #xD800) (is char-set= (ucs-range->char-set 0 #xD801))) (check-that (ucs-range->char-set 0 #xD800) (is char-set= (ucs-range->char-set 0 #xDFFF))) (check-that char-set:empty (is char-set= (ucs-range->char-set #xD800 #xD810))) (check-that char-set:empty (is char-set= (ucs-range->char-set #xD810 #xE000))) (check-that (ucs-range->char-set #xD810 #xE001) (is char-set= (ucs-range->char-set #xE000 #xE001))) (check-that (char-set (scalar-value->char #xD7FF) (scalar-value->char #xE000)) (is char-set= (ucs-range->char-set #xD7FF #xE001)))) ;; Querying character sets ------------------------------ (define-test-case char-set-count/2 srfi-14-tests (check (char-set-count (lambda (x) (and (char<=? #\0 x) (char<=? x #\2))) char-set:digit) => 3)) (define-test-case list->char-set/2 srfi-14-tests (check-that (list->char-set (char-set->list char-set:digit)) (is char-set= char-set:digit)) (check-that (list->char-set (char-set->list char-set:digit) char-set:empty) (is char-set= char-set:digit)) (check-that (list->char-set! (char-set->list char-set:digit) (char-set-copy char-set:empty)) (is char-set= char-set:digit)) (check-that (string->char-set (char-set->string char-set:digit)) (is char-set= char-set:digit))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/srfi-14.scm000066400000000000000000000621401375154206600213330ustar00rootroot00000000000000; Part of Scheme 48 1.9. See file COPYING for notices and license. ; Authors: Mike Sperber, Robert Tansom ; Copyright (c) 2005-2006 by Basis Technology Corporation. ; This is basically a complete re-implementation, suitable for Unicode. ; Some bits and pieces from Olin's reference implementation remain, ; but none from the MIT Scheme code. For whatever remains, the ; following copyright holds: ; Copyright (c) 1994-2003 by Olin Shivers ; ; All rights reserved. ; ; Redistribution and use in source and binary forms, with or without ; modification, are permitted provided that the following conditions ; are met: ; 1. Redistributions of source code must retain the above copyright ; notice, this list of conditions and the following disclaimer. ; 2. Redistributions in binary form must reproduce the above copyright ; notice, this list of conditions and the following disclaimer in the ; documentation and/or other materials provided with the distribution. ; 3. The name of the authors may not be used to endorse or promote products ; derived from this software without specific prior written permission. ; ; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR ; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES ; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. ; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, ; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT ; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (define-record-type :char-set (make-char-set simple i-list) char-set? ;; byte vector for the Latin-1 part (simple char-set-simple set-char-set-simple!) ;; inversion list for the rest (i-list char-set-i-list set-char-set-i-list!)) (define-record-discloser :char-set (lambda (cs) (list 'char-set (char-set-size cs)))) (define (make-char-set-immutable! char-set) (make-immutable! char-set) (make-immutable! (char-set-simple char-set))) ; inversion lists are always immutable ;;; "Simple Csets"---we use mutable byte vectors for the Latin-1 part (define *simple-cset-boundary* 256) (define (simple-char? c) (< (char->scalar-value c) *simple-cset-boundary*)) (define (make-empty-simple-cset) (make-byte-vector *simple-cset-boundary* 0)) (define (make-full-simple-cset) (make-byte-vector *simple-cset-boundary* 1)) (define (copy-simple-cset s) (byte-vector-copy s)) ; don't mistake these for abstractions (define (simple-cset-code-not-member? s i) (zero? (byte-vector-ref s i))) (define (simple-cset-code-member? s i) (not (simple-cset-code-not-member? s i))) (define (simple-cset-ref s i) (byte-vector-ref s i)) (define (simple-cset-set! s i v) (byte-vector-set! s i v)) (define (simple-cset-remove-code! s i) (byte-vector-set! s i 0)) (define (simple-cset-adjoin-code! s i) (byte-vector-set! s i 1)) (define (simple-cset-contains? s char) (simple-cset-code-member? s (char->scalar-value char))) (define (simple-cset=? s1 s2) (byte-vector=? s1 s2)) (define (simple-cset<=? s1 s2) (or (eq? s1 s2) (let loop ((i 0)) (if (>= i *simple-cset-boundary*) #t (and (<= (simple-cset-ref s1 i) (simple-cset-ref s2 i)) (loop (+ 1 i))))))) (define (simple-cset-size s) (let loop ((i 0) (size 0)) (if (>= i *simple-cset-boundary*) size (loop (+ 1 i) (+ size (simple-cset-ref s i)))))) (define (simple-cset-count pred s) (let loop ((i 0) (count 0)) (if (>= i *simple-cset-boundary*) count (loop (+ 1 i) (if (and (simple-cset-code-member? s i) (pred (scalar-value->char i))) (+ count 1) count))))) (define (simple-cset-modify! set s chars) (for-each (lambda (c) (set s (char->scalar-value c))) chars) s) (define (simple-cset-modify set s chars) (simple-cset-modify! set (copy-simple-cset s) chars)) (define (simple-cset-adjoin s . chars) (simple-cset-modify simple-cset-adjoin-code! s chars)) (define (simple-cset-adjoin! s . chars) (simple-cset-modify! simple-cset-adjoin-code! s chars)) (define (simple-cset-delete s . chars) (simple-cset-modify simple-cset-remove-code! s chars)) (define (simple-cset-delete! s . chars) (simple-cset-modify! simple-cset-remove-code! s chars)) ;;; If we represented char sets as a bit set, we could do the following ;;; trick to pick the lowest bit out of the set: ;;; (count-bits (xor (- cset 1) cset)) ;;; (But first mask out the bits already scanned by the cursor first.) (define (simple-cset-cursor-next s cursor) (let loop ((cur cursor)) (let ((cur (- cur 1))) (if (or (< cur 0) (simple-cset-code-member? s cur)) cur (loop cur))))) (define (end-of-simple-cset? cursor) (negative? cursor)) (define (simple-cset-cursor-ref cursor) (scalar-value->char cursor)) (define (simple-cset-for-each proc s) (let loop ((i 0)) (if (< i *simple-cset-boundary*) (begin (if (simple-cset-code-member? s i) (proc (scalar-value->char i))) (loop (+ 1 i)))))) (define (simple-cset-fold kons knil s) (let loop ((i 0) (ans knil)) (if (>= i *simple-cset-boundary*) ans (loop (+ 1 i) (if (simple-cset-code-not-member? s i) ans (kons (scalar-value->char i) ans)))))) (define (simple-cset-every? pred s) (let loop ((i 0)) (cond ((>= i *simple-cset-boundary*) #t) ((or (simple-cset-code-not-member? s i) (pred (scalar-value->char i))) (loop (+ 1 i))) (else #f)))) (define (simple-cset-any pred s) (let loop ((i 0)) (cond ((>= i *simple-cset-boundary*) #f) ((and (simple-cset-code-member? s i) (pred (scalar-value->char i)))) (else (loop (+ 1 i)))))) (define (ucs-range->simple-cset lower upper) (let ((s (make-empty-simple-cset))) (let loop ((i lower)) (if (< i upper) (begin (simple-cset-adjoin-code! s i) (loop (+ 1 i))))) s)) ; Algebra ; These do various "s[i] := s[i] op val" operations (define (simple-cset-invert-code! s i v) (simple-cset-set! s i (- 1 v))) (define (simple-cset-and-code! s i v) (if (zero? v) (simple-cset-remove-code! s i))) (define (simple-cset-or-code! s i v) (if (not (zero? v)) (simple-cset-adjoin-code! s i))) (define (simple-cset-minus-code! s i v) (if (not (zero? v)) (simple-cset-remove-code! s i))) (define (simple-cset-xor-code! s i v) (if (not (zero? v)) (simple-cset-set! s i (- 1 (simple-cset-ref s i))))) (define (simple-cset-complement s) (simple-cset-complement! (copy-simple-cset s))) (define (simple-cset-complement! s) (byte-vector-iter (lambda (i v) (simple-cset-invert-code! s i v)) s) s) (define (simple-cset-op! s simple-csets code-op!) (for-each (lambda (s2) (let loop ((i 0)) (if (< i *simple-cset-boundary*) (begin (code-op! s i (simple-cset-ref s2 i)) (loop (+ 1 i)))))) simple-csets) s) (define (simple-cset-union! s1 . ss) (simple-cset-op! s1 ss simple-cset-or-code!)) (define (simple-cset-union . ss) (if (pair? ss) (apply simple-cset-union! (byte-vector-copy (car ss)) (cdr ss)) (make-empty-simple-cset))) (define (simple-cset-intersection! s1 . ss) (simple-cset-op! s1 ss simple-cset-and-code!)) (define (simple-cset-intersection . ss) (if (pair? ss) (apply simple-cset-intersection! (byte-vector-copy (car ss)) (cdr ss)) (make-full-simple-cset))) (define (simple-cset-difference! s1 . ss) (simple-cset-op! s1 ss simple-cset-minus-code!)) (define (simple-cset-difference s1 . ss) (if (pair? ss) (apply simple-cset-difference! (copy-simple-cset s1) ss) (copy-simple-cset s1))) (define (simple-cset-xor! s1 . ss) (simple-cset-op! s1 ss simple-cset-xor-code!)) (define (simple-cset-xor . ss) (if (pair? ss) (apply simple-cset-xor! (byte-vector-copy (car ss)) (cdr ss)) (make-empty-simple-cset))) (define (simple-cset-diff+intersection! s1 s2 . ss) (byte-vector-iter (lambda (i v) (cond ((zero? v) (simple-cset-remove-code! s2 i)) ((simple-cset-code-member? s2 i) (simple-cset-remove-code! s1 i)))) s1) (for-each (lambda (s) (byte-vector-iter (lambda (i v) (if (and (not (zero? v)) (simple-cset-code-member? s1 i)) (begin (simple-cset-remove-code! s1 i) (simple-cset-adjoin-code! s2 i)))) s)) ss) (values s1 s2)) ; Compute (c + 37 c + 37^2 c + ...) modulo BOUND, with sleaze thrown ; in to keep the intermediate values small. (We do the calculation ; with just enough bits to represent BOUND, masking off high bits at ; each step in calculation. If this screws up any important properties ; of the hash function I'd like to hear about it. -Olin) (define (simple-cset-hash s bound) ;; The mask that will cover BOUND-1: (let ((mask (let loop ((i #x10000)) ; Let's skip first 16 iterations, eh? (if (>= i bound) (- i 1) (loop (+ i i)))))) (let loop ((i (- *simple-cset-boundary* 1)) (ans 0)) (if (< i 0) (modulo ans bound) (loop (- i 1) (if (simple-cset-code-not-member? s i) ans (bitwise-and mask (+ (* 37 ans) i)))))))) ;;; Now for the real character sets (define (make-empty-char-set) (make-char-set (make-empty-simple-cset) (make-empty-inversion-list *simple-cset-boundary* (+ 1 #x10ffff)))) (define (make-full-char-set) (make-char-set (make-full-simple-cset) (range->inversion-list *simple-cset-boundary* (+ 1 #x10ffff) *simple-cset-boundary* (+ 1 #x10ffff)))) (define (char-set-copy cs) (make-char-set (copy-simple-cset (char-set-simple cs)) (inversion-list-copy (char-set-i-list cs)))) ; n-ary version (define (char-set= . rest) (or (null? rest) (let ((cs1 (car rest)) (rest (cdr rest))) (let loop ((rest rest)) (or (not (pair? rest)) (and (char-set=/2 cs1 (car rest)) (loop (cdr rest)))))))) ; binary version (define (char-set=/2 cs-1 cs-2) (and (simple-cset=? (char-set-simple cs-1) (char-set-simple cs-2)) (inversion-list=? (char-set-i-list cs-1) (char-set-i-list cs-2)))) ; n-ary (define (char-set<= . rest) (or (null? rest) (let ((cs1 (car rest)) (rest (cdr rest))) (let loop ((cs1 cs1) (rest rest)) (or (not (pair? rest)) (and (char-set<=/2 cs1 (car rest)) (loop (car rest) (cdr rest)))))))) ; binary (define (char-set<=/2 cs-1 cs-2) (and (simple-cset<=? (char-set-simple cs-1) (char-set-simple cs-2)) (inversion-list<=? (char-set-i-list cs-1) (char-set-i-list cs-2)))) (define (inversion-list<=? i-list-1 i-list-2) (inversion-list=? i-list-1 (inversion-list-intersection i-list-1 i-list-2))) ;;; Hash ; We follow Olin's reference implementation: ; ; If you keep BOUND small enough, the intermediate calculations will ; always be fixnums. How small is dependent on the underlying Scheme system; ; we use a default BOUND of 2^22 = 4194304, which should hack it in ; Schemes that give you at least 29 signed bits for fixnums. The core ; calculation that you don't want to overflow is, worst case, ; (+ 65535 (* 37 (- bound 1))) ; where 65535 is the max character code. Choose the default BOUND to be the ; biggest power of two that won't cause this expression to fixnum overflow, ; and everything will be copacetic. (define char-set-hash (opt-lambda (cs (bound 4194304)) (if (not (and (integer? bound) (exact? bound) (<= 0 bound))) (assertion-violation 'char-set-hash "invalid bound" bound)) (let ((bound (if (zero? bound) 4194304 bound))) (modulo (+ (simple-cset-hash (char-set-simple cs) bound) (* 37 (inversion-list-hash (char-set-i-list cs) bound))) bound)))) (define (char-set-contains? cs char) (if (simple-char? char) (simple-cset-contains? (char-set-simple cs) char) (inversion-list-member? (char->scalar-value char) (char-set-i-list cs)))) (define (char-set-size cs) (+ (simple-cset-size (char-set-simple cs)) (inversion-list-size (char-set-i-list cs)))) (define (char-set-count pred cset) (+ (simple-cset-count pred (char-set-simple cset)) (inversion-list-count pred (char-set-i-list cset)))) (define (inversion-list-count pred i-list) (inversion-list-fold/done? (lambda (v count) (if (pred (scalar-value->char v)) (+ 1 count) count)) 0 (lambda (v) #f) i-list)) (define (make-char-set-char-op simple-cset-op inversion-list-op) (lambda (cs . chars) (call-with-values (lambda () (partition-list simple-char? chars)) (lambda (simple-chars non-simple-chars) (make-char-set (apply simple-cset-op (char-set-simple cs) simple-chars) (apply inversion-list-op (char-set-i-list cs) (map char->scalar-value non-simple-chars))))))) (define (make-char-set-char-op! simple-cset-op! simple-cset-op inversion-list-op) (lambda (cs . chars) (call-with-values (lambda () (partition-list simple-char? chars)) (lambda (simple-chars non-simple-chars) (if (null? non-simple-chars) (apply simple-cset-op! (char-set-simple cs) simple-chars) (begin (set-char-set-simple! cs (apply simple-cset-op (char-set-simple cs) simple-chars)) (set-char-set-i-list! cs (apply inversion-list-op (char-set-i-list cs) (map char->scalar-value non-simple-chars))))))) cs)) (define char-set-adjoin (make-char-set-char-op simple-cset-adjoin inversion-list-adjoin)) (define char-set-adjoin! (make-char-set-char-op! simple-cset-adjoin! simple-cset-adjoin inversion-list-adjoin)) (define char-set-delete (make-char-set-char-op simple-cset-delete inversion-list-remove)) (define char-set-delete! (make-char-set-char-op! simple-cset-delete! simple-cset-delete inversion-list-remove)) ;;; Cursors ; A cursor is either an integer index into the mark vector (-1 for the ; end-of-char-set cursor) as in the reference implementation, and an ; inversion-list cursor otherwise. (define (char-set-cursor cset) (let ((simple-cursor (simple-cset-cursor-next (char-set-simple cset) *simple-cset-boundary*))) (if (end-of-simple-cset? simple-cursor) (inversion-list-cursor (char-set-i-list cset)) simple-cursor))) (define (end-of-char-set? cursor) (and (inversion-list-cursor? cursor) (inversion-list-cursor-at-end? cursor))) (define (char-set-ref cset cursor) (if (number? cursor) (simple-cset-cursor-ref cursor) (scalar-value->char (inversion-list-cursor-ref cursor)))) (define (char-set-cursor-next cset cursor) (cond ((number? cursor) (let ((next (simple-cset-cursor-next (char-set-simple cset) cursor))) (if (end-of-simple-cset? next) (inversion-list-cursor (char-set-i-list cset)) next))) (else (inversion-list-cursor-next (char-set-i-list cset) cursor)))) (define (char-set-for-each proc cs) (simple-cset-for-each proc (char-set-simple cs)) (inversion-list-fold/done? (lambda (n _) (proc (scalar-value->char n)) (unspecific)) #f (lambda (_) #f) (char-set-i-list cs))) ; this is pretty inefficent (define (char-set-map proc cs) (let ((simple-cset (make-empty-simple-cset)) (other-scalar-values '())) (define (adjoin! c) (let ((c (proc c))) (if (simple-char? c) (simple-cset-adjoin! simple-cset c) (set! other-scalar-values (cons (char->scalar-value c) other-scalar-values))))) (char-set-for-each adjoin! cs) (make-char-set simple-cset (apply numbers->inversion-list *simple-cset-boundary* (+ 1 #x10ffff) other-scalar-values)))) (define (char-set-fold kons knil cs) (inversion-list-fold/done? (lambda (n v) (kons (scalar-value->char n) v)) (simple-cset-fold kons knil (char-set-simple cs)) (lambda (_) #f) (char-set-i-list cs))) (define (char-set-every pred cs) (and (simple-cset-every? pred (char-set-simple cs)) (inversion-list-fold/done? (lambda (n v) (and v (pred (scalar-value->char n)))) #t not (char-set-i-list cs)))) (define (char-set-any pred cs) (or (simple-cset-any pred (char-set-simple cs)) (inversion-list-fold/done? (lambda (n v) (or v (pred (scalar-value->char n)))) #f values (char-set-i-list cs)))) (define (base-char-set maybe-base-cs) (if maybe-base-cs (char-set-copy maybe-base-cs) (make-empty-char-set))) (define char-set-unfold (opt-lambda (p f g seed (maybe-base-cs #f)) (char-set-unfold! p f g seed (base-char-set maybe-base-cs)))) (define (char-set-unfold! p f g seed base-cs) (let loop ((seed seed) (cs base-cs)) (if (p seed) cs ; P says we are done. (loop (g seed) ; Loop on (G SEED). (char-set-adjoin! cs (f seed)))))) ; Add (F SEED) to set. ; converting from and to lists (define (char-set . chars) (list->char-set chars)) (define list->char-set (opt-lambda (chars (maybe-base-cs #f)) (list->char-set! chars (base-char-set maybe-base-cs)))) (define (list->char-set! chars cs) (for-each (lambda (c) (char-set-adjoin! cs c)) chars) cs) (define (char-set->list cs) (char-set-fold cons '() cs)) ; converting to and from strings (define string->char-set (opt-lambda (str (maybe-base-cs #f)) (string->char-set! str (base-char-set maybe-base-cs)))) (define (string->char-set! str cs) (do ((i (- (string-length str) 1) (- i 1))) ((< i 0)) (char-set-adjoin! cs (string-ref str i))) cs) (define (char-set->string cs) (let ((ans (make-string (char-set-size cs)))) (char-set-fold (lambda (ch i) (string-set! ans i ch) (+ i 1)) 0 cs) ans)) (define ucs-range->char-set (opt-lambda (lower upper (error? #f) (maybe-base-cs #f)) (ucs-range->char-set! lower upper error? (base-char-set maybe-base-cs)))) (define (ucs-range->char-set! lower upper error? base-cs) (if (negative? lower) (assertion-violation 'ucs-range->char-set! "negative lower bound" lower)) (if (> lower #x10ffff) (assertion-violation 'ucs-range->char-set! "invalid lower bound" lower)) (if (negative? upper) (assertion-violation 'ucs-range->char-set! "negative upper bound" upper)) (if (> upper #x110000) (assertion-violation 'ucs-range->char-set! "invalid lower bound" upper)) (if (not (<= lower upper)) (assertion-violation 'ucs-range->char-set! "decreasing bounds" lower upper)) (let ((create-inversion-list (lambda (lower upper) (cond ((and (>= lower #xD800) (>= #xe000 upper)) (make-empty-inversion-list *simple-cset-boundary* (+ 1 #x10ffff))) ((<= upper #xe000) (range->inversion-list *simple-cset-boundary* (+ 1 #x10ffff) lower (min #xd800 upper))) ((>= lower #xd800) (range->inversion-list *simple-cset-boundary* (+ 1 #x10ffff) (max #xe000 lower) upper)) (else ;; hole (ranges->inversion-list *simple-cset-boundary* (+ 1 #x10ffff) (cons lower #xd800) (cons #xe000 upper))))))) (char-set-union! base-cs (cond ((>= lower *simple-cset-boundary*) (make-char-set (make-empty-simple-cset) (create-inversion-list lower upper))) ((< upper *simple-cset-boundary*) (make-char-set (ucs-range->simple-cset lower upper) (make-empty-inversion-list *simple-cset-boundary* (+ 1 #x10ffff)))) (else (make-char-set (ucs-range->simple-cset lower *simple-cset-boundary*) (create-inversion-list *simple-cset-boundary* upper))))))) (define char-set-filter (opt-lambda (predicate domain (maybe-base-cs #f)) (char-set-filter! predicate domain (base-char-set maybe-base-cs)))) (define (char-set-filter! predicate domain base-cs) (char-set-fold (lambda (ch _) (if (predicate ch) (char-set-adjoin! base-cs ch))) (unspecific) domain) base-cs) ; {string, char, char-set, char predicate} -> char-set ; This is called ->CHAR-SET in the SRFI, but that's not a valid R5RS ; identifier. (define (x->char-set x) (cond ((char-set? x) x) ((string? x) (string->char-set x)) ((char? x) (char-set x)) (else (assertion-violation 'x->char-set "Not a charset, string or char.")))) ; Set algebra (define *surrogate-complement-i-list* (inversion-list-complement (range->inversion-list *simple-cset-boundary* (+ 1 #x10ffff) #xd800 #xe000))) (define (char-set-complement cs) (make-char-set (simple-cset-complement (char-set-simple cs)) (inversion-list-intersection (inversion-list-complement (char-set-i-list cs)) *surrogate-complement-i-list*))) (define (char-set-complement! cs) (set-char-set-simple! cs (simple-cset-complement! (char-set-simple cs))) (set-char-set-i-list! cs (inversion-list-intersection (inversion-list-complement (char-set-i-list cs)) *surrogate-complement-i-list*)) cs) (define (make-char-set-op! simple-cset-op! inversion-list-op) (lambda (cset1 . csets) (set-char-set-simple! cset1 (apply simple-cset-op! (char-set-simple cset1) (map char-set-simple csets))) (set-char-set-i-list! cset1 (apply inversion-list-op (char-set-i-list cset1) (map char-set-i-list csets))) cset1)) (define (make-char-set-op char-set-op! make-neutral) (lambda csets (if (pair? csets) (apply char-set-op! (char-set-copy (car csets)) (cdr csets)) (make-neutral)))) (define char-set-union! (make-char-set-op! simple-cset-union! inversion-list-union)) (define char-set-union (make-char-set-op char-set-union! make-empty-char-set)) (define char-set-intersection! (make-char-set-op! simple-cset-intersection! inversion-list-intersection)) (define char-set-intersection (make-char-set-op char-set-intersection! make-full-char-set)) (define char-set-difference! (make-char-set-op! simple-cset-difference! inversion-list-difference)) (define (char-set-difference cset1 . csets) (apply char-set-difference! (char-set-copy cset1) csets)) ; copied from inversion-list.scm (define (binary->n-ary proc/2) (lambda (arg-1 . args) (if (and (pair? args) (null? (cdr args))) (proc/2 arg-1 (car args)) (let loop ((args args) (result arg-1)) (if (null? args) result (loop (cdr args) (proc/2 result (car args)))))))) (define inversion-list-xor (binary->n-ary (lambda (i-list-1 i-list-2) (inversion-list-union (inversion-list-intersection (inversion-list-complement i-list-1) i-list-2) (inversion-list-intersection i-list-1 (inversion-list-complement i-list-2)))))) ; Really inefficient for things outside Latin-1 ; WHO NEEDS THIS NONSENSE, ANYWAY? (define char-set-xor! (make-char-set-op! simple-cset-xor! inversion-list-xor)) (define char-set-xor (make-char-set-op char-set-xor! make-empty-char-set)) (define (char-set-diff+intersection! cs1 cs2 . csets) (call-with-values (lambda () (apply simple-cset-diff+intersection! (char-set-simple cs1) (char-set-simple cs2) (map char-set-simple csets))) (lambda (simple-diff simple-intersection) (set-char-set-simple! cs1 simple-diff) (set-char-set-simple! cs2 simple-intersection) (let ((i-list-1 (char-set-i-list cs1)) (i-list-2 (char-set-i-list cs2)) (i-list-rest (map char-set-i-list csets))) (set-char-set-i-list! cs1 (apply inversion-list-difference i-list-1 i-list-2 i-list-rest)) (set-char-set-i-list! cs2 (inversion-list-intersection i-list-1 (apply inversion-list-union i-list-2 i-list-rest))) (values cs1 cs2))))) (define (char-set-diff+intersection cs1 . csets) (apply char-set-diff+intersection! (char-set-copy cs1) (make-empty-char-set) csets)) ;; Byte vector utilities (define (byte-vector-copy b) (let* ((size (byte-vector-length b)) (result (make-byte-vector size 0))) (copy-bytes! b 0 result 0 size) result)) ;;; Apply P to each index and its char code in S: (P I VAL). ;;; Used by the set-algebra ops. (define (byte-vector-iter p s) (let loop ((i (- (byte-vector-length s) 1))) (if (>= i 0) (begin (p i (byte-vector-ref s i)) (loop (- i 1)))))) ;; Utility for srfi-14-base-char-sets.scm, which follows ; The range vector is an even-sized vector with [lower, upper) ; pairs. (define (range-vector->char-set range-vector) (let ((size (vector-length range-vector)) (simple-cset (make-empty-simple-cset))) (let loop ((index 0) (ranges '())) (if (>= index size) (make-char-set simple-cset (apply ranges->inversion-list *simple-cset-boundary* (+ 1 #x10ffff) ranges)) (let ((lower (vector-ref range-vector index)) (upper (vector-ref range-vector (+ 1 index)))) (define (fill-simple-cset! lower upper) (let loop ((scalar-value lower)) (if (< scalar-value upper) (begin (simple-cset-adjoin-code! simple-cset scalar-value) (loop (+ 1 scalar-value)))))) (cond ((>= lower *simple-cset-boundary*) (loop (+ 2 index) (cons (cons lower upper) ranges))) ((< upper *simple-cset-boundary*) (fill-simple-cset! lower upper) (loop (+ 2 index) ranges)) (else (fill-simple-cset! lower *simple-cset-boundary*) (loop (+ 2 index) (cons (cons *simple-cset-boundary* upper) ranges))))))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a14/unicode-data.scm000066400000000000000000001316341375154206600225100ustar00rootroot00000000000000; Part of Scheme 48 1.9. See file COPYING for notices and license. ; Authors: Mike Sperber ; Copyright (c) 2005-2006 by Basis Technology Corporation. ; Parse UnicodeData.txt and various other files from the Unicode ; consortium, and generate character classification and conversion ; tables from it. (define (string-split string at) (let ((count (string-length string))) (let loop ((index 0) (rev-result '())) (cond ((>= index count) (reverse (cons "" rev-result))) ((string-index string at index) => (lambda (found) (loop (+ 1 found) (cons (substring string index found) rev-result)))) (else (reverse (cons (substring string index count) rev-result))))))) (define (split-unicode-data-record line) (string-split line #\;)) (define (maybe-code-point text default) (if (zero? (string-length text)) default (string->number text 16))) (define-record-type code-point-info :code-point-info (make-code-point-info code-point name general-category combining-class bidirectional-category-id canonical-decomposition compatibility-decomposition decimal-digit-value digit-value numeric-value mirrored? unicode-1.0-name iso-10646-comment uppercase-code-point lowercase-code-point titlecase-code-point) code-point-info? ;; number (code-point code-point-info-code-point) ;; string (name code-point-info-name) ;; :GENERAL-CATEGORY (general-category code-point-info-general-category) ;; number (combining-class code-point-info-combining-class) ;; symbol (bidirectional-category-id code-point-info-bidirectional-category-id) ;; #f or list (canonical-decomposition code-point-info-canonical-decomposition) (compatibility-decomposition code-point-info-compatibility-decomposition) ;; number (decimal-digit-value code-point-info-decimal-digit-value) ;; number (digit-value code-point-info-digit-value) ;; number (numeric-value code-point-info-numeric-value) ;; boolean (mirrored? code-point-info-mirrored?) ;; string (unicode-1.0-name code-point-info-unicode-1.0-name) ;; string (iso-10646-comment code-point-info-iso-10646-comment) ;; number (uppercase-code-point code-point-info-uppercase-code-point) ;; number (lowercase-code-point code-point-info-lowercase-code-point) ;; number (titlecase-code-point code-point-info-titlecase-code-point)) (define-record-discloser :code-point-info (lambda (r) (list 'code-point-info (code-point-info-code-point r) (code-point-info-name r) (code-point-info-general-category r) (code-point-info-combining-class r) (code-point-info-bidirectional-category-id r) (code-point-info-canonical-decomposition r) (code-point-info-compatibility-decomposition r) (code-point-info-decimal-digit-value r) (code-point-info-digit-value r) (code-point-info-numeric-value r) (code-point-info-mirrored? r) (code-point-info-unicode-1.0-name r) (code-point-info-iso-10646-comment r) (code-point-info-uppercase-code-point r) (code-point-info-lowercase-code-point r) (code-point-info-titlecase-code-point r)))) (define (unicode-data-record->info line) (destructure (((code-point-hex name general-category-id combining-class-id bidirectional-category-text decomposition-text decimal-digit-value-text digit-value-text numeric-value-text mirrored-y/n unicode-1.0-name iso-10646-comment uppercase-code-point-hex lowercase-code-point-hex titlecase-code-point-hex) (split-unicode-data-record line))) (let ((code-point (maybe-code-point code-point-hex #f))) (let ((uppercase-code-point (maybe-code-point uppercase-code-point-hex code-point)) (lowercase-code-point (maybe-code-point lowercase-code-point-hex code-point)) (titlecase-code-point (maybe-code-point titlecase-code-point-hex code-point)) (decomposition (parse-decomposition decomposition-text))) (make-code-point-info code-point name (id->general-category general-category-id) (string->number combining-class-id) (string->symbol bidirectional-category-text) (and (and (pair? decomposition) (number? (car decomposition))) decomposition) (and (and (pair? decomposition) (symbol? (car decomposition))) (cdr decomposition)) (string->number decimal-digit-value-text) (string->number digit-value-text) (string->number numeric-value-text) (string=? mirrored-y/n "Y") unicode-1.0-name iso-10646-comment uppercase-code-point lowercase-code-point titlecase-code-point))))) ;; return #f or a list, which contains the scalar values of the decompositon ;; for compatibility decompositions, the tag is prepended as a symbol (define (parse-decomposition d) (cond ((zero? (string-length d)) #f) ((char=? #\< (string-ref d 0)) (let ((after (string-index d #\space))) (cons (string->symbol (substring d 0 after)) (call-with-values (lambda () (parse-scalar-values d after)) (lambda (l i) l))))) (else (call-with-values (lambda () (parse-scalar-values d 0)) (lambda (l i) l))))) ; for EXPANDED-CODE-POINT-INFO-SOURCE (define (code-point-info-with-code-point+name info code-point name) (make-code-point-info code-point name (code-point-info-general-category info) (code-point-info-combining-class info) (code-point-info-bidirectional-category-id info) (code-point-info-canonical-decomposition info) (code-point-info-compatibility-decomposition info) (code-point-info-decimal-digit-value info) (code-point-info-digit-value info) (code-point-info-numeric-value info) (code-point-info-mirrored? info) (code-point-info-unicode-1.0-name info) (code-point-info-iso-10646-comment info) code-point code-point code-point)) ; kludge ; expand the code-point ranges that look like this: ; 3400;;Lo;0;L;;;;;N;;;;; ; 4DB5;;Lo;0;L;;;;;N;;;;; ; returns a thunk that returns the infos from consecutive calls, ; then #f (define (expanded-code-point-info-source infos) (let ((first-info #f) (code-point #f) (last-code-point #f) (name-base #f)) (lambda () (let again () (cond (first-info (if (<= code-point last-code-point) (begin (set! code-point (+ 1 code-point)) (code-point-info-with-code-point+name first-info (- code-point 1) name-base)) ; kludge for speed; should be: ; (string-append name-base (number->string code-point 16)) (begin (set! first-info #f) (again)))) ((null? infos) #f) (else (let* ((info (car infos)) (name (code-point-info-name info))) (cond ((and (string-prefix? "<" name) (string-suffix? ", First>" name)) (set! first-info info) (set! code-point (code-point-info-code-point info)) (set! last-code-point (code-point-info-code-point (cadr infos))) (set! name-base (string-append (substring name 1 ; (string-length "<") (- (string-length name) 8 ; (string-length ", First>") )) "-")) ; kludge, see above (set! infos (cddr infos)) (again)) (else (set! infos (cdr infos)) info))))))))) (define (for-each-expanded-code-point-info proc infos) (let ((source (expanded-code-point-info-source infos))) (let loop () (let ((info (source))) (if info (begin (proc info) (loop))))))) (define (read-line port) (let loop ((l '())) (let ((c (read-char port))) (if (eof-object? c) c (if (char=? c #\newline) (list->string (reverse l)) (loop (cons c l))))))) (define (parse-unicode-data filename) (call-with-input-file filename (lambda (port) (let loop ((rev-infos '())) (let ((thing (read-line port))) (if (eof-object? thing) (reverse rev-infos) (loop (cons (unicode-data-record->info thing) rev-infos)))))))) ; Mapping the relevant info (general category + case mappings) into a ; compact array (define (mapping-offsets infos accessor) (let loop ((infos infos) (offsets '())) (if (null? infos) (list->vector offsets) (let* ((info (car infos)) (code-point (code-point-info-code-point info)) (other (accessor info)) (offset (- other code-point))) (if (member offset offsets) (loop (cdr infos) offsets) (loop (cdr infos) (cons offset offsets))))))) (define (vector-index vector value) (let ((count (vector-length vector))) (let loop ((i 0)) (cond ((>= i count) #f) ((equal? value (vector-ref vector i)) i) (else (loop (+ 1 i))))))) (define (code-point-info->case+general-category-encoding info specialcasing? special-lowercase-table special-uppercase-table uppercase-offsets lowercase-offsets titlecase-offsets uppercase-index-width lowercase-index-width titlecase-index-width) (let ((code-point (code-point-info-code-point info))) (let ((uppercase-index (vector-index uppercase-offsets (- (code-point-info-uppercase-code-point info) code-point))) (lowercase-index (vector-index lowercase-offsets (- (code-point-info-lowercase-code-point info) code-point))) (titlecase-index (vector-index titlecase-offsets (- (code-point-info-titlecase-code-point info) code-point))) (uppercase? (or (eq? (general-category uppercase-letter) (code-point-info-general-category info)) (table-ref special-uppercase-table code-point))) (lowercase? (or (eq? (general-category lowercase-letter) (code-point-info-general-category info)) (table-ref special-lowercase-table code-point)))) (bitwise-ior (arithmetic-shift (bitwise-ior (arithmetic-shift (bitwise-ior (arithmetic-shift (bitwise-ior (arithmetic-shift (bitwise-ior (if specialcasing? 4 0) (if uppercase? 2 0) (if lowercase? 1 0)) uppercase-index-width) uppercase-index) lowercase-index-width) lowercase-index) titlecase-index-width) titlecase-index) *general-category-bits*) (general-category-index (code-point-info-general-category info)))))) (define (code-point-encoding-uppercase? encoding uppercase-index-width lowercase-index-width titlecase-index-width) (not (zero? (bitwise-and 1 (arithmetic-shift encoding (- (+ 1 uppercase-index-width lowercase-index-width titlecase-index-width *general-category-bits*))))))) (define (code-point-encoding-lowercase? encoding uppercase-index-width lowercase-index-width titlecase-index-width) (not (zero? (bitwise-and 1 (arithmetic-shift encoding (- (+ uppercase-index-width lowercase-index-width titlecase-index-width *general-category-bits*))))))) (define (lookup-by-offset-index code-point offset-index offsets) (+ code-point (vector-ref offsets offset-index))) (define (code-point-encoding-uppercase-code-point code-point encoding uppercase-offsets uppercase-index-width lowercase-index-width titlecase-index-width) (lookup-by-offset-index code-point (bitwise-and (- (arithmetic-shift 1 uppercase-index-width) 1) (arithmetic-shift encoding (- (+ lowercase-index-width titlecase-index-width *general-category-bits*)))) uppercase-offsets)) (define (code-point-encoding-lowercase-code-point code-point encoding lowercase-offsets uppercase-index-width lowercase-index-width titlecase-index-width) (lookup-by-offset-index code-point (bitwise-and (- (arithmetic-shift 1 lowercase-index-width) 1) (arithmetic-shift encoding (- (+ titlecase-index-width *general-category-bits*)))) lowercase-offsets)) (define (code-point-encoding-titlecase-code-point code-point encoding titlecase-offsets uppercase-index-width lowercase-index-width titlecase-index-width) (lookup-by-offset-index code-point (bitwise-and (- (arithmetic-shift 1 titlecase-index-width) 1) (arithmetic-shift encoding (- *general-category-bits*))) titlecase-offsets)) (define *code-point-encoding-general-category-mask* (- (arithmetic-shift 1 *general-category-bits*) 1)) (define (code-point-encoding-general-category encoding) (vector-ref general-categories (bitwise-and encoding *code-point-encoding-general-category-mask*))) (define (max-code-point infos) (let loop ((max 0) (infos infos)) (cond ((null? infos) max) ((> (code-point-info-code-point (car infos)) max) (loop (code-point-info-code-point (car infos)) (cdr infos))) (else (loop max (cdr infos)))))) ; returns a THUNK that will return for each code-point in sequence ; (PROC ) or DEFAULT if there's no info. ; assumes INFOS are sorted (define (make-consecutive-info-source source make-default proc) (let ((next-info #f) (last-code-point -1)) (lambda () (define (upto info) (if (< last-code-point (code-point-info-code-point info)) (begin (set! next-info info) (proc (make-default last-code-point))) (begin (set! next-info #f) ;; scalar values only (if (eq? (code-point-info-general-category info) (general-category surrogate)) (proc (make-default last-code-point)) (proc info))))) (set! last-code-point (+ 1 last-code-point)) (cond ((or next-info (source)) => upto) (else #f))))) ; Dealing with PropList.txt (define (parse-proplist-for-upper/lowercase filename) (call-with-input-file filename (lambda (port) (let ((uppercase (make-integer-table)) (lowercase (make-integer-table))) (let loop () (let ((thing (read-line port))) (if (eof-object? thing) (values uppercase lowercase) (call-with-values (lambda () (extract-upper/lowercase thing)) (lambda (uppers lowers) (for-each (lambda (u) (table-set! uppercase u #t)) uppers) (for-each (lambda (l) (table-set! lowercase l #t)) lowers) (loop)))))))))) (define (extract-upper/lowercase line) (cond ((string-prefix? "#" line) (values '() '())) ((string-contains line "Other_Uppercase") (values (proplist-line-range line) '())) ((string-contains line "Other_Lowercase") (values '() (proplist-line-range line))) (else (values '() '())))) (define (proplist-line-range line) (let* ((i1 (string-skip line char-set:hex-digit)) (first (string->number (substring line 0 i1) 16))) (if (char=? #\. (string-ref line i1)) (let* ((i2 (string-skip line #\. i1)) (i3 (string-skip line char-set:hex-digit i2)) (last (string->number (substring line i2 i3) 16))) (let loop ((last last) (range '())) (if (= last first) (cons last range) (loop (- last 1) (cons last range))))) (list first)))) ; assumes START points to whitespace or the first digit ; returns list of scalar values + position after sequence ; (possibly after trailing semicolon) (define (parse-scalar-values s start) (let ((size (string-length s))) (let loop ((start start) (rev-values '())) (let ((i1 (string-skip s char-set:whitespace start))) (cond ((not i1) (values (reverse rev-values) (+ start 1))) ((char=? #\; (string-ref s i1)) (values (reverse rev-values) (+ i1 1))) (else (let* ((i2 (or (string-skip s char-set:hex-digit i1) size)) (n (string->number (substring s i1 i2) 16))) (loop i2 (cons n rev-values))))))))) (define-record-type specialcasing :specialcasing (make-specialcasing scalar-value lowercase titlecase uppercase foldcase final-sigma?) specialcasing? (scalar-value specialcasing-scalar-value) (lowercase specialcasing-lowercase) (titlecase specialcasing-titlecase) (uppercase specialcasing-uppercase) ;; This will actually come from CaseFolding.txt (foldcase specialcasing-foldcase set-specialcasing-foldcase!) (final-sigma? specialcasing-final-sigma?)) (define (parse-specialcasing-line line) (let* ((i1 (string-skip line char-set:hex-digit 0)) (n (string->number (substring line 0 i1) 16))) (call-with-values (lambda () (parse-scalar-values line (+ 1 i1))) (lambda (lowercase i2) (call-with-values (lambda () (parse-scalar-values line i2)) (lambda (titlecase i3) (call-with-values (lambda () (parse-scalar-values line i3)) (lambda (uppercase i4) (let ((i5 (or (string-index line #\; (+ 1 i4)) (string-index line #\# (+ 1 i4)) (string-length line)))) (let ((conditions (string-trim-both (substring line i4 i5)))) (if (or (string=? "" conditions) (string=? "Final_Sigma" conditions)) (make-specialcasing n lowercase titlecase uppercase #f (string=? conditions "Final_Sigma")) #f))))))))))) (define (parse-specialcasing filename) (call-with-input-file filename (lambda (port) (let loop ((specialcasings '())) (let ((thing (read-line port))) (if (eof-object? thing) specialcasings (cond ((and (not (string=? "" thing)) (not (char=? #\# (string-ref thing 0))) (parse-specialcasing-line thing)) => (lambda (sc) (loop (cons sc specialcasings)))) (else (loop specialcasings))))))))) ; we only extract the common and full case foldings (define (parse-casefolding-line line) (let* ((i1 (string-skip line char-set:hex-digit 0)) (n (string->number (substring line 0 i1) 16)) (i2 (string-skip line char-set:whitespace (+ 1 i1))) (status (string-ref line i2))) (call-with-values (lambda () (parse-scalar-values line (+ 2 i2))) (lambda (scalar-values i) (cond ((or (char=? status #\C) (char=? status #\F)) (cons n (cons status scalar-values))) ((> (length scalar-values) 1) (error "multi-character common case-folding mapping")) (else #f)))))) (define (parse-casefolding filename) (call-with-input-file filename (lambda (port) (let loop ((casefoldings '())) (let ((thing (read-line port))) (cond ((eof-object? thing) casefoldings) ((and (not (string=? "" thing)) (not (char=? #\# (string-ref thing 0))) (parse-casefolding-line thing)) => (lambda (folding) (loop (cons folding casefoldings)))) (else (loop casefoldings)))))))) (define (merge-specialcasings+casefoldings! specialcasings casefoldings) (for-each (lambda (casefolding) (let ((sv (car casefolding)) (status (cadr casefolding)) (folding (cddr casefolding))) (cond ((find (lambda (specialcasing) (= (specialcasing-scalar-value specialcasing) sv)) specialcasings) => (lambda (specialcasing) (set-specialcasing-foldcase! specialcasing folding))) ((char=? status #\F) ; the others will be covered by UnicodeData.txt (let ((sv-list (list sv))) (set! specialcasings (cons (make-specialcasing sv sv-list sv-list sv-list folding #f) specialcasings))))))) casefoldings) specialcasings) (define (parse-specialcasing+casefolding specialcasing-filename casefolding-filename) (let ((specialcasings (parse-specialcasing specialcasing-filename)) (casefoldings (parse-casefolding casefolding-filename))) (merge-specialcasings+casefoldings! specialcasings casefoldings))) (define (list-prefix? l1 l2) (let loop ((l1 l1) (l2 l2)) (cond ((null? l1) #t) ((null? l2) #f) ((equal? (car l1) (car l2)) (loop (cdr l1) (cdr l2))) (else #f)))) ; We return two lists: a list of :SPECIALCASING records where the ; xxxCASE fields are replaced by (offset . length) pairs into the ; second list, which contains all the case mappings jumbled together. (define (specialcasing-encoding specialcasings) (let ((casings '())) (define (add-casing! l) (let loop ((rest casings) (index 0)) (cond ((null? rest) (set! casings (append casings l)) index) ((list-prefix? l rest) index) (else (loop (cdr rest) (+ 1 index)))))) (define (transform-specialcasing s) (let ((lowercase (cons (add-casing! (specialcasing-lowercase s)) (length (specialcasing-lowercase s)))) (titlecase (cons (add-casing! (specialcasing-titlecase s)) (length (specialcasing-titlecase s)))) (uppercase (cons (add-casing! (specialcasing-uppercase s)) (length (specialcasing-uppercase s)))) (foldcase (cons (add-casing! (specialcasing-foldcase s)) (length (specialcasing-foldcase s))))) (make-specialcasing (specialcasing-scalar-value s) lowercase titlecase uppercase foldcase (specialcasing-final-sigma? s)))) (let ((transformed (map transform-specialcasing specialcasings))) (values transformed casings)))) (define (specialcasing-encoding-ref casings offset size) (let loop ((i 0) (r '())) (if (>= i size) (reverse r) (loop (+ 1 i) (cons (vector-ref casings (+ offset i)) r))))) ; for testing (define (check-specialcasing-encodings specialcasings) (call-with-values (lambda () (specialcasing-encoding specialcasings)) (lambda (encodings casings) (let ((casings (list->vector casings))) (for-each (lambda (specialcasing encoding) (define (check select) (let ((pair (select encoding)) (reference (select specialcasing))) (if (not (equal? reference (specialcasing-encoding-ref casings (car pair) (cdr pair)))) (error "encoding failure" encoding reference (specialcasing-encoding-ref casings (car pair) (cdr pair)))))) (check specialcasing-lowercase) (check specialcasing-uppercase) (check specialcasing-titlecase) (check specialcasing-foldcase)) specialcasings encodings))))) (define (specialcasings->table specialcasings) (let ((table (make-integer-table))) (for-each (lambda (s) (table-set! table (specialcasing-scalar-value s) s)) specialcasings) table)) (define (make-scalar-value-case+general-category-encoding-tables infos special-lowercase-table special-uppercase-table specialcasings) (let ((uppercase-offsets (mapping-offsets infos code-point-info-uppercase-code-point)) (lowercase-offsets (mapping-offsets infos code-point-info-lowercase-code-point)) (titlecase-offsets (mapping-offsets infos code-point-info-titlecase-code-point))) (let ((uppercase-index-width (bits-necessary (vector-length uppercase-offsets))) (lowercase-index-width (bits-necessary (vector-length lowercase-offsets))) (titlecase-index-width (bits-necessary (vector-length titlecase-offsets))) (specialcasings-table (specialcasings->table specialcasings)) (block-size (expt 2 *block-bits*))) (call-with-values (lambda () (compute-compact-table (make-consecutive-info-source (expanded-code-point-info-source infos) (lambda (code-point) (make-code-point-info code-point "" (general-category unassigned) #f #f #f #f #f #f #f #f #f #f code-point code-point code-point)) (lambda (info) (code-point-info->case+general-category-encoding info (table-ref specialcasings-table (code-point-info-code-point info)) special-lowercase-table special-uppercase-table uppercase-offsets lowercase-offsets titlecase-offsets uppercase-index-width lowercase-index-width titlecase-index-width))) block-size)) (lambda (indices encodings) (values indices encodings uppercase-offsets lowercase-offsets titlecase-offsets)))))) ; saves a couple of kilobyes, but probably not worthwhile (define (write-vector-code/rll name vector port) (write `(define ,name (make-vector ,(vector-length vector))) port) (newline port) (let loop ((values (vector->list vector)) (index 0)) (cond ((null? values)) ((or (null? (cdr values)) (not (equal? (car values) (cadr values)))) (write `(vector-set! ,name ,index ,(car values)) port) (newline port) (loop (cdr values) (+ 1 index))) (else (let ((value (car values))) (let inner-loop ((values values) (last-index index)) (cond ((or (null? values) (not (equal? (car values) value))) (write `(do ((i ,index (+ 1 i))) ((>= i ,last-index)) (vector-set! ,name i ,value)) port) (newline port) (loop values last-index)) (else (inner-loop (cdr values) (+ 1 last-index)))))))))) (define (create-unicode-tables unicode-data-filename proplist-filename specialcasing-filename casefolding-filename composition-exclusions-filename category-output-file syntax-info-output-file normalization-output-file srfi-14-base-output-file) (let ((infos (parse-unicode-data unicode-data-filename)) (specialcasings (parse-specialcasing+casefolding specialcasing-filename casefolding-filename))) (call-with-values (lambda () (parse-proplist-for-upper/lowercase proplist-filename)) (lambda (special-uppercase-table special-lowercase-table) (call-with-output-file category-output-file (lambda (port) (display "; Automatically generated by WRITE-UNICODE-CATEGORY-TABLES; do not edit." port) (newline port) (newline port) (write-unicode-category-tables infos special-uppercase-table special-lowercase-table specialcasings port) (write-specialcasings-tables specialcasings port))) (call-with-output-file syntax-info-output-file (lambda (port) (display "; Automatically generated by WRITE-UNICODE-CATEGORY-TABLES; do not edit." port) (newline port) (newline port) (write-syntax-info infos port) (newline port))) (write-srfi-14-base-char-sets infos srfi-14-base-output-file) (call-with-output-file normalization-output-file (lambda (port) (display "; Automatically generated by WRITE-UNICODE-CATEGORY-TABLES; do not edit." port) (newline port) (newline port) (write-normalization-tables infos (parse-composition-exclusions composition-exclusions-filename) port))))))) (define *block-bits* 8) ; better than 9, at least (define (write-unicode-category-tables infos special-uppercase-table special-lowercase-table specialcasings port) (call-with-values (lambda () (make-scalar-value-case+general-category-encoding-tables infos special-lowercase-table special-uppercase-table specialcasings)) (lambda (indices encodings uppercase-offsets lowercase-offsets titlecase-offsets) (write `(define *encoding-table-block-bits* ,*block-bits*) port) (newline port) (newline port) (write `(define *uppercase-index-width* ,(bits-necessary (vector-length uppercase-offsets))) port) (newline port) (write `(define *lowercase-index-width* ,(bits-necessary (vector-length lowercase-offsets))) port) (newline port) (write `(define *titlecase-index-width* ,(bits-necessary (vector-length titlecase-offsets))) port) (newline port) (newline port) (write `(define *scalar-value-info-indices* ',indices) port) (newline port) (write `(define *scalar-value-info-encodings* ',encodings) port) (newline port) (newline port) (write `(define *uppercase-offsets* ',uppercase-offsets) port) (newline port) (write `(define *lowercase-offsets* ',lowercase-offsets) port) (newline port) (write `(define *titlecase-offsets* ',titlecase-offsets) port) (newline port) (newline port)))) (define (write-specialcasings-tables specialcasings port) (call-with-values (lambda () (specialcasing-encoding specialcasings)) (lambda (encodings casings) ;; we write it out here to avoid introducing yet another file ;; into the UNICODE-CHAR-MAPS package (write '(define-record-type specialcasing :specialcasing (make-specialcasing scalar-value lowercase-start lowercase-length titlecase-start titlecase-length uppercase-start uppercase-length foldcase-start foldcase-length final-sigma?) specialcasing? (scalar-value specialcasing-scalar-value) (lowercase-start specialcasing-lowercase-start) (lowercase-length specialcasing-lowercase-length) (titlecase-start specialcasing-titlecase-start) (titlecase-length specialcasing-titlecase-length) (uppercase-start specialcasing-uppercase-start) (uppercase-length specialcasing-uppercase-length) (foldcase-start specialcasing-foldcase-start) (foldcase-length specialcasing-foldcase-length) (final-sigma? specialcasing-final-sigma?)) port) (newline port) (newline port) (write `(define *specialcasing-table* (make-integer-table)) port) (newline port) (newline port) (for-each (lambda (c) (write `(table-set! *specialcasing-table* ,(specialcasing-scalar-value c) (make-specialcasing ,(specialcasing-scalar-value c) ,(car (specialcasing-lowercase c)) ,(cdr (specialcasing-lowercase c)) ,(car (specialcasing-titlecase c)) ,(cdr (specialcasing-titlecase c)) ,(car (specialcasing-uppercase c)) ,(cdr (specialcasing-uppercase c)) ,(car (specialcasing-foldcase c)) ,(cdr (specialcasing-foldcase c)) ,(specialcasing-final-sigma? c))) port) (newline port)) encodings) (newline port) (write `(define *specialcasings* (list->string (map scalar-value->char ',casings))) port) (newline port) (newline port)))) ;; Read syntax (define (write-syntax-info infos port) (write `(define *non-symbol-constituents-above-127* ',(list->vector (non-symbol-constituents-above-127 infos))) port) (newline port) (newline port) (write `(define *whitespaces* ',(list->vector (whitespaces infos))) port) (newline port)) (define *symbol-constituent-general-categories* (list (general-category uppercase-letter) (general-category lowercase-letter) (general-category titlecase-letter) (general-category modified-letter) (general-category other-letter) (general-category non-spacing-mark) (general-category combining-spacing-mark) (general-category enclosing-mark) (general-category decimal-digit-number) (general-category letter-number) (general-category other-number) (general-category dash-punctuation) (general-category connector-punctuation) (general-category other-punctuation) (general-category currency-symbol) (general-category mathematical-symbol) (general-category modifier-symbol) (general-category other-symbol) (general-category private-use-character))) (define (symbol-constituent-above-127? info) (memq (code-point-info-general-category info) *symbol-constituent-general-categories*)) (define (non-symbol-constituents-above-127 infos) (let ((reverse-non-constituents '())) (for-each-expanded-code-point-info (lambda (info) (let ((cp (code-point-info-code-point info))) (if (and (> cp 127) (not (eq? (general-category surrogate) (code-point-info-general-category info))) (not (symbol-constituent-above-127? info))) (set! reverse-non-constituents (cons cp reverse-non-constituents))))) infos) (reverse reverse-non-constituents))) (define (whitespaces infos) (let ((reverse-whitespaces '())) (for-each-expanded-code-point-info (lambda (info) (if (eq? (general-category-primary-category (code-point-info-general-category info)) (primary-category separator)) (set! reverse-whitespaces (cons (code-point-info-code-point info) reverse-whitespaces)))) infos) (sort-list (append '(#x009 #x00a #x00b #x00c #x00d #x085) reverse-whitespaces) <))) (define (write-srfi-14-base-char-sets infos output-file) (call-with-output-file output-file (lambda (port) (display "; Automatically generated by WRITE-SRFI-14-BASE-CHAR-SETS; do not edit." port) (newline port) (newline port) (let-syntax ((general-category-predicate (syntax-rules () ((general-category-predicate ?name) (lambda (info) (eq? (code-point-info-general-category info) (general-category ?name)))))) (primary-category-predicate (syntax-rules () ((primary-category-predicate ?name) (lambda (info) (eq? (general-category-primary-category (code-point-info-general-category info)) (primary-category ?name))))))) (write-srfi-14-base-char-set-definition 'char-set:lower-case srfi-14-lower-case? infos port) (write-srfi-14-base-char-set-definition 'char-set:upper-case srfi-14-upper-case? infos port) (write-srfi-14-base-char-set-definition 'char-set:title-case (general-category-predicate titlecase-letter) infos port) (write-srfi-14-base-char-set-definition 'char-set:letter (primary-category-predicate letter) infos port) (write-srfi-14-base-char-set-definition 'char-set:digit (general-category-predicate decimal-digit-number) infos port) (write-srfi-14-base-char-set-definition 'char-set:mark (primary-category-predicate mark) infos port) (write-srfi-14-base-char-set-definition 'char-set:separator (primary-category-predicate separator) infos port) (write-srfi-14-base-char-set-definition 'char-set:punctuation (primary-category-predicate punctuation) infos port) (write-srfi-14-base-char-set-definition 'char-set:symbol (primary-category-predicate symbol) infos port) (write-srfi-14-base-char-set-definition 'char-set:space-separator (general-category-predicate space-separator) infos port))))) ; SRFI 14 has funny notions of lower case and upper case (define (srfi-14-lower-case? info) (let ((cp (code-point-info-code-point info))) (and (not (and (>= cp #x2000) (<= cp #x2fff))) (= cp (code-point-info-lowercase-code-point info)) (or (not (= cp (code-point-info-uppercase-code-point info))) (string-contains (code-point-info-name info) "SMALL LETTER") (string-contains (code-point-info-name info) "SMALL LIGATURE"))))) (define (srfi-14-upper-case? info) (let ((cp (code-point-info-code-point info))) (and (not (and (>= cp #x2000) (<= cp #x2fff))) (= cp (code-point-info-uppercase-code-point info)) (or (not (= cp (code-point-info-lowercase-code-point info))) (string-contains (code-point-info-name info) "CAPITAL LETTER") (string-contains (code-point-info-name info) "CAPITAL LIGATURE"))))) (define (write-srfi-14-base-char-set-definition name pred infos port) (write (srfi-14-base-char-set-definition name pred infos) port) (newline port)) (define (ranges->range-vector ranges) (let* ((range-count (length ranges)) (range-vector (make-vector (* 2 (length ranges))))) (let loop ((i 0) (ranges ranges)) (if (< i range-count) (begin (vector-set! range-vector (* 2 i) (caar ranges)) (vector-set! range-vector (+ 1 (* 2 i)) (cdar ranges)) (loop (+ 1 i) (cdr ranges))))) range-vector)) (define (srfi-14-base-char-set-definition name pred infos) (let ((accumulator (make-ranges-accumulator pred))) (for-each-expanded-code-point-info accumulator infos) `(define ,name (range-vector->char-set ',(ranges->range-vector (accumulator 'ranges)))))) (define (make-ranges-accumulator pred) (let ((rev-ranges '()) (current-left #f) (current-right #f)) ;; assumes the characters arrive with ascending scalar values (lambda (message) (cond ((not (code-point-info? message)) (if current-left (reverse (cons (cons current-left current-right) rev-ranges)) (reverse rev-ranges))) ((pred message) (let ((scalar-value (code-point-info-code-point message))) (cond ((not current-left) (set! current-left scalar-value) (set! current-right (+ 1 scalar-value))) ((= scalar-value current-right) (set! current-right (+ 1 current-right))) (else (set! rev-ranges (cons (cons current-left current-right) rev-ranges)) (set! current-left scalar-value) (set! current-right (+ 1 scalar-value)))))))))) (define (write-normalization-tables infos excluded port) (call-with-values (lambda () (make-normalization-encoding-tables infos)) (lambda (indices encodings) (write `(define *normalization-info-block-bits* ,*block-bits*) port) (newline port) (write `(define *normalization-info-indices* ',indices) port) (newline port) (write `(define *normalization-info-encodings* ',encodings) port) (newline port))) (newline port) (let ((canonical-pairs (canonical-decomposition-pairs infos))) (write `(define *canonical-decomposition-scalar-values* ',(list->vector (map car canonical-pairs))) port) (newline port) (write `(define *canonical-decompositions* ',(list->vector (map cdr canonical-pairs))) port) (newline port)) (newline port) (call-with-values (lambda () (compatibility-decomposition-tables infos)) (lambda (decompositions scalar-values indices) (write `(define *compatibility-decompositions* ',decompositions) port) (newline port) (write `(define *compatibility-scalar-values* ',scalar-values) port) (newline port) (write `(define *compatibility-indices* ',indices) port) (newline port))) (newline port) (let ((composition-pairs (composition-pairs infos excluded))) (write `(define *composition-scalar-values* ',(list->vector (map car composition-pairs))) port) (newline port) (write `(define *composition-encodings* ',(list->vector (map cdr composition-pairs))) port) (newline port))) (define (parse-composition-exclusions filename) (call-with-input-file filename (lambda (port) (let loop ((exclusions '())) (let ((thing (read-line port))) (cond ((eof-object? thing) exclusions) ((and (not (string=? "" thing)) (not (char=? #\# (string-ref thing 0)))) (let ((end (or (string-skip thing char-set:hex-digit) (string-length thing)))) (loop (cons (string->number (substring thing 0 end) 16) exclusions)))) (else (loop exclusions)))))))) (define (make-normalization-encoding-tables infos) (compute-compact-table (make-consecutive-info-source (expanded-code-point-info-source infos) (lambda (code-point) (make-code-point-info code-point "" (general-category unassigned) 0 #f #f #f #f #f #f #f #f #f code-point code-point code-point)) (lambda (info) (bitwise-ior (code-point-info-combining-class info) ; 0..240 (if (code-point-info-canonical-decomposition info) #x100 0) (if (code-point-info-compatibility-decomposition info) #x200 0)))) (expt 2 *block-bits*))) (define (encode-canonical-decomposition l) (cond ((null? (cdr l)) (if (> (car l) #xffff) l (car l))) (else (let ((a (car l)) (b (cadr l))) (if (or (> a #xffff) (> b #xffff)) (cons a b) (bitwise-ior (arithmetic-shift b 16) a)))))) ;; generate an alist that maps scalar values to decomposition encodings (define (canonical-decomposition-pairs infos) (let ((pairs '())) (for-each-expanded-code-point-info (lambda (info) (cond ((code-point-info-canonical-decomposition info) => (lambda (d) (set! pairs (cons (cons (code-point-info-code-point info) (encode-canonical-decomposition d)) pairs)))))) infos) (reverse pairs))) (define (compatibility-decomposition-tables infos) (let ((reverse-decomps '()) (decomp-index 0) (rev-infos '())) (for-each-expanded-code-point-info (lambda (info) (cond ((code-point-info-compatibility-decomposition info) => (lambda (d) (let ((size (length d))) (set! reverse-decomps (append (reverse d) reverse-decomps)) (set! rev-infos (cons (cons (code-point-info-code-point info) decomp-index) rev-infos)) (set! decomp-index (+ decomp-index size))))))) infos) (let ((decomps (list->vector (reverse reverse-decomps)))) (values decomps (list->vector (map car (reverse rev-infos))) (list->vector (map cdr (reverse (cons (cons #f (vector-length decomps)) rev-infos)))))))) (define (composition-pairs infos excluded) (let ((pairs '())) (for-each-expanded-code-point-info (lambda (info) (cond ((code-point-info-canonical-decomposition info) => (lambda (d) (if (and (pair? (cdr d)) ; not a singleton (not (member (code-point-info-code-point info) excluded)) (code-point-info-combining-class (find-code-point-info (car d) infos))) ; possibly expensive (set! pairs (cons (cons (code-point-info-code-point info) (encode-composition d)) pairs))))))) infos) (sort-list pairs (lambda (p1 p2) (< (cdr p1) (cdr p2)))))) (define (encode-composition l) (if (or (> (car l) #xffff) (> (cadr l) #xffff)) (error "non-BMP composition")) (bitwise-ior (arithmetic-shift (cadr l) 16) (car l))) ; for debugging (define (test-code-point-case+general-category-encoding-tables infos special-uppercase-table special-lowercase-table specialcasings indices encodings uppercase-offsets lowercase-offsets titlecase-offsets) (let ((lower-mask (- (arithmetic-shift 1 *block-bits*) 1)) (uppercase-index-width (bits-necessary (vector-length uppercase-offsets))) (lowercase-index-width (bits-necessary (vector-length lowercase-offsets))) (titlecase-index-width (bits-necessary (vector-length titlecase-offsets)))) (for-each-expanded-code-point-info (lambda (info) (let* ((code-point (code-point-info-code-point info)) (base-index (vector-ref indices (arithmetic-shift code-point (- *block-bits*)))) (index (+ base-index (bitwise-and code-point lower-mask))) (encoding (vector-ref encodings index))) (if (not (eq? (code-point-info-general-category info) (general-category surrogate))) (begin (if (not (eq? (code-point-info-general-category info) (code-point-encoding-general-category encoding))) (error "general category mismatch" info (code-point-encoding-general-category encoding))) (let ((uppercase-code-point (code-point-encoding-uppercase-code-point code-point encoding uppercase-offsets uppercase-index-width lowercase-index-width titlecase-index-width)) (lowercase-code-point (code-point-encoding-lowercase-code-point code-point encoding lowercase-offsets uppercase-index-width lowercase-index-width titlecase-index-width)) (titlecase-code-point (code-point-encoding-titlecase-code-point code-point encoding titlecase-offsets uppercase-index-width lowercase-index-width titlecase-index-width)) (uppercase? (code-point-encoding-uppercase? encoding uppercase-index-width lowercase-index-width titlecase-index-width)) (lowercase? (code-point-encoding-lowercase? encoding uppercase-index-width lowercase-index-width titlecase-index-width))) (if (not (= (code-point-info-uppercase-code-point info) uppercase-code-point)) (error "uppercase mismatch" info uppercase-code-point)) (if (not (= (code-point-info-lowercase-code-point info) lowercase-code-point)) (error "lowercase mismatch" info lowercase-code-point)) (if (not (= (code-point-info-titlecase-code-point info) titlecase-code-point)) (error "titlecase mismatch" info titlecase-code-point)) (if (not (eq? (or (table-ref special-uppercase-table code-point) (eq? (code-point-info-general-category info) (general-category uppercase-letter))) uppercase?)) (error "uppercase? mismatch" info code-point)) (if (not (eq? (or (table-ref special-lowercase-table code-point) (eq? (code-point-info-general-category info) (general-category lowercase-letter))) lowercase?)) (error "lowercase? mismatch" info code-point)) ))))) infos))) (define (check-unicode-tables unicode-data-filename proplist-filename specialcasing-filename) (let ((infos (parse-unicode-data unicode-data-filename)) (specialcasings (parse-specialcasing specialcasing-filename))) (call-with-values (lambda () (parse-proplist-for-upper/lowercase proplist-filename)) (lambda (special-uppercase-table special-lowercase-table) (call-with-values (lambda () (make-scalar-value-case+general-category-encoding-tables infos special-lowercase-table special-uppercase-table specialcasings)) (lambda (indices encodings uppercase-offsets lowercase-offsets titlecase-offsets) (test-code-point-case+general-category-encoding-tables infos special-uppercase-table special-lowercase-table specialcasings indices encodings uppercase-offsets lowercase-offsets titlecase-offsets))))))) (define (find-code-point-info code-point infos) (call-with-current-continuation (lambda (return) (for-each-expanded-code-point-info (lambda (info) (if (= code-point (code-point-info-code-point info)) (return info))) infos)))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a141.sls000066400000000000000000000005531375154206600202460ustar00rootroot00000000000000(library (srfi :141) (export ceiling/ ceiling-quotient ceiling-remainder floor/ floor-quotient floor-remainder truncate/ truncate-quotient truncate-remainder round/ round-quotient round-remainder euclidean/ euclidean-quotient euclidean-remainder balanced/ balanced-quotient balanced-remainder) (import (srfi :141 integer-division))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a141/000077500000000000000000000000001375154206600175205ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a141/integer-division.sls000066400000000000000000000007021375154206600235210ustar00rootroot00000000000000(library (srfi :141 integer-division) (export ceiling/ ceiling-quotient ceiling-remainder floor/ floor-quotient floor-remainder truncate/ truncate-quotient truncate-remainder round/ round-quotient round-remainder euclidean/ euclidean-quotient euclidean-remainder balanced/ balanced-quotient balanced-remainder) (import (rnrs) (rnrs r5rs) (srfi private include)) (include/resolve ("srfi" "%3a141") "srfi-141-impl.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a141/srfi-141-impl.scm000066400000000000000000000244371375154206600224430ustar00rootroot00000000000000 ;;; -*- Mode: Scheme -*- ;;;; Integer Division Operators ;;; Given a QUOTIENT and REMAINDER defined for nonnegative numerators ;;; and positive denominators implementing the truncated, floored, or ;;; Euclidean integer division, this implements a number of other ;;; integer division operators. ;;; Copyright (c) 2010--2011 Taylor R. Campbell ;;; All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; 1. Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; 2. Redistributions in binary form must reproduce the above copyright ;;; notice, this list of conditions and the following disclaimer in the ;;; documentation and/or other materials provided with the distribution. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF ;;; SUCH DAMAGE. ;;;; Shims ;;; SRFI-8 (define-syntax receive (syntax-rules () ((receive formals expression body ...) (call-with-values (lambda () expression) (lambda formals body ...))))) ;;; exact-integer? (define (exact-integer? x) (and (integer? x) (exact? x))) ;;;; Integer Division ;;;; Ceiling (define (ceiling/ n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (ceiling-/- n d)) ((negative? n) (let ((n (- 0 n))) (values (- 0 (quotient n d)) (- 0 (remainder n d))))) ((negative? d) (let ((d (- 0 d))) (values (- 0 (quotient n d)) (remainder n d)))) (else (ceiling+/+ n d))) (let ((q (ceiling (/ n d)))) (values q (- n (* d q)))))) (define (ceiling-/- n d) (let ((n (- 0 n)) (d (- 0 d))) (let ((q (quotient n d)) (r (remainder n d))) (if (zero? r) (values q r) (values (+ q 1) (- d r)))))) (define (ceiling+/+ n d) (let ((q (quotient n d)) (r (remainder n d))) (if (zero? r) (values q r) (values (+ q 1) (- r d))))) (define (ceiling-quotient n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (receive (q r) (ceiling-/- n d) r q)) ((negative? n) (- 0 (quotient (- 0 n) d))) ((negative? d) (- 0 (quotient n (- 0 d)))) (else (receive (q r) (ceiling+/+ n d) r q))) (ceiling (/ n d)))) (define (ceiling-remainder n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (receive (q r) (ceiling-/- n d) q r)) ((negative? n) (- 0 (remainder (- 0 n) d))) ((negative? d) (remainder n (- 0 d))) (else (receive (q r) (ceiling+/+ n d) q r))) (- n (* d (ceiling (/ n d)))))) ;;;; Euclidean Division ;;; 0 <= r < |d| (define (euclidean/ n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (ceiling-/- n d)) ((negative? n) (floor-/+ n d)) ((negative? d) (let ((d (- 0 d))) (values (- 0 (quotient n d)) (remainder n d)))) (else (values (quotient n d) (remainder n d)))) (let ((q (if (negative? d) (ceiling (/ n d)) (floor (/ n d))))) (values q (- n (* d q)))))) (define (euclidean-quotient n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (receive (q r) (ceiling-/- n d) r q)) ((negative? n) (receive (q r) (floor-/+ n d) r q)) ((negative? d) (- 0 (quotient n (- 0 d)))) (else (quotient n d))) (if (negative? d) (ceiling (/ n d)) (floor (/ n d))))) (define (euclidean-remainder n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (receive (q r) (ceiling-/- n d) q r)) ((negative? n) (receive (q r) (floor-/+ n d) q r)) ((negative? d) (remainder n (- 0 d))) (else (remainder n d))) (- n (* d (if (negative? d) (ceiling (/ n d)) (floor (/ n d))))))) ;;;; Floor (define (floor/ n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (let ((n (- 0 n)) (d (- 0 d))) (values (quotient n d) (- 0 (remainder n d))))) ((negative? n) (floor-/+ n d)) ((negative? d) (floor+/- n d)) (else (values (quotient n d) (remainder n d)))) (let ((q (floor (/ n d)))) (values q (- n (* d q)))))) (define (floor-/+ n d) (let ((n (- 0 n))) (let ((q (quotient n d)) (r (remainder n d))) (if (zero? r) (values (- 0 q) r) (values (- (- 0 q) 1) (- d r)))))) (define (floor+/- n d) (let ((d (- 0 d))) (let ((q (quotient n d)) (r (remainder n d))) (if (zero? r) (values (- 0 q) r) (values (- (- 0 q) 1) (- r d)))))) (define (floor-quotient n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (quotient (- 0 n) (- 0 d))) ((negative? n) (receive (q r) (floor-/+ n d) r q)) ((negative? d) (receive (q r) (floor+/- n d) r q)) (else (quotient n d))) (floor (/ n d)))) (define (floor-remainder n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (- 0 (remainder (- 0 n) (- 0 d)))) ((negative? n) (receive (q r) (floor-/+ n d) q r)) ((negative? d) (receive (q r) (floor+/- n d) q r)) (else (remainder n d))) (- n (* d (floor (/ n d)))))) ;;;; Round Ties to Even (define (round/ n d) (define (divide n d adjust leave) (let ((q (quotient n d)) (r (remainder n d))) (if (and (not (zero? r)) (or (and (odd? q) (even? d) (divisible? n (quotient d 2))) (< d (* 2 r)))) (adjust (+ q 1) (- r d)) (leave q r)))) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (divide (- 0 n) (- 0 d) (lambda (q r) (values q (- 0 r))) (lambda (q r) (values q (- 0 r))))) ((negative? n) (divide (- 0 n) d (lambda (q r) (values (- 0 q) (- 0 r))) (lambda (q r) (values (- 0 q) (- 0 r))))) ((negative? d) (divide n (- 0 d) (lambda (q r) (values (- 0 q) r)) (lambda (q r) (values (- 0 q) r)))) (else (let ((return (lambda (q r) (values q r)))) (divide n d return return)))) (let ((q (round (/ n d)))) (values q (- n (* d q)))))) (define (divisible? n d) ;; This operation admits a faster implementation than the one given ;; here. (zero? (remainder n d))) (define (round-quotient n d) (if (and (exact-integer? n) (exact-integer? d)) (receive (q r) (round/ n d) r ;ignore q) (round (/ n d)))) (define (round-remainder n d) (if (and (exact-integer? n) (exact-integer? d)) (receive (q r) (round/ n d) q ;ignore r) (- n (* d (round (/ n d)))))) ;;;; Truncate (define (truncate/ n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (let ((n (- 0 n)) (d (- 0 d))) (values (quotient n d) (- 0 (remainder n d))))) ((negative? n) (let ((n (- 0 n))) (values (- 0 (quotient n d)) (- 0 (remainder n d))))) ((negative? d) (let ((d (- 0 d))) (values (- 0 (quotient n d)) (remainder n d)))) (else (values (quotient n d) (remainder n d)))) (let ((q (truncate (/ n d)))) (values q (- n (* d q)))))) (define (truncate-quotient n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (quotient (- 0 n) (- 0 d))) ((negative? n) (- 0 (quotient (- 0 n) d))) ((negative? d) (- 0 (quotient n (- 0 d)))) (else (quotient n d))) (truncate (/ n d)))) (define (truncate-remainder n d) (if (and (exact-integer? n) (exact-integer? d)) (cond ((and (negative? n) (negative? d)) (- 0 (remainder (- 0 n) (- 0 d)))) ((negative? n) (- 0 (remainder (- 0 n) d))) ((negative? d) (remainder n (- 0 d))) (else (remainder n d))) (- n (* d (truncate (/ n d)))))) ;;; Copyright 2015 William D Clinger. ;;; ;;; Permission to copy this software, in whole or in part, to use this ;;; software for any lawful purpose, and to redistribute this software ;;; is granted subject to the restriction that all copies made of this ;;; software must include this copyright and permission notice in full. ;;; ;;; I also request that you send me a copy of any improvements that you ;;; make to this software so that they may be incorporated within it to ;;; the benefit of the Scheme community. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (balanced/ x y) (call-with-values (lambda () (euclidean/ x y)) (lambda (q r) (cond ((< r (abs (/ y 2))) (values q r)) ((> y 0) (values (+ q 1) (- x (* (+ q 1) y)))) (else (values (- q 1) (- x (* (- q 1) y)))))))) (define (balanced-quotient x y) (call-with-values (lambda () (balanced/ x y)) (lambda (q r) q))) (define (balanced-remainder x y) (call-with-values (lambda () (balanced/ x y)) (lambda (q r) r))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a143.sls000066400000000000000000000032171375154206600202500ustar00rootroot00000000000000;; SRFI-143 r6rs library entry ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to ;; deal in the Software without restriction, including without limitation the ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or ;; sell copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. (library (srfi :143) (export fx-width fx-greatest fx-least fixnum? fx=? fx? fx<=? fx>=? fxzero? fxpositive? fxnegative? fxodd? fxeven? fxmax fxmin fx+ fx- fxneg fx* fxquotient fxremainder fxabs fxsquare fxsqrt fx+/carry fx-/carry fx*/carry fxnot fxand fxior fxxor fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right fxbit-count fxlength fxif fxbit-set? fxcopy-bit fxfirst-set-bit fxbit-field fxbit-field-rotate fxbit-field-reverse) (import (srfi :143 fixnums))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a143/000077500000000000000000000000001375154206600175225ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a143/fixnums.sls000066400000000000000000000025651375154206600217460ustar00rootroot00000000000000;; SRFI-143 r6rs library implementation ;; ;; Implements the fixnum operators specified in SRFI-143 using a combination of ;; R6RS sepcified version and Chez Scheme provided operators where R6RS does ;; not include them. These are in the helpers library and non-Chez Scheme ;; versions are included for supporting other R6RS implementations. ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep (library (srfi :143 fixnums) (export fx-width fx-greatest fx-least fixnum? fx=? fx? fx<=? fx>=? fxzero? fxpositive? fxnegative? fxodd? fxeven? fxmax fxmin fx+ fx- fxneg fx* fxquotient fxremainder fxabs fxsquare fxsqrt fx+/carry fx-/carry fx*/carry fxnot fxand fxior fxxor fxarithmetic-shift fxarithmetic-shift-left fxarithmetic-shift-right fxbit-count fxlength fxif fxbit-set? fxcopy-bit fxfirst-set-bit fxbit-field fxbit-field-rotate fxbit-field-reverse) (import (rnrs) (srfi :143 helpers)) (define fx-width (fixnum-width)) (define fx-greatest (greatest-fixnum)) (define fx-least (least-fixnum)) (define fxneg (lambda (i) (fx- i))) (define fxsquare (lambda (i) (fx* i i))) (define fxsqrt (lambda (i) (exact-integer-sqrt i))) (define fxfirst-set-bit (lambda (i) (fxfirst-bit-set i))) (define fxbit-field-rotate (lambda (i c s e) (fxrotate-bit-field i s e c))) (define fxbit-field-reverse (lambda (i s e) (fxreverse-bit-field i s e)))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a143/helpers.chezscheme.sls000066400000000000000000000004541375154206600240270ustar00rootroot00000000000000;; SRFI-143 Chez Scheme helper implementation ;; ;; Imports the fxabs, fxremainder, and fxquotient procedures from Chez Scheme ;; for the SRFI-143 functions. ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep (library (srfi :143 helpers) (export fxabs fxremainder fxquotient) (import (chezscheme))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a143/helpers.sls000066400000000000000000000007671375154206600217210ustar00rootroot00000000000000;; SRFI-143 r6rs helper implementation ;; ;; Implemnts the fxabs, fxremainder, and fxquotient procedures for the SRFI-143 ;; functions, using the provided r6rs generics or simple functions. ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep (library (srfi :143 helpers) (export fxabs fxremainder fxquotient) (import (rnrs) (rnrs r5rs)) (define fxabs (lambda (i) (if (fxlist list->bits bits->vector vector->bits bits bitwise-fold bitwise-for-each bitwise-unfold make-bitwise-generator) (import (srfi :151 bitwise-operations))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a151/000077500000000000000000000000001375154206600175215ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a151/bitwise-operations.sls000066400000000000000000000202461375154206600240770ustar00rootroot00000000000000;; SRFI-151 r6rs library implementation ;; ;; The following contains a combination of R6RS implementation along with ;; implementations pulled from the SRFI-151 implementation. ;; ;; The R6RS wrappers and simple functions are: ;; Copyright (c) 2018 - 2020 Andrew W. Keep ;; ;; The bitwise-eqv implementation is based on the Olin Shiver's SRFI-33 ;; implementation from the SRFI-151 example library: ;; Olin Shivers is the sole author of this code, and he has placed it in the ;; public domain. ;; ;; The bitwise-fold, bitwise-for-each, bitwise-unfold, and ;; make-bitwise-generator functions are pulled from John Cowan's SRFI-151 ;; implementation and are: ;; Copyright John Cowan 2017 (library (srfi :151 bitwise-operations) (export bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-eqv bitwise-nand bitwise-nor bitwise-andc1 bitwise-andc2 bitwise-orc1 bitwise-orc2 arithmetic-shift bit-count integer-length bitwise-if bit-set? copy-bit bit-swap any-bit-set? every-bit-set? first-set-bit bit-field bit-field-any? bit-field-every? bit-field-clear bit-field-set bit-field-replace bit-field-replace-same bit-field-rotate bit-field-reverse bits->list list->bits bits->vector vector->bits bits bitwise-fold bitwise-for-each bitwise-unfold make-bitwise-generator) (import (rnrs)) ;;; The bitwise-eqv implmentation is based on the one in the SRFI-151 ;;; implementation, which extracted it from the SRFI-33 implementation which ;;; carried the following copyright information: ;;; ;;; Olin Shivers is the sole author of this code, and he has placed it in ;;; the public domain. ;;; ;;; A good implementation might choose to provide direct compiler/interpreter ;;; support for these derived functions, or might simply define them to be ;;; integrable -- i.e., inline-expanded. ;;; ;;; This is a general definition, but less than efficient. It should also ;;; receive primitive compiler/interpreter support so that the expensive ;;; n-ary mechanism is not invoked in the standard cases -- that is, ;;; an application of BITWISE-EQV should be rewritten into an equivalent ;;; tree applying some two-argument primitive to the arguments, in the ;;; same manner that statically-known n-ary applications of associative ;;; operations such as + and * are handled efficiently: ;;; (bitwise-eqv) => -1 ;;; (bitwise-eqv i) => i ;;; (bitwise-eqv i j) => (%bitwise-eqv i j) ;;; (bitwise-eqv i j k) => (%bitwise-eqv (%bitwise-eqv i j) k) ;;; (bitwise-eqv i j k l) => (%bitwise-eqv (%bitwise-eqv (%bitwise-eqv i j) k) l) ;;; ;;; Note: this implementation takes the advice of the comment avove and ;;; implemets this using case lambade, though Chez Scheme's source optimizer ;;; is relied upon to produce the constants. (define bitwise-eqv (case-lambda [() (bitwise-not (bitwise-xor))] [(i) (bitwise-not (bitwise-xor i))] [(i j) (bitwise-not (bitwise-xor i j))] [(i . more) (let loop ([i i] [more more]) (if (null? more) i (loop (bitwise-not (bitwise-xor i (car more))) (cdr more))))])) (define bitwise-nand (lambda (i j) (bitwise-not (bitwise-and i j)))) (define bitwise-nor (lambda (i j) (bitwise-not (bitwise-ior i j)))) (define bitwise-andc1 (lambda (i j) (bitwise-and (bitwise-not i) j))) (define bitwise-andc2 (lambda (i j) (bitwise-and i (bitwise-not j)))) (define bitwise-orc1 (lambda (i j) (bitwise-ior (bitwise-not i) j))) (define bitwise-orc2 (lambda (i j) (bitwise-ior i (bitwise-not j)))) (define arithmetic-shift (lambda (i c) (bitwise-arithmetic-shift i c))) (define bit-count (lambda (i) (if (< i 0) (bitwise-bit-count (bitwise-not i)) (bitwise-bit-count i)))) (define integer-length (lambda (i) (bitwise-length i))) (define bit-set? (lambda (index i) (bitwise-bit-set? i index))) (define copy-bit (lambda (index i bool) (bitwise-copy-bit i index (if bool 1 0)))) (define bit-swap (lambda (idx1 idx2 i) (if (bitwise-bit-set? i idx1) (if (bitwise-bit-set? i idx2) i (bitwise-copy-bit (bitwise-copy-bit i idx2 1) idx1 0)) (if (bitwise-bit-set? i idx2) (bitwise-copy-bit (bitwise-copy-bit i idx2 0) idx1 1) i)))) (define any-bit-set? (lambda (bits i) (not (zero? (bitwise-and bits i))))) (define every-bit-set? (lambda (bits i) (= (bitwise-and bits i) bits))) (define first-set-bit (lambda (i) (bitwise-first-bit-set i))) (define bit-field (lambda (i s e) (bitwise-bit-field i s e))) (define bit-field-any? (lambda (i s e) (not (zero? (bitwise-bit-field i s e))))) (define bit-field-every? (lambda (i s e) (= (bitwise-bit-field i s e) (- (expt 2 (- e s)) 1)))) (define bit-field-clear (lambda (i s e) (bitwise-copy-bit-field i s e 0))) (define bit-field-set (lambda (i s e) (bitwise-copy-bit-field i s e -1))) (define bit-field-replace (lambda (dest src s e) (bitwise-copy-bit-field dest s e src))) (define bit-field-replace-same (lambda (dest src s e) (bitwise-copy-bit-field dest s e (bitwise-bit-field src s e)))) (define bit-field-rotate (lambda (i count start end) (if (negative? count) (bitwise-rotate-bit-field i start end (fx+ count (fx- end start))) (bitwise-rotate-bit-field i start end count)))) (define bit-field-reverse (lambda (i start end) (bitwise-reverse-bit-field i start end))) (define bits->list (case-lambda [(i) (if (< i 0) (bits->list i (integer-length i)) (let f ([i i]) (if (zero? i) '() (cons (odd? i) (f (bitwise-arithmetic-shift-right i 1))))))] [(i n) (let loop ([n n] [ls '()]) (if (fx=? n 0) ls (let ([n (fx- n 1)]) (loop n (cons (bitwise-bit-set? i n) ls)))))])) (define bits->vector (case-lambda [(i) (if (< i 0) (bits->vector i (integer-length i)) (let f ([i i] [c 0]) (if (fx=? i 0) (make-vector c) (let ([v (f (bitwise-arithmetic-shift-right i 1) (fx+ c 1))]) (vector-set! v c (odd? i))))))] [(i n) (let ([v (make-vector n)]) (let loop ([n n]) (unless (fx=? n 0) (let ([n (fx- n 1)]) (vector-set! v n (bitwise-bit-set? i n)) (loop n)))) v)])) (define list->bits (lambda (ls) (let loop ([ls ls] [idx 0] [i 0]) (if (null? ls) i (loop (cdr ls) (fx+ idx 1) (bitwise-copy-bit i idx (if (car ls) 1 0))))))) (define vector->bits (lambda (v) (let loop ([n (vector-length v)] [i 0]) (if (fx=? n 0) i (let ([n (fx- n 1)]) (loop n (bitwise-copy-bit i n (if (vector-ref v n) 1 0)))))))) (define bits (lambda args (list->bits args))) ;; ---- from SRFI-151 other --- ;; The following functions: bitwise-fold, bitwise-for-each, bitwise-unfold, ;; and make-bitwise-generator are taken from John Cowan's implemtation ;; functions from the SRFI-151. ;; ;; Copyright John Cowan 2017 ;; (define bitwise-fold (lambda (proc seed i) (let ([n (integer-length i)]) (let loop ([idx 0] [r seed]) (if (fx=? idx n) r (loop (fx+ idx 1) (proc (bitwise-bit-set? i idx) r))))))) (define bitwise-for-each (lambda (proc i) (let ([n (integer-length i)]) (let loop ([idx 0]) (unless (fx=? idx n) (proc (bitwise-bit-set? i idx)) (loop (fx+ idx 1))))))) (define bitwise-unfold (lambda (stop? mapper successor seed) (do ([state seed (successor state)] [idx 0 (fx+ idx 1)] [i 0 (bitwise-copy-bit i idx (if (mapper state) 1 0))]) ((stop? state) i)))) (define make-bitwise-generator (lambda (i) (let ([idx 0]) (lambda () (let ([r (bitwise-bit-set? i idx)]) (set! idx (fx+ idx 1)) r))))) ;; ---- END from SRFI-151 other --- ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a152.sls000066400000000000000000000027241375154206600202520ustar00rootroot00000000000000(library (srfi :152) (export ;; Predicates string? string-null? string-every string-any ;; Constructors make-string string string-tabulate string-unfold string-unfold-right ;; Conversion string->vector string->list vector->string list->string reverse-list->string ;; Selection string-length string-ref substring string-copy string-take string-take-right string-drop string-drop-right string-pad string-pad-right string-trim string-trim-right string-trim-both ;; Replacement string-replace ;; Comparision string=? string-ci=? string? string-ci>? string<=? string-ci<=? string>=? string-ci>=? ;; Prefixes and suffixes string-prefix-length string-suffix-length string-prefix? string-suffix? ;; Searching string-index string-index-right string-skip string-skip-right string-contains string-contains-right string-take-while string-take-while-right string-drop-while string-drop-while-right string-break string-span ;; Concatenation string-append string-concatenate string-concatenate-reverse string-join ;; Fold and map and friends string-fold string-fold-right string-map string-for-each string-count string-filter string-remove ;; Replication and splitting string-replicate string-segment string-split ;; Input-output read-string write-string ;; Mutation string-set! string-fill! string-copy!) (import (srfi :152 strings))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a152/000077500000000000000000000000001375154206600175225ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a152/extend-comparisons.scm000066400000000000000000000017571375154206600240620ustar00rootroot00000000000000;;; Extend comparisons to 0 and 1 arguments. ;; 2017-10-04 Sudarshan S Chawathe ;; For each (name . base-name) pair in arguments, define name to be ;; comparison procedure similar to base-name, but allow it to accept 0 ;; or 1 arguments in addition to more (as permitted by base-name), ;; returning true in the former cases. (define-syntax define-comparison/base/pairs (syntax-rules () ((_ (name . base-name) ...) (begin (define (name . strs) (or (null? strs) (null? (cdr strs)) (apply base-name strs))) ...)))) ;; Extend the usual string comparison procedures as above. (define-comparison/base/pairs (string=? . base-string=?) (string? . base-string>?) (string<=? . base-string<=?) (string>=? . base-string>=?) (string-ci=? . base-string-ci=?) (string-ci? . base-string-ci>?) (string-ci<=? . base-string-ci<=?) (string-ci>=? . base-string-ci>=?)) ;;; chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a152/macros.scm000066400000000000000000000037161375154206600215210ustar00rootroot00000000000000;;;; Definitions of macros ;;; From SRFI 8 (define-syntax receive (syntax-rules () ((receive formals expression body ...) (call-with-values (lambda () expression) (lambda formals body ...))))) ;;; Shivers-compatible let-optionals* ;;; This version from Scheme-48 1.9.2, ;;; using error instead of assertion-violation (define-syntax let-optionals* (syntax-rules () ((let-optionals* arg (opt-clause ...) body ...) (let ((rest arg)) (%let-optionals* rest (opt-clause ...) body ...))))) (define-syntax %let-optionals* (syntax-rules () ((%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...) (call-with-values (lambda () (xparser arg)) (lambda (rest var ...) (%let-optionals* rest (opt-clause ...) body ...)))) ((%let-optionals* arg ((var default) opt-clause ...) body ...) (call-with-values (lambda () (if (null? arg) (values default '()) (values (car arg) (cdr arg)))) (lambda (var rest) (%let-optionals* rest (opt-clause ...) body ...)))) ((%let-optionals* arg ((var default test) opt-clause ...) body ...) (call-with-values (lambda () (if (null? arg) (values default '()) (let ((var (car arg))) (if test (values var (cdr arg)) (error "arg failed LET-OPT test" var))))) (lambda (var rest) (%let-optionals* rest (opt-clause ...) body ...)))) ((%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...) (call-with-values (lambda () (if (null? arg) (values default #f '()) (let ((var (car arg))) (if test (values var #t (cdr arg)) (error "arg failed LET-OPT test" var))))) (lambda (var supplied? rest) (%let-optionals* rest (opt-clause ...) body ...)))) ((%let-optionals* arg (rest) body ...) (let ((rest arg)) body ...)) ((%let-optionals* arg () body ...) (if (null? arg) (begin body ...) (error "Too many arguments in let-opt" arg))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a152/portable.scm000066400000000000000000001561251375154206600220500ustar00rootroot00000000000000;;; SRFI 130 string library reference implementation -*- Scheme -*- ;;; Olin Shivers 7/2000 ;;; John Cowan 4/2016 ;;; ;;; Copyright (c) 1988-1994 Massachusetts Institute of Technology. ;;; Copyright (c) 1998, 1999, 2000 Olin Shivers. ;;; Copyright (c) 2016 John Cowan. ;;; The details of the copyrights appear at the end of the file. Short ;;; summary: BSD-style open source. ;;; Imports ;;; This is a fairly large library. While it was written for portability, you ;;; must be aware of its dependencies in order to run it in a given scheme ;;; implementation. Here is a complete list of the dependencies it has and the ;;; assumptions it makes beyond stock R5RS Scheme: ;;; ;;; This code has the following non-R5RS dependencies: ;;; - (RECEIVE (var ...) mv-exp body ...) multiple-value binding macro; ;;; ;;; - An n-ary ERROR procedure; ;;; ;;; - A simple CHECK-ARG procedure for checking parameter values; it is ;;; Inserted here (define check-arg (lambda (pred val proc) (if (pred val) val (error "Bad arg" val pred proc)))) ;;; - LET-OPTIONALS* macro for parsing, defaulting & ;;; type-checking optional parameters from a rest argument; ;;; ;;; The code depends upon a small set of core string primitives from R5RS: ;;; MAKE-STRING STRING-REF STRING? STRING-LENGTH SUBSTRING ;;; (Actually, SUBSTRING is not a primitive, but we assume that an ;;; implementation's native version is probably faster than one we could ;;; define, so we import it from R5RS.) ;;; ;;; (define (add1 n) (+ 1 n)) ;;; Enough introductory blather. On to the source code. (But see the end of ;;; the file for further notes on porting & performance tuning.) ;;; Support for START/END substring specs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This macro parses optional start/end arguments from arg lists, defaulting ;;; them to 0/(string-length s), and checks them for correctness. (define-syntax let-string-start+end (syntax-rules () ((let-string-start+end (start end) proc s-exp args-exp body ...) (receive (start end) (string-parse-final-start+end proc s-exp args-exp) body ...)) ((let-string-start+end (start end rest) proc s-exp args-exp body ...) (receive (rest start end) (string-parse-start+end proc s-exp args-exp) body ...)))) ;;; This one parses out a *pair* of final start/end indices. ;;; Not exported; for internal use. (define-syntax let-string-start+end2 (syntax-rules () ((l-s-s+e2 (start1 end1 start2 end2) proc s1 s2 args body ...) (let ((procv proc)) ; Make sure PROC is only evaluated once. (let-string-start+end (start1 end1 rest) procv s1 args (let-string-start+end (start2 end2) procv s2 rest body ...)))))) ;;; Returns three values: rest start end (define (string-parse-start+end proc s args) (if (not (string? s)) (error "Non-string value" proc s)) (let ((slen (string-length s))) (if (pair? args) (let ((start (car args)) (args (cdr args))) (if (and (integer? start) (exact? start) (>= start 0)) (receive (end args) (if (pair? args) (let ((end (car args)) (args (cdr args))) (if (and (integer? end) (exact? end) (<= end slen)) (values end args) (error "Illegal substring END spec" proc end s))) (values slen args)) (if (<= start end) (values args start end) (error "Illegal substring START/END spec" proc start end s))) (error "Illegal substring START spec" proc start s))) (values '() 0 slen)))) (define (string-parse-final-start+end proc s args) (receive (rest start end) (string-parse-start+end proc s args) (if (pair? rest) (error "Extra arguments to procedure" proc rest) (values start end)))) (define (substring-spec-ok? s start end) (and (string? s) (integer? start) (exact? start) (integer? end) (exact? end) (<= 0 start) (<= start end) (<= end (string-length s)))) (define (check-substring-spec proc s start end) (if (not (substring-spec-ok? s start end)) (error "Illegal substring spec." proc s start end))) ;;; Defined by R5RS, so commented out here. ;(define (string . chars) ; (let* ((len (length chars)) ; (ans (make-string len))) ; (do ((i 0 (+ i 1)) ; (chars chars (cdr chars))) ; ((>= i len)) ; (string-set! ans i (car chars))) ; ans)) ; ;(define (string . chars) (string-unfold null? car cdr chars)) ;;; substring S START [END] ;;; string-copy S [START END] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; All this goop is just arg parsing & checking surrounding a call to the ;;; actual primitive, %SUBSTRING. ;;; Split out so that other routines in this library can avoid arg-parsing ;;; overhead for END parameter. (define (%substring s start end) (if (and (zero? start) (= end (string-length s))) s (substring s start end))) ;;; Basic iterators and other higher-order abstractions ;;; (string-fold kons knil s [start end]) ;;; (string-fold-right kons knil s [start end]) ;;; (string-unfold p f g seed [base make-final]) ;;; (string-unfold-right p f g seed [base make-final]) ;;; (string-for-each proc s [start end]) ;;; (string-every char/pred s [start end]) ;;; (string-any char/pred s [start end]) ;;; (string-tabulate proc len) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; You want compiler support for high-level transforms on fold and unfold ops. ;;; You'd at least like a lot of inlining for clients of these procedures. ;;; Don't hold your breath. (define (string-fold kons knil s . maybe-start+end) (check-arg procedure? kons string-fold) (let-string-start+end (start end) string-fold s maybe-start+end (let lp ((v knil) (i start)) (if (< i end) (lp (kons (string-ref s i) v) (+ i 1)) v)))) (define (string-fold-right kons knil s . maybe-start+end) (check-arg procedure? kons string-fold-right) (let-string-start+end (start end) string-fold-right s maybe-start+end (let lp ((v knil) (i (- end 1))) (if (>= i start) (lp (kons (string-ref s i) v) (- i 1)) v)))) ;;; (string-unfold p f g seed [base make-final]) ;;; This is the fundamental constructor for strings. ;;; - G is used to generate a series of "seed" values from the initial seed: ;;; SEED, (G SEED), (G^2 SEED), (G^3 SEED), ... ;;; - P tells us when to stop -- when it returns true when applied to one ;;; of these seed values. ;;; - F maps each seed value to the corresponding character ;;; in the result string. These chars are assembled into the ;;; string in a left-to-right order. ;;; - BASE is the optional initial/leftmost portion of the constructed string; ;;; it defaults to the empty string "". ;;; - MAKE-FINAL is applied to the terminal seed value (on which P returns ;;; true) to produce the final/rightmost portion of the constructed string. ;;; It defaults to (LAMBDA (X) ""). ;;; ;;; In other words, the following (simple, inefficient) definition holds: ;;; (define (string-unfold p f g seed base make-final) ;;; (string-append base ;;; (let recur ((seed seed)) ;;; (if (p seed) (make-final seed) ;;; (string-append (string (f seed)) ;;; (recur (g seed))))))) ;;; ;;; STRING-UNFOLD is a fairly powerful constructor -- you can use it to ;;; reverse a string, copy a string, convert a list to a string, read ;;; a port into a string, and so forth. Examples: ;;; (port->string port) = ;;; (string-unfold (compose eof-object? peek-char) ;;; read-char values port) ;;; ;;; (list->string lis) = (string-unfold null? car cdr lis) ;;; ;;; (tabulate-string f size) = (string-unfold (lambda (i) (= i size)) f add1 0) ;;; A problem with the following simple formulation is that it pushes one ;;; stack frame for every char in the result string -- an issue if you are ;;; using it to read a 100kchar string. So we don't use it -- but I include ;;; it to give a clear, straightforward description of what the function ;;; does. ;(define (string-unfold p f g seed base make-final) ; (let ((ans (let recur ((seed seed) (i (string-length base))) ; (if (p seed) ; (let* ((final (make-final seed)) ; (ans (make-string (+ i (string-length final))))) ; (string-copy! ans i final) ; ans) ; ; (let* ((c (f seed)) ; (s (recur (g seed) (+ i 1)))) ; (string-set! s i c) ; s))))) ; (string-copy! ans 0 base) ; ans)) ;;; The strategy is to allocate a series of chunks into which we stash the ;;; chars as we generate them. Chunk size goes up in powers of two starting ;;; with 40 and levelling out at 4k, i.e. ;;; 40 40 80 160 320 640 1280 2560 4096 4096 4096 4096 4096... ;;; This should work pretty well for short strings, 1-line (80 char) strings, ;;; and longer ones. When done, we allocate an answer string and copy the ;;; chars over from the chunk buffers. (define (string-unfold p f g seed . base+make-final) (check-arg procedure? p string-unfold) (check-arg procedure? f string-unfold) (check-arg procedure? g string-unfold) (let-optionals* base+make-final ((base "" (string? base)) (make-final (lambda (x) "") (procedure? make-final))) (let lp ((chunks '()) ; Previously filled chunks (nchars 0) ; Number of chars in CHUNKS (chunk (make-string 40)) ; Current chunk into which we write (chunk-len 40) (i 0) ; Number of chars written into CHUNK (seed seed)) (let lp2 ((i i) (seed seed)) (if (not (p seed)) (let ((c (f seed)) (seed (g seed))) (if (< i chunk-len) (begin (string-set! chunk i c) (lp2 (+ i 1) seed)) (let* ((nchars2 (+ chunk-len nchars)) (chunk-len2 (min 4096 nchars2)) (new-chunk (make-string chunk-len2))) (string-set! new-chunk 0 c) (lp (cons chunk chunks) (+ nchars chunk-len) new-chunk chunk-len2 1 seed)))) ;; We're done. Make the answer string & install the bits. (let* ((final (make-final seed)) (flen (string-length final)) (base-len (string-length base)) (j (+ base-len nchars i)) (ans (make-string (+ j flen)))) (%string-copy! ans j final 0 flen) ; Install FINAL. (let ((j (- j i))) (%string-copy! ans j chunk 0 i) ; Install CHUNK[0,I). (let lp ((j j) (chunks chunks)) ; Install CHUNKS. (if (pair? chunks) (let* ((chunk (car chunks)) (chunks (cdr chunks)) (chunk-len (string-length chunk)) (j (- j chunk-len))) (%string-copy! ans j chunk 0 chunk-len) (lp j chunks))))) (%string-copy! ans 0 base 0 base-len) ; Install BASE. ans)))))) (define (string-unfold-right p f g seed . base+make-final) (let-optionals* base+make-final ((base "" (string? base)) (make-final (lambda (x) "") (procedure? make-final))) (let lp ((chunks '()) ; Previously filled chunks (nchars 0) ; Number of chars in CHUNKS (chunk (make-string 40)) ; Current chunk into which we write (chunk-len 40) (i 40) ; Number of chars available in CHUNK (seed seed)) (let lp2 ((i i) (seed seed)) ; Fill up CHUNK from right (if (not (p seed)) ; to left. (let ((c (f seed)) (seed (g seed))) (if (> i 0) (let ((i (- i 1))) (string-set! chunk i c) (lp2 i seed)) (let* ((nchars2 (+ chunk-len nchars)) (chunk-len2 (min 4096 nchars2)) (new-chunk (make-string chunk-len2)) (i (- chunk-len2 1))) (string-set! new-chunk i c) (lp (cons chunk chunks) (+ nchars chunk-len) new-chunk chunk-len2 i seed)))) ;; We're done. Make the answer string & install the bits. (let* ((final (make-final seed)) (flen (string-length final)) (base-len (string-length base)) (chunk-used (- chunk-len i)) (j (+ base-len nchars chunk-used)) (ans (make-string (+ j flen)))) (%string-copy! ans 0 final 0 flen) ; Install FINAL. (%string-copy! ans flen chunk i chunk-len); Install CHUNK[I,). (let lp ((j (+ flen chunk-used)) ; Install CHUNKS. (chunks chunks)) (if (pair? chunks) (let* ((chunk (car chunks)) (chunks (cdr chunks)) (chunk-len (string-length chunk))) (%string-copy! ans j chunk 0 chunk-len) (lp (+ j chunk-len) chunks)) (%string-copy! ans j base 0 base-len))); Install BASE. ans)))))) (define (string-every criterion s . maybe-start+end) (let-string-start+end (start end) string-every s maybe-start+end (or (= start end) ; final (PRED S[END-1]) call (let lp ((i start)) ; is a tail call. (let ((c (string-ref s i)) (i1 (+ i 1))) (if (= i1 end) (criterion c) ; Tail call. (and (criterion c) (lp i1)))))))) (define (string-any criterion s . maybe-start+end) (let-string-start+end (start end) string-any s maybe-start+end (and (< start end) ; final (PRED S[END-1]) call (let lp ((i start)) ; is a tail call. (let ((c (string-ref s i)) (i1 (+ i 1))) (if (= i1 end) (criterion c) ; Tail call (or (criterion c) (lp i1)))))))) (define (string-tabulate proc len) (check-arg procedure? proc string-tabulate) (check-arg (lambda (val) (and (integer? val) (exact? val) (<= 0 val))) len string-tabulate) (let ((s (make-string len))) (do ((i (- len 1) (- i 1))) ((< i 0)) (string-set! s i (proc i))) s)) ;;; string-prefix-length s1 s2 [start1 end1 start2 end2] ;;; string-suffix-length s1 s2 [start1 end1 start2 end2] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Find the length of the common prefix/suffix. ;;; It is not required that the two substrings passed be of equal length. ;;; This was microcode in MIT Scheme -- a very tightly bummed primitive. ;;; %STRING-PREFIX-LENGTH is the core routine of all string-comparisons, ;;; so should be as tense as possible. (define (%string-prefix-length s1 start1 end1 s2 start2 end2) (let* ((delta (min (- end1 start1) (- end2 start2))) (end1 (+ start1 delta))) (if (and (eq? s1 s2) (= start1 start2)) ; EQ fast path delta (let lp ((i start1) (j start2)) ; Regular path (if (or (>= i end1) (not (char=? (string-ref s1 i) (string-ref s2 j)))) (- i start1) (lp (+ i 1) (+ j 1))))))) (define (%string-suffix-length s1 start1 end1 s2 start2 end2) (let* ((delta (min (- end1 start1) (- end2 start2))) (start1 (- end1 delta))) (if (and (eq? s1 s2) (= end1 end2)) ; EQ fast path delta (let lp ((i (- end1 1)) (j (- end2 1))) ; Regular path (if (or (< i start1) (not (char=? (string-ref s1 i) (string-ref s2 j)))) (- (- end1 i) 1) (lp (- i 1) (- j 1))))))) (define (string-prefix-length s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-prefix-length s1 s2 maybe-starts+ends (%string-prefix-length s1 start1 end1 s2 start2 end2))) (define (string-suffix-length s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-suffix-length s1 s2 maybe-starts+ends (%string-suffix-length s1 start1 end1 s2 start2 end2))) ;;; string-prefix? s1 s2 [start1 end1 start2 end2] ;;; string-suffix? s1 s2 [start1 end1 start2 end2] ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; These are all simple derivatives of the previous counting funs. (define (string-prefix? s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-prefix? s1 s2 maybe-starts+ends (%string-prefix? s1 start1 end1 s2 start2 end2))) (define (string-suffix? s1 s2 . maybe-starts+ends) (let-string-start+end2 (start1 end1 start2 end2) string-suffix? s1 s2 maybe-starts+ends (%string-suffix? s1 start1 end1 s2 start2 end2))) ;;; Here are the internal routines that do the real work. (define (%string-prefix? s1 start1 end1 s2 start2 end2) (let ((len1 (- end1 start1))) (and (<= len1 (- end2 start2)) ; Quick check (= (%string-prefix-length s1 start1 end1 s2 start2 end2) len1)))) (define (%string-suffix? s1 start1 end1 s2 start2 end2) (let ((len1 (- end1 start1))) (and (<= len1 (- end2 start2)) ; Quick check (= len1 (%string-suffix-length s1 start1 end1 s2 start2 end2))))) ;;; Cutting & pasting strings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; string-take string nchars ;;; string-drop string nchars ;;; ;;; string-take-right string nchars ;;; string-drop-right string nchars ;;; ;;; string-pad string k [char start end] ;;; string-pad-right string k [char start end] ;;; ;;; string-trim string [char/char-set/pred start end] ;;; string-trim-right string [char/char-set/pred start end] ;;; string-trim-both string [char/char-set/pred start end] ;;; ;;; These trimmers invert the char-set meaning from MIT Scheme -- you ;;; say what you want to trim. (define (string-take s n) (check-arg string? s string-take) (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n (string-length s)))) n string-take) (%substring s 0 n)) (define (string-take-right s n) (check-arg string? s string-take-right) (let ((len (string-length s))) (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len))) n string-take-right) (%substring s (- len n) len))) (define (string-drop s n) (check-arg string? s string-drop) (let ((len (string-length s))) (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len))) n string-drop) (%substring s n len))) (define (string-drop-right s n) (check-arg string? s string-drop-right) (let ((len (string-length s))) (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len))) n string-drop-right) (%substring s 0 (- len n)))) (define (string-trim s . criterion+start+end) (let-optionals* criterion+start+end ((criterion char-whitespace?) rest) (let-string-start+end (start end) string-trim s rest (cond ((string-skip s criterion start end) => (lambda (i) (%substring s i end))) (else ""))))) (define (string-trim-right s . criterion+start+end) (let-optionals* criterion+start+end ((criterion char-whitespace?) rest) (let-string-start+end (start end) string-trim-right s rest (cond ((string-skip-right s criterion start end) => (lambda (i) (%substring s start (+ 1 i)))) (else ""))))) (define (string-trim-both s . criterion+start+end) (let-optionals* criterion+start+end ((criterion char-whitespace?) rest) (let-string-start+end (start end) string-trim-both s rest (cond ((string-skip s criterion start end) => (lambda (i) (%substring s i (+ 1 (string-skip-right s criterion i end))))) (else ""))))) (define (string-pad-right s n . char+start+end) (let-optionals* char+start+end ((char #\space (char? char)) rest) (let-string-start+end (start end) string-pad-right s rest (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n))) n string-pad-right) (let ((len (- end start))) (if (<= n len) (%substring s start (+ start n)) (let ((ans (make-string n char))) (%string-copy! ans 0 s start end) ans)))))) (define (string-pad s n . char+start+end) (let-optionals* char+start+end ((char #\space (char? char)) rest) (let-string-start+end (start end) string-pad s rest (check-arg (lambda (n) (and (integer? n) (exact? n) (<= 0 n))) n string-pad) (let ((len (- end start))) (if (<= n len) (%substring s (- end n) end) (let ((ans (make-string n char))) (%string-copy! ans (- n len) s start end) ans)))))) ;;; Filtering strings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; string-remove char/pred string [start end] ;;; string-filter char/pred string [start end] ;;; ;;; If the criterion is a predicate, we don't do this double-scan strategy, ;;; because the predicate might have side-effects or be very expensive to ;;; compute. So we preallocate a temp buffer pessimistically, and only do ;;; one scan over S. This is likely to be faster and more space-efficient ;;; than consing a list. (define (string-remove criterion s . maybe-start+end) (let-string-start+end (start end) string-remove s maybe-start+end (let* ((slen (- end start)) (temp (make-string slen)) (ans-len (string-fold (lambda (c i) (if (criterion c) i (begin (string-set! temp i c) (+ i 1)))) 0 s start end))) (if (= ans-len slen) temp (substring temp 0 ans-len))))) (define (string-filter criterion s . maybe-start+end) (let-string-start+end (start end) string-filter s maybe-start+end (let* ((slen (- end start)) (temp (make-string slen)) (ans-len (string-fold (lambda (c i) (if (criterion c) (begin (string-set! temp i c) (+ i 1)) i)) 0 s start end))) (if (= ans-len slen) temp (substring temp 0 ans-len))))) ;;; String search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; string-index string char/pred [start end] ;;; string-index-right string char/pred [start end] ;;; string-skip string char/pred [start end] ;;; string-skip-right string char/pred [start end] ;;; string-count string char/pred [start end] ;;; There's a lot of replicated code here for efficiency. (define (string-index str criterion . maybe-start+end) (let-string-start+end (start end) string-index str maybe-start+end (let lp ((i start)) (and (< i end) (if (criterion (string-ref str i)) i (lp (+ i 1))))))) (define (string-index-right str criterion . maybe-start+end) (let-string-start+end (start end) string-index-right str maybe-start+end (let lp ((i (- end 1))) (and (>= i start) (if (criterion (string-ref str i)) i (lp (- i 1))))))) (define (string-skip str criterion . maybe-start+end) (let-string-start+end (start end) string-skip str maybe-start+end (let lp ((i start)) (and (< i end) (if (criterion (string-ref str i)) (lp (+ i 1)) i))))) (define (string-skip-right str criterion . maybe-start+end) (let-string-start+end (start end) string-skip-right str maybe-start+end (let lp ((i (- end 1))) (and (>= i start) (if (criterion (string-ref str i)) (lp (- i 1)) i))))) ;;; Useful hacks added for SRFI 152 (define (string-take-while s criterion . maybe-start+end) (let-string-start+end (start end) string-take-while s maybe-start+end (let ((idx (string-skip s criterion start end))) (if idx (%substring s 0 idx) "")))) (define (string-take-while-right s criterion . maybe-start+end) (let-string-start+end (start end) string-take-while s maybe-start+end (let ((idx (string-skip-right s criterion start end))) (if idx (%substring s (+ idx 1) (string-length s)) "")))) (define (string-drop-while s criterion . maybe-start+end) (let-string-start+end (start end) string-drop-while s maybe-start+end (let ((idx (string-skip s criterion start end))) (if idx (%substring s idx (string-length s)) s)))) (define (string-drop-while-right s criterion . maybe-start+end) (let-string-start+end (start end) string-drop-while s maybe-start+end (let ((idx (string-skip-right s criterion start end))) (if idx (%substring s 0 (+ idx 1)) s)))) (define (string-span s criterion . maybe-start+end) (let-string-start+end (start end) string-span s maybe-start+end (let ((idx (string-skip s criterion start end))) (if idx (values (%substring s 0 idx) (%substring s idx (string-length s))) (values "" s))))) (define (string-break s criterion . maybe-start+end) (let-string-start+end (start end) string-break s maybe-start+end (let ((idx (string-index s criterion start end))) (if idx (values (%substring s 0 idx) (%substring s idx (string-length s))) (values s ""))))) (define (string-count s criterion . maybe-start+end) (let-string-start+end (start end) string-count s maybe-start+end (do ((i start (+ i 1)) (count 0 (if (criterion (string-ref s i)) (+ count 1) count))) ((>= i end) count)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; %string-copy! to tstart from [fstart fend] ;;; Guaranteed to work, even if s1 eq s2. ;;; Library-internal routine (define (%string-copy! to tstart from fstart fend) (if (> fstart tstart) (do ((i fstart (+ i 1)) (j tstart (+ j 1))) ((>= i fend)) (string-set! to j (string-ref from i))) (do ((i (- fend 1) (- i 1)) (j (+ -1 tstart (- fend fstart)) (- j 1))) ((< i fstart)) (string-set! to j (string-ref from i))))) ;;; Returns starting-position in STRING or #f if not true. ;;; This implementation is slow & simple. It is useful as a "spec" or for ;;; comparison testing with fancier implementations. ;;; See below for fast KMP version. ;(define (string-contains string substring . maybe-starts+ends) ; (let-string-start+end2 (start1 end1 start2 end2) ; string-contains string substring maybe-starts+ends ; (let* ((len (- end2 start2)) ; (i-bound (- end1 len))) ; (let lp ((i start1)) ; (and (< i i-bound) ; (if (string= string substring i (+ i len) start2 end2) ; i ; (lp (+ i 1)))))))) ;;; Searching for an occurrence of a substring ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define (string-contains text pattern . maybe-starts+ends) (let-string-start+end2 (t-start t-end p-start p-end) string-contains text pattern maybe-starts+ends (%kmp-search pattern text char=? p-start p-end t-start t-end))) (define (string-contains-right text pattern . maybe-starts+ends) (let-string-start+end2 (t-start t-end p-start p-end) string-contains-right text pattern maybe-starts+ends (let* ((t-len (string-length text)) (p-len (string-length pattern)) (p-size (- p-end p-start)) (rt-start (- t-len t-end)) (rt-end (- t-len t-start)) (rp-start (- p-len p-end)) (rp-end (- p-len p-start)) (res (%kmp-search (string-reverse pattern) (string-reverse text) char=? rp-start rp-end rt-start rt-end))) (if res (- t-len res p-size) #f)))) ;;; Knuth-Morris-Pratt string searching ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; See ;;; "Fast pattern matching in strings" ;;; SIAM J. Computing 6(2):323-350 1977 ;;; D. E. Knuth, J. H. Morris and V. R. Pratt ;;; also described in ;;; "Pattern matching in strings" ;;; Alfred V. Aho ;;; Formal Language Theory - Perspectives and Open Problems ;;; Ronald V. Brook (editor) ;;; This algorithm is O(m + n) where m and n are the ;;; lengths of the pattern and string respectively ;;; KMP search source[start,end) for PATTERN. Return starting index of ;;; leftmost match or #f. (define (%kmp-search pattern text c= p-start p-end t-start t-end) (let ((plen (- p-end p-start)) (rv (make-kmp-restart-vector pattern c= p-start p-end))) ;; The search loop. TJ & PJ are redundant state. (let lp ((ti t-start) (pi 0) (tj (- t-end t-start)) ; (- tlen ti) -- how many chars left. (pj plen)) ; (- plen pi) -- how many chars left. (if (= pi plen) (- ti plen) ; Win. (and (<= pj tj) ; Lose. (if (c= (string-ref text ti) ; Search. (string-ref pattern (+ p-start pi))) (lp (+ 1 ti) (+ 1 pi) (- tj 1) (- pj 1)) ; Advance. (let ((pi (vector-ref rv pi))) ; Retreat. (if (= pi -1) (lp (+ ti 1) 0 (- tj 1) plen) ; Punt. (lp ti pi tj (- plen pi)))))))))) ;;; (make-kmp-restart-vector pattern [c= start end]) -> integer-vector ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Compute the KMP restart vector RV for string PATTERN. If ;;; we have matched chars 0..i-1 of PATTERN against a search string S, and ;;; PATTERN[i] doesn't match S[k], then reset i := RV[i], and try again to ;;; match S[k]. If RV[i] = -1, then punt S[k] completely, and move on to ;;; S[k+1] and PATTERN[0] -- no possible match of PAT[0..i] contains S[k]. ;;; ;;; In other words, if you have matched the first i chars of PATTERN, but ;;; the i+1'th char doesn't match, RV[i] tells you what the next-longest ;;; prefix of PATTERN is that you have matched. ;;; ;;; - C= (default CHAR=?) is used to compare characters for equality. ;;; Pass in CHAR-CI=? for case-folded string search. ;;; ;;; - START & END restrict the pattern to the indicated substring; the ;;; returned vector will be of length END - START. The numbers stored ;;; in the vector will be values in the range [0,END-START) -- that is, ;;; they are valid indices into the restart vector; you have to add START ;;; to them to use them as indices into PATTERN. ;;; ;;; I've split this out as a separate function in case other constant-string ;;; searchers might want to use it. ;;; ;;; E.g.: ;;; a b d a b x ;;; #(-1 0 0 -1 1 2) #;(define (make-kmp-restart-vector pattern . maybe-c=+start+end) (let-optionals* maybe-c=+start+end ((c= char=? (procedure? c=)) ((start end) (lambda (args) (string-parse-start+end make-kmp-restart-vector pattern args)))) (let* ((rvlen (- end start)) (rv (make-vector rvlen -1))) (if (> rvlen 0) (let ((rvlen-1 (- rvlen 1)) (c0 (string-ref pattern start))) ;; Here's the main loop. We have set rv[0] ... rv[i]. ;; K = I + START -- it is the corresponding index into PATTERN. (let lp1 ((i 0) (j -1) (k start)) (if (< i rvlen-1) ;; lp2 invariant: ;; pat[(k-j) .. k-1] matches pat[start .. start+j-1] ;; or j = -1. (let lp2 ((j j)) (cond ((= j -1) (let ((i1 (+ 1 i))) (if (not (c= (string-ref pattern (+ k 1)) c0)) (vector-set! rv i1 0)) (lp1 i1 0 (+ k 1)))) ;; pat[(k-j) .. k] matches pat[start..start+j]. ((c= (string-ref pattern k) (string-ref pattern (+ j start))) (let* ((i1 (+ 1 i)) (j1 (+ 1 j))) (vector-set! rv i1 j1) (lp1 i1 j1 (+ k 1)))) (else (lp2 (vector-ref rv j))))))))) rv))) (define (make-kmp-restart-vector pattern . maybe-c=+start+end) (let-optionals* maybe-c=+start+end ((c= char=?) rest) ; (procedure? c=)) (receive (rest2 start end) (string-parse-start+end make-kmp-restart-vector pattern rest) (let* ((rvlen (- end start)) (rv (make-vector rvlen -1))) (if (> rvlen 0) (let ((rvlen-1 (- rvlen 1)) (c0 (string-ref pattern start))) ;; Here's the main loop. We have set rv[0] ... rv[i]. ;; K = I + START -- it is the corresponding index into PATTERN. (let lp1 ((i 0) (j -1) (k start)) (if (< i rvlen-1) ;; lp2 invariant: ;; pat[(k-j) .. k-1] matches pat[start .. start+j-1] ;; or j = -1. (let lp2 ((j j)) (cond ((= j -1) (let ((i1 (+ i 1)) (ck+1 (string-ref pattern (add1 k)))) (vector-set! rv i1 (if (c= ck+1 c0) -1 0)) (lp1 i1 0 (+ k 1)))) ;; pat[(k-j) .. k] matches pat[start..start+j]. ((c= (string-ref pattern k) (string-ref pattern (+ j start))) (let* ((i1 (+ 1 i)) (j1 (+ 1 j))) (vector-set! rv i1 j1) (lp1 i1 j1 (+ k 1)))) (else (lp2 (vector-ref rv j))))))))) rv)))) ;;; We've matched I chars from PAT. C is the next char from the search string. ;;; Return the new I after handling C. ;;; ;;; The pattern is (VECTOR-LENGTH RV) chars long, beginning at index PAT-START ;;; in PAT (PAT-START is usually 0). The I chars of the pattern we've matched ;;; are ;;; PAT[PAT-START .. PAT-START + I]. ;;; ;;; It's *not* an oversight that there is no friendly error checking or ;;; defaulting of arguments. This is a low-level, inner-loop procedure ;;; that we want integrated/inlined into the point of call. (define (kmp-step pat rv c i c= p-start) (let lp ((i i)) (if (c= c (string-ref pat (+ i p-start))) ; Match => (+ i 1) ; Done. (let ((i (vector-ref rv i))) ; Back up in PAT. (if (= i -1) 0 ; Can't back up further. (lp i)))))) ; Keep trying for match. ;;; Zip through S[start,end), looking for a match of PAT. Assume we've ;;; already matched the first I chars of PAT when we commence at S[start]. ;;; - <0: If we find a match *ending* at index J, return -J. ;;; - >=0: If we get to the end of the S[start,end) span without finding ;;; a complete match, return the number of chars from PAT we'd matched ;;; when we ran off the end. ;;; ;;; This is useful for searching *across* buffers -- that is, when your ;;; input comes in chunks of text. We hand-integrate the KMP-STEP loop ;;; for speed. (define (string-kmp-partial-search pat rv s i . c=+p-start+s-start+s-end) ; (check-arg vector? rv string-kmp-partial-search) (let-optionals* c=+p-start+s-start+s-end ((c= char=?) ; (procedure? c=)) (p-start 0) rest) ; (and (integer? p-start) (exact? p-start) (<= 0 p-start))) (receive (rest2 s-start s-end) (string-parse-start+end string-kmp-partial-search s rest) ;; Enough prelude. Here's the actual code. (let ((patlen (vector-length rv))) (let lp ((si s-start) ; An index into S. (vi i)) ; An index into RV. (cond ((= vi patlen) (- si)) ; Win. ((= si s-end) vi) ; Ran off the end. (else ; Match s[si] & loop. (let ((c (string-ref s si))) (lp (+ si 1) (let lp2 ((vi vi)) ; This is just KMP-STEP. (if (c= c (string-ref pat (+ vi p-start))) (+ vi 1) (let ((vi (vector-ref rv vi))) (if (= vi -1) 0 (lp2 vi))))))))))))) ) ;;; Misc ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; (string-null? s) ;;; (reverse-list->string clist) ;;; (string->list s [start end]) (define (string-null? s) (zero? (string-length s))) (define (string-reverse s . maybe-start+end) (let-string-start+end (start end) string-reverse s maybe-start+end (let* ((len (- end start)) (ans (make-string len))) (do ((i start (+ i 1)) (j (- len 1) (- j 1))) ((< j 0)) (string-set! ans j (string-ref s i))) ans))) (define (reverse-list->string clist) (let* ((len (length clist)) (s (make-string len))) (do ((i (- len 1) (- i 1)) (clist clist (cdr clist))) ((not (pair? clist))) (string-set! s i (car clist))) s)) ;;; Defined by R5RS, so commented out here. ;(define (list->string lis) (string-unfold null? car cdr lis)) ;;; string-concatenate string-list -> string ;;; string-concatenate/shared string-list -> string ; Alas, Scheme 48's APPLY blows up if you have many, many arguments. ;(define (string-concatenate strings) (apply string-append strings)) ;;; Here it is written out. I avoid using REDUCE to add up string lengths ;;; to avoid non-R5RS dependencies. (define (string-concatenate strings) (let* ((total (do ((strings strings (cdr strings)) (i 0 (+ i (string-length (car strings))))) ((not (pair? strings)) i))) (ans (make-string total))) (let lp ((i 0) (strings strings)) (if (pair? strings) (let* ((s (car strings)) (slen (string-length s))) (%string-copy! ans i s 0 slen) (lp (+ i slen) (cdr strings))))) ans)) ;;; Defined by R5RS, so commented out here. ;(define (string-append . strings) (string-concatenate strings)) ;;; string-concatenate-reverse string-list [final-string end] -> string ;;; string-concatenate-reverse/shared string-list [final-string end] -> string ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Return ;;; (string-concatenate ;;; (reverse ;;; (cons (substring final-string 0 end) string-list))) (define (string-concatenate-reverse string-list . maybe-final+end) (let-optionals* maybe-final+end ((final "" (string? final)) (end (string-length final) (and (integer? end) (exact? end) (<= 0 end (string-length final))))) (let ((len (let lp ((sum 0) (lis string-list)) (if (pair? lis) (lp (+ sum (string-length (car lis))) (cdr lis)) sum)))) (%finish-string-concatenate-reverse len string-list final end)))) (define (%finish-string-concatenate-reverse len string-list final end) (let ((ans (make-string (+ end len)))) (%string-copy! ans len final 0 end) (let lp ((i len) (lis string-list)) (if (pair? lis) (let* ((s (car lis)) (lis (cdr lis)) (slen (string-length s)) (i (- i slen))) (%string-copy! ans i s 0 slen) (lp i lis)))) ans)) ;;; string-replace s1 s2 start1 end1 [start2 end2] -> string ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Replace S1[START1,END1) with S2[START2,END2). (define (string-replace s1 s2 start1 end1 . maybe-start+end) (check-substring-spec string-replace s1 start1 end1) (let-string-start+end (start2 end2) string-replace s2 maybe-start+end (let* ((slen1 (string-length s1)) (sublen2 (- end2 start2)) (alen (+ (- slen1 (- end1 start1)) sublen2)) (ans (make-string alen))) (%string-copy! ans 0 s1 0 start1) (%string-copy! ans start1 s2 start2 end2) (%string-copy! ans (+ start1 sublen2) s1 end1 slen1) ans))) ;;; string-split s delimiter [grammar limit start end] -> list ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Returns a list of the words contained in the substring of string from ;;; start (inclusive) to end (exclusive). Delimiter specifies a string ;;; whose characters are to be used as the word separator. The returned ;;; list will then have one more item than the number of non-overlapping ;;; occurrences of the delimiter in the string. If delimiter is an ;;; empty string, then the returned list contains a list of strings, ;;; each of which contains a single character. Grammar is a symbol with ;;; the same meaning as in the string-join procedure. If it is infix, ;;; which is the default, processing is done as described above, except ;;; that an empty s produces the empty list; if it is strict-infix, ;;; an empty s signals an error. The values prefix and suffix cause a ;;; leading/trailing empty string in the result to be suppressed. ;;; ;;; If limit is a non-negative exact integer, at most that many splits ;;; occur, and the remainder of string is returned as the final element ;;; of the list (thus, the result will have at most limit+1 elements). If ;;; limit is not specified or is #f, then as many splits as possible ;;; are made. It is an error if limit is any other value. ;;; ;;; Thanks to Shiro Kawai for the following code. (define (string-split s delimiter . args) ;; The argument checking part might be refactored with other srfi-130 ;; routines. (if (not (string? s)) (error "string expected" s)) (if (not (string? delimiter)) (error "string expected" delimiter)) (let ((slen (string-length s))) (receive (grammar limit no-limit start end) (if (pair? args) (if (pair? (cdr args)) (if (pair? (cddr args)) (if (pair? (cdddr args)) (values (car args) (cadr args) #f (caddr args) (cadddr args)) (values (car args) (cadr args) #f (caddr args) slen)) (values (car args) (cadr args) #f 0 slen)) (values (car args) #f #t 0 slen)) (values 'infix #f #t 0 slen)) (if (not (memq grammar '(infix strict-infix prefix suffix))) (error "grammar must be one of (infix strict-infix prefix suffix)" grammar)) (if (not limit) (set! no-limit #t)) (if (not (or no-limit (and (integer? limit) (exact? limit) (>= limit 0)))) (error "limit must be exact nonnegative integer or #f" limit)) (if (not (and (integer? start) (exact? start))) (error "start argument must be exact integer" start)) (if (not (<= 0 start slen)) (error "start argument out of range" start)) (if (not (<= 0 end slen)) (error "end argument out of range" end)) (if (not (<= start end)) (error "start argument is greater than end argument" (list start end))) (cond ((= start end) (if (eq? grammar 'strict-infix) (error "empty string cannot be spilt with strict-infix grammar") '())) ((string-null? delimiter) (%string-split-chars s start end limit)) (else (%string-split s start end delimiter grammar limit)))))) (define (%string-split-chars s start end limit) (if (not limit) (map string (string->list s start end)) (let loop ((r '()) (c start) (n 0)) (cond ((= c end) (reverse r)) ((>= n limit) (reverse (cons (substring s c end) r))) (else (loop (cons (string (string-ref s c)) r) (+ c 1) (+ n 1))))))) (define (%string-split s start end delimiter grammar limit) (let ((dlen (string-length delimiter))) (define (finish r c) (let ((rest (substring s c end))) (if (and (eq? grammar 'suffix) (string-null? rest)) (reverse r) (reverse (cons rest r))))) (define (scan r c n) (if (and limit (>= n limit)) (finish r c) (let ((i (string-contains s delimiter c end))) (if i (let ((fragment (substring s c i))) (if (and (= n 0) (eq? grammar 'prefix) (string-null? fragment)) (scan r (+ i dlen) (+ n 1)) (scan (cons fragment r) (+ i dlen) (+ n 1)))) (finish r c))))) (scan '() start 0))) ;;; string-replicate s from [to start end] -> string ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; S is a string; START and END are optional arguments that demarcate ;;; a substring of S, defaulting to 0 and the length of S (e.g., the whole ;;; string). Replicate this substring up and down index space, in both the ;; positive and negative directions. For example, if S = "abcdefg", START=3, ;;; and END=6, then we have the conceptual bidirectionally-infinite string ;;; ... d e f d e f d e f d e f d e f d e f d e f ... ;;; ... -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8 9 ... ;;; XSUBSTRING returns the substring of this string beginning at index FROM, ;;; and ending at TO (which defaults to FROM+(END-START)). ;;; ;;; You can use XSUBSTRING in many ways: ;;; - To rotate a string left: (string-replicate "abcdef" 2) => "cdefab" ;;; - To rotate a string right: (string-replicate "abcdef" -2) => "efabcd" ;;; - To replicate a string: (string-replicate "abc" 0 7) => "abcabca" ;;; ;;; Note that ;;; - The FROM/TO indices give a half-open range -- the characters from ;;; index FROM up to, but not including index TO. ;;; - The FROM/TO indices are not in terms of the index space for string S. ;;; They are in terms of the replicated index space of the substring ;;; defined by S, START, and END. ;;; ;;; It is an error if START=END -- although this is allowed by special ;;; dispensation when FROM=TO. (define (string-replicate s from . maybe-to+start+end) (check-arg (lambda (val) (and (integer? val) (exact? val))) from string-replicate) (receive (to start end) (if (pair? maybe-to+start+end) (let-string-start+end (start end) string-replicate s (cdr maybe-to+start+end) (let ((to (car maybe-to+start+end))) (check-arg (lambda (val) (and (integer? val) (exact? val) (<= from val))) to string-replicate) (values to start end))) (let ((slen (string-length (check-arg string? s string-replicate)))) (values (+ from slen) 0 slen))) (let ((slen (- end start)) (anslen (- to from))) (cond ((zero? anslen) "") ((zero? slen) (error "Cannot replicate empty (sub)string" string-replicate s from to start end)) ((= 1 slen) ; Fast path for 1-char replication. (make-string anslen (string-ref s start))) ;; Selected text falls entirely within one span. ((= (floor (/ from slen)) (floor (/ to slen))) (substring s (+ start (modulo from slen)) (+ start (modulo to slen)))) ;; Selected text requires multiple spans. (else (let ((ans (make-string anslen))) (%multispan-repcopy! ans 0 s from to start end) ans)))))) ;;; This is the core copying loop for XSUBSTRING and STRING-XCOPY! ;;; Internal -- not exported, no careful arg checking. (define (%multispan-repcopy! target tstart s sfrom sto start end) (let* ((slen (- end start)) (i0 (+ start (modulo sfrom slen))) (total-chars (- sto sfrom))) ;; Copy the partial span ! the beginning (%string-copy! target tstart s i0 end) (let* ((ncopied (- end i0)) ; We've copied this many. (nleft (- total-chars ncopied)) ; # chars left to copy. (nspans (quotient nleft slen))) ; # whole spans to copy ;; Copy the whole spans in the middle. (do ((i (+ tstart ncopied) (+ i slen)) ; Current target index. (nspans nspans (- nspans 1))) ; # spans to copy ((zero? nspans) ;; Copy the partial-span ! the end & we're done. (%string-copy! target i s start (+ start (- total-chars (- i tstart))))) (%string-copy! target i s start end))))); Copy a whole span. ;;; (string-join string-list [delimiter grammar]) => string ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Paste strings together using the delimiter string. ;;; ;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz" ;;; ;;; DELIMITER defaults to a single space " " ;;; GRAMMAR is one of the symbols {prefix, infix, strict-infix, suffix} ;;; and defaults to 'infix. ;;; ;;; I could rewrite this more efficiently -- precompute the length of the ;;; answer string, then allocate & fill it in iteratively. Using ;;; STRING-CONCATENATE is less efficient. (define (string-join strings . delim+grammar) (let-optionals* delim+grammar ((delim " " (string? delim)) (grammar 'infix)) (let ((buildit (lambda (lis final) (let recur ((lis lis)) (if (pair? lis) (cons delim (cons (car lis) (recur (cdr lis)))) final))))) (cond ((pair? strings) (string-concatenate (case grammar ((infix strict-infix) (cons (car strings) (buildit (cdr strings) '()))) ((prefix) (buildit strings '())) ((suffix) (cons (car strings) (buildit (cdr strings) (list delim)))) (else (error "Illegal join grammar" grammar string-join))))) ((not (null? strings)) (error "STRINGS parameter not list." strings string-join)) ;; STRINGS is () ((eq? grammar 'strict-infix) (error "Empty list cannot be joined with STRICT-INFIX grammar." string-join)) (else ""))))) ; Special-cased for infix grammar. (define (string-segment str k) (if (< k 1) (error "minimum segment size is 1" k)) (let ((len (string-length str))) (let loop ((start 0) (result '())) (if (= start len) (reverse result) (let ((end (min (+ start k) len))) (loop end (cons (%substring str start end) result))))))) ;;; Porting & performance-tuning notes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; See the section at the beginning of this file on external dependencies. ;;; ;;; The biggest issue with respect to porting is the LET-OPTIONALS* macro. ;;; There are many, many optional arguments in this library; the complexity ;;; of parsing, defaulting & type-testing these parameters is handled with the ;;; aid of this macro. There are about 15 uses of LET-OPTIONALS*. You can ;;; rewrite the uses, port the hairy macro definition (which is implemented ;;; using a Clinger-Rees low-level explicit-renaming macro system), or port ;;; the simple, high-level definition, which is less efficient. ;;; ;;; There is a fair amount of argument checking. This is, strictly speaking, ;;; unnecessary -- the actual body of the procedures will blow up if, say, a ;;; START/END index is improper. However, the error message will not be as ;;; good as if the error were caught at the "higher level." Also, a very, very ;;; smart Scheme compiler may be able to exploit having the type checks done ;;; early, so that the actual body of the procedures can assume proper values. ;;; This isn't likely; this kind of compiler technology isn't common any ;;; longer. ;;; ;;; The overhead of optional-argument parsing is irritating. The optional ;;; arguments must be consed into a rest list on entry, and then parsed out. ;;; Function call should be a matter of a few register moves and a jump; it ;;; should not involve heap allocation! Your Scheme system may have a superior ;;; non-R5RS optional-argument system that can eliminate this overhead. If so, ;;; then this is a prime candidate for optimising these procedures, ;;; *especially* the many optional START/END index parameters. ;;; ;;; Note that optional arguments are also a barrier to procedure integration. ;;; If your Scheme system permits you to specify alternate entry points ;;; for a call when the number of optional arguments is known in a manner ;;; that enables inlining/integration, this can provide performance ;;; improvements. ;;; ;;; There is enough *explicit* error checking that *all* string-index ;;; operations should *never* produce a bounds error. Period. Feel like ;;; living dangerously? *Big* performance win to be had by replacing ;;; STRING-REF's and STRING-SET!'s with unsafe equivalents in the loops. ;;; Similarly, fixnum-specific operators can speed up the arithmetic done on ;;; the index values in the inner loops. The only arguments that are not ;;; completely error checked are ;;; - string lists (complete checking requires time proportional to the ;;; length of the list) ;;; - procedure arguments, such as char->char maps & predicates. ;;; There is no way to check the range & domain of procedures in Scheme. ;;; Procedures that take these parameters cannot fully check their ;;; arguments. But all other types to all other procedures are fully ;;; checked. ;;; ;;; This does open up the alternate possibility of simply *removing* these ;;; checks, and letting the safe primitives raise the errors. On a dumb ;;; Scheme system, this would provide speed (by eliminating the redundant ;;; error checks) at the cost of error-message clarity. ;;; ;;; See the comments preceding the hash function code for notes on tuning ;;; the default bound so that the code never overflows your implementation's ;;; fixnum size into bignum calculation. ;;; ;;; In an interpreted Scheme, some of these procedures, or the internal ;;; routines with % prefixes, are excellent candidates for being rewritten ;;; in C. Consider STRING-HASH, %STRING-COMPARE, the ;;; %STRING-{SUF,PRE}FIX-LENGTH routines, STRING-COPY!, STRING-INDEX & ;;; STRING-SKIP (char case), SUBSTRING and SUBSTRING, ;;; %KMP-SEARCH, and %MULTISPAN-REPCOPY!. ;;; ;;; It would also be nice to have the ability to mark some of these ;;; routines as candidates for inlining/integration. ;;; ;;; All the %-prefixed routines in this source code are written ;;; to be called internally to this library. They do *not* perform ;;; friendly error checks on the inputs; they assume everything is ;;; proper. They also do not take optional arguments. These two properties ;;; save calling overhead and enable procedure integration -- but they ;;; are not appropriate for exported routines. ;;; Copyright details ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The prefix/suffix and comparison routines in this code had (extremely ;;; distant) origins in MIT Scheme's string lib, and was substantially ;;; reworked by Olin Shivers (shivers@ai.mit.edu) 9/98. As such, it is ;;; covered by MIT Scheme's open source copyright. See below for details. ;;; ;;; The KMP string-search code was influenced by implementations written ;;; by Stephen Bevan, Brian Dehneyer and Will Fitzgerald. However, this ;;; version was written from scratch by myself. ;;; ;;; The remainder of this code was written from scratch by myself for scsh. ;;; The scsh copyright is a BSD-style open source copyright. See below for ;;; details. ;;; -Olin Shivers ;;; MIT Scheme copyright terms ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This material was developed by the Scheme project at the Massachusetts ;;; Institute of Technology, Department of Electrical Engineering and ;;; Computer Science. Permission to copy and modify this software, to ;;; redistribute either the original software or a modified version, and ;;; to use this software for any purpose is granted, subject to the ;;; following restrictions and understandings. ;;; ;;; 1. Any copy made of this software must include this copyright notice ;;; in full. ;;; ;;; 2. Users of this software agree to make their best efforts (a) to ;;; return to the MIT Scheme project any improvements or extensions that ;;; they make, so that these may be included in future releases; and (b) ;;; to inform MIT of noteworthy uses of this software. ;;; ;;; 3. All materials developed as a consequence of the use of this ;;; software shall duly acknowledge such use, in accordance with the usual ;;; standards of acknowledging credit in academic research. ;;; ;;; 4. MIT has made no warrantee or representation that the operation of ;;; this software will be error-free, and MIT is under no obligation to ;;; provide any services, by way of maintenance, update, or otherwise. ;;; ;;; 5. In conjunction with products arising from the use of this material, ;;; there shall be no use of the name of the Massachusetts Institute of ;;; Technology nor of any adaptation thereof in any advertising, ;;; promotional, or sales literature without prior written consent from ;;; MIT in each case. ;;; Scsh copyright terms ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; 1. Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; 2. Redistributions in binary form must reproduce the above copyright ;;; notice, this list of conditions and the following disclaimer in the ;;; documentation and/or other materials provided with the distribution. ;;; 3. The name of the authors may not be used to endorse or promote products ;;; derived from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR ;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES ;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. ;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, ;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT ;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a152/r7rs-shim.scm000066400000000000000000000110151375154206600220570ustar00rootroot00000000000000(define (string-fill! s char . maybe-start+end) (check-arg char? char string-fill!) (let-string-start+end (start end) string-fill! s maybe-start+end (do ((i (- end 1) (- i 1))) ((< i start)) (string-set! s i char)))) (define (string-copy! to tstart from . maybe-fstart+fend) (let-string-start+end (fstart fend) string-copy! from maybe-fstart+fend (check-arg integer? tstart string-copy!) (check-substring-spec string-copy! to tstart (+ tstart (- fend fstart))) (%string-copy! to tstart from fstart fend))) ;;; Library-internal routine #;(define (%string-copy! to tstart from fstart fend) (if (> fstart tstart) (do ((i fstart (+ i 1)) (j tstart (+ j 1))) ((>= i fend)) (string-set! to j (string-ref from i))) (do ((i (- fend 1) (- i 1)) (j (+ -1 tstart (- fend fstart)) (- j 1))) ((< i fstart)) (string-set! to j (string-ref from i))))) (define (string->list s . maybe-start+end) (let-string-start+end (start end) string->list s maybe-start+end (do ((i (- end 1) (- i 1)) (ans '() (cons (string-ref s i) ans))) ((< i start) ans)))) (define (string->vector s . maybe-start+end) (let-string-start+end (start end) string->vector s maybe-start+end (let ((vector (make-vector (- end start)))) (do ((i (- end 1) (- i 1))) ((< i start) vector) (vector-set! vector (- i start) (string-ref s i)))))) (define (vector->string vector . maybe-start+end) (let ((start 0) (end (vector-length vector))) (case (length maybe-start+end) ((1) (set! start (car maybe-start+end))) ((2) (set! end (cadr maybe-start+end)))) (let ((s (make-string (- end start)))) (do ((i (- end 1) (- i 1))) ((< i start) s) (string-set! s (- i start) (vector-ref vector i)))))) (define (string-map f x . rest) (define (string-map1 f x) (list->string (map f (string->list x)))) (define (string-map2 f x y) (list->string (map f (string->list x) (string->list y)))) (define (string-mapn f lists) (list->string (apply map f (map string->list lists)))) (case (length rest) ((0) (string-map1 f x)) ((1) (string-map2 f x (car rest))) (else (string-mapn f (cons x rest))))) (define (string-for-each f s . rest) (define (for-each1 i n) (if (< i n) (begin (f (string-ref s i)) (for-each1 (+ i 1) n)) (if #f #f))) (define (for-each2 s2 i n) (if (< i n) (begin (f (string-ref s i) (string-ref s2 i)) (for-each2 s2 (+ i 1) n)) (if #f #f))) (define (for-each-n revstrings i n) (if (< i n) (do ((rev revstrings (cdr rev)) (chars '() (cons (string-ref (car rev) i) chars))) ((null? rev) (apply f chars) (for-each-n revstrings (+ i 1) n))) (if #f #f))) (let ((n (string-length s))) (cond ((null? rest) (for-each1 0 n)) ((and (null? (cdr rest)) (string? (car rest)) (= n (string-length (car rest)))) (for-each2 (car rest) 0 n)) (else (let ((args (cons s rest))) (do ((ss rest (cdr ss))) ((null? ss) (for-each-n (reverse args) 0 n)) (let ((x (car ss))) (if (or (not (string? x)) (not (= n (string-length x)))) (error "illegal-arguments" (cons f args)))))))))) (define (string-copy s . maybe-start+end) (let-string-start+end (start end) string-copy! s maybe-start+end (%substring s start end))) (cond-expand (chicken #;imported) (else (define read-string (case-lambda ((k) (read-string k (current-input-port))) ((k port) (let loop ((i 0) (o '())) (if (>= i k) (list->string (reverse o)) (let ((c (read-char port))) (if (eof-object? c) (if (= i 0) c (list->string (reverse o))) (loop (+ i 1) (cons c o))))))))))) ;; Chicken's write-string is incompatible with R7RS (define write-string (case-lambda ((str) (display str)) ((str port) (display str port)) ((str port start) (write-string str port start (string-length str))) ((str port start end) (display (%substring str start end) port)))) #;(define (eof-object) (let ((port (open-input-string ""))) (dynamic-wind (lambda () #f) (lambda () (read-char port)) (lambda () close-input-port port)))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a152/strings.sls000066400000000000000000000044401375154206600217400ustar00rootroot00000000000000(library (srfi :152 strings) (export ;; Predicates string? string-null? string-every string-any ;; Constructors make-string string string-tabulate string-unfold string-unfold-right ;; Conversion string->vector string->list vector->string list->string reverse-list->string ;; Selection string-length string-ref substring string-copy string-take string-take-right string-drop string-drop-right string-pad string-pad-right string-trim string-trim-right string-trim-both ;; Replacement string-replace ;; Comparision string=? string-ci=? string? string-ci>? string<=? string-ci<=? string>=? string-ci>=? ;; Prefixes and suffixes string-prefix-length string-suffix-length string-prefix? string-suffix? ;; Searching string-index string-index-right string-skip string-skip-right string-contains string-contains-right string-take-while string-take-while-right string-drop-while string-drop-while-right string-break string-span ;; Concatenation string-append string-concatenate string-concatenate-reverse string-join ;; Fold and map and friends string-fold string-fold-right string-map string-for-each string-count string-filter string-remove ;; Replication and splitting string-replicate string-segment string-split ;; Input-output read-string write-string ;; Mutation string-set! string-fill! string-copy!) (import (rename (except (rnrs) string->list string-for-each string-copy error) (string=? base-string=?) (string? base-string>?) (string<=? base-string<=?) (string>=? base-string>=?) (string-ci=? base-string-ci=?) (string-ci? base-string-ci>?) (string-ci<=? base-string-ci<=?) (string-ci>=? base-string-ci>=?)) (except (rnrs mutable-strings) string-fill!) (rnrs r5rs) (srfi :0) (srfi :23) (srfi private include)) (include/resolve ("srfi" "%3a152") "macros.scm") (include/resolve ("srfi" "%3a152") "portable.scm") (include/resolve ("srfi" "%3a152") "r7rs-shim.scm") (include/resolve ("srfi" "%3a152") "extend-comparisons.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a156.sls000066400000000000000000000001241375154206600202460ustar00rootroot00000000000000(library (srfi :156) (export is isnt) (import (srfi :156 predicate-combiners))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a156/000077500000000000000000000000001375154206600175265ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a156/predicate-combiners.sls000066400000000000000000000002411375154206600241650ustar00rootroot00000000000000(library (srfi :156 predicate-combiners) (export is isnt) (import (rnrs) (srfi private include)) (include/resolve ("srfi" "%3a156") "srfi-156-impl.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a156/srfi-156-impl.scm000066400000000000000000000065511375154206600224540ustar00rootroot00000000000000;; Reference Implementation from SRFI 156 ;; ;; Copyright (C) Panicz Maciej Godek (2017). All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to ;; deal in the Software without restriction, including without limitation the ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or ;; sell copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;; IN THE SOFTWARE. ;; ;; 12/31/2017 - AWK - shimmed extract-placehoders to allow for _ in R6RS scheme (define-syntax infix/postfix (syntax-rules () ((infix/postfix x somewhat?) (somewhat? x)) ((infix/postfix left related-to? right) (related-to? left right)) ((infix/postfix left related-to? right . likewise) (let ((right* right)) (and (infix/postfix left related-to? right*) (infix/postfix right* . likewise)))))) (define-syntax extract-placeholders (lambda (x) (syntax-case x () [(_ final () () body) #'(final (infix/postfix . body))] [(_ final () args body) #'(lambda args (final (infix/postfix . body)))] [(k final (underscore op . rest) (args ...) (body ...)) (eq? (syntax->datum #'underscore) '_) #'(k final rest (args ... arg) (body ... arg op))] [(k final (arg op . rest) args (body ...)) #'(k final rest args (body ... arg op))] [(k final (underscore) (args ...) (body ...)) (eq? (syntax->datum #'underscore) '_) #'(k final () (args ... arg) (body ... arg))] [(k final (arg) args (body ...)) #'(k final () args (body ... arg))]))) #;(define-syntax extract-placeholders (syntax-rules (_) ((extract-placeholders final () () body) (final (infix/postfix . body))) ((extract-placeholders final () args body) (lambda args (final (infix/postfix . body)))) ((extract-placeholders final (_ op . rest) (args ...) (body ...)) (extract-placeholders final rest (args ... arg) (body ... arg op))) ((extract-placeholders final (arg op . rest) args (body ...)) (extract-placeholders final rest args (body ... arg op))) ((extract-placeholders final (_) (args ...) (body ...)) (extract-placeholders final () (args ... arg) (body ... arg))) ((extract-placeholders final (arg) args (body ...)) (extract-placeholders final () args (body ... arg))))) (define-syntax identity-syntax (syntax-rules () ((identity-syntax form) form))) (define-syntax is (syntax-rules () ((is . something) (extract-placeholders identity-syntax something () ())))) (define-syntax isnt (syntax-rules () ((isnt . something) (extract-placeholders not something () ())))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a158.sls000066400000000000000000000022011375154206600202460ustar00rootroot00000000000000(library (srfi :158) (export ;; Generator constructors generator circular-generator make-iota-generator make-range-generator make-coroutine-generator list->generator vector->generator reverse-vector->generator string->generator bytevector->generator make-for-each-generator make-unfold-generator ;; Generator operations gcons* gappend gflatten ggroup gmerge gmap gcombine gfilter gremove gstate-filter gtake gdrop gtake-while gdrop-while gdelete gdelete-neighbor-dups gindex gselect ;; Consuming generated values generator->list generator->reverse-list generator->vector generator->vector! generator->string generator-fold generator-for-each generator-map->list generator-find generator-count generator-any generator-every generator-unfold ;; accumulator constructors make-accumulator count-accumulator list-accumulator reverse-list-accumulator vector-accumulator reverse-vector-accumulator vector-accumulator! string-accumulator bytevector-accumulator bytevector-accumulator! sum-accumulator product-accumulator) (import (srfi :158 generators-and-accumulators))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a158/000077500000000000000000000000001375154206600175305ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a158/generators-and-accumulators.sls000066400000000000000000000024451375154206600256710ustar00rootroot00000000000000(library (srfi :158 generators-and-accumulators) (export ;; Generator constructors generator circular-generator make-iota-generator make-range-generator make-coroutine-generator list->generator vector->generator reverse-vector->generator string->generator bytevector->generator make-for-each-generator make-unfold-generator ;; Generator operations gcons* gappend gflatten ggroup gmerge gmap gcombine gfilter gremove gstate-filter gtake gdrop gtake-while gdrop-while gdelete gdelete-neighbor-dups gindex gselect ;; Consuming generated values generator->list generator->reverse-list generator->vector generator->vector! generator->string generator-fold generator-for-each generator-map->list generator-find generator-count generator-any generator-every generator-unfold ;; accumulator constructors make-accumulator count-accumulator list-accumulator reverse-list-accumulator vector-accumulator reverse-vector-accumulator vector-accumulator! string-accumulator bytevector-accumulator bytevector-accumulator! sum-accumulator product-accumulator) (import (rnrs) (only (srfi :1) make-list) (srfi private include) (srfi private define-values)) (include/resolve ("srfi" "%3a158") "srfi-158-impl.scm")) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a158/srfi-158-impl.scm000077500000000000000000000432021375154206600224550ustar00rootroot00000000000000;; reference implementation from: https://github.com/scheme-requests-for-implementation/srfi-158 ;; Copyright (C) Shiro Kawai, John Cowan, Thomas Gilray (2015). All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to ;; deal in the Software without restriction, including without limitation the ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or ;; sell copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;; IN THE SOFTWARE. ;; Chibi Scheme version of any (define (any pred ls) (if (null? (cdr ls)) (pred (car ls)) ((lambda (x) (if x x (any pred (cdr ls)))) (pred (car ls))))) ;; list->bytevector (define (list->bytevector list) (let ((vec (make-bytevector (length list) 0))) (let loop ((i 0) (list list)) (if (null? list) vec (begin (bytevector-u8-set! vec i (car list)) (loop (+ i 1) (cdr list))))))) ;; generator (define (generator . args) (lambda () (if (null? args) (eof-object) (let ((next (car args))) (set! args (cdr args)) next)))) ;; circular-generator (define (circular-generator . args) (let ((base-args args)) (lambda () (when (null? args) (set! args base-args)) (let ((next (car args))) (set! args (cdr args)) next)))) ;; make-iota-generator (define make-iota-generator (case-lambda ((count) (make-iota-generator count 0 1)) ((count start) (make-iota-generator count start 1)) ((count start step) (make-iota count start step)))) ;; make-iota (define (make-iota count start step) (lambda () (cond ((<= count 0) (eof-object)) (else (let ((result start)) (set! count (- count 1)) (set! start (+ start step)) result))))) ;; make-range-generator (define make-range-generator (case-lambda ((start end) (make-range-generator start end 1)) ((start) (make-infinite-range-generator start)) ((start end step) (set! start (- (+ start step) step)) (lambda () (if (< start end) (let ((v start)) (set! start (+ start step)) v) (eof-object)))))) (define (make-infinite-range-generator start) (lambda () (let ((result start)) (set! start (+ start 1)) result))) ;; make-coroutine-generator (define (make-coroutine-generator proc) (define return #f) (define resume #f) (define yield (lambda (v) (call/cc (lambda (r) (set! resume r) (return v))))) (lambda () (call/cc (lambda (cc) (set! return cc) (if resume (resume (if #f #f)) ; void? or yield again? (begin (proc yield) (set! resume (lambda (v) (return (eof-object)))) (return (eof-object)))))))) ;; list->generator (define (list->generator lst) (lambda () (if (null? lst) (eof-object) (let ((next (car lst))) (set! lst (cdr lst)) next)))) ;; vector->generator (define vector->generator (case-lambda ((vec) (vector->generator vec 0 (vector-length vec))) ((vec start) (vector->generator vec start (vector-length vec))) ((vec start end) (lambda () (if (>= start end) (eof-object) (let ((next (vector-ref vec start))) (set! start (+ start 1)) next)))))) ;; reverse-vector->generator (define reverse-vector->generator (case-lambda ((vec) (reverse-vector->generator vec 0 (vector-length vec))) ((vec start) (reverse-vector->generator vec start (vector-length vec))) ((vec start end) (lambda () (if (>= start end) (eof-object) (let ((next (vector-ref vec (- end 1)))) (set! end (- end 1)) next)))))) ;; string->generator (define string->generator (case-lambda ((str) (string->generator str 0 (string-length str))) ((str start) (string->generator str start (string-length str))) ((str start end) (lambda () (if (>= start end) (eof-object) (let ((next (string-ref str start))) (set! start (+ start 1)) next)))))) ;; bytevector->generator (define bytevector->generator (case-lambda ((str) (bytevector->generator str 0 (bytevector-length str))) ((str start) (bytevector->generator str start (bytevector-length str))) ((str start end) (lambda () (if (>= start end) (eof-object) (let ((next (bytevector-u8-ref str start))) (set! start (+ start 1)) next)))))) ;; make-for-each-generator ;FIXME: seems to fail test (define (make-for-each-generator for-each obj) (make-coroutine-generator (lambda (yield) (for-each yield obj)))) ;; make-unfold-generator (define (make-unfold-generator stop? mapper successor seed) (make-coroutine-generator (lambda (yield) (let loop ((s seed)) (if (stop? s) (if #f #f) (begin (yield (mapper s)) (loop (successor s)))))))) ;; gcons* (define (gcons* . args) (lambda () (if (null? args) (eof-object) (if (= (length args) 1) ((car args)) (let ((v (car args))) (set! args (cdr args)) v))))) ;; gappend (define (gappend . args) (lambda () (if (null? args) (eof-object) (let loop ((v ((car args)))) (if (eof-object? v) (begin (set! args (cdr args)) (if (null? args) (eof-object) (loop ((car args))))) v))))) ;; gflatten (define (gflatten gen) (let ((state '())) (lambda () (if (null? state) (set! state (gen))) (if (eof-object? state) state (let ((obj (car state))) (set! state (cdr state)) obj))))) ;; ggroup (define ggroup (case-lambda ((gen k) (simple-ggroup gen k)) ((gen k padding) (padded-ggroup (simple-ggroup gen k) k padding)))) (define (simple-ggroup gen k) (lambda () (let loop ((item (gen)) (result '()) (count (- k 1))) (if (eof-object? item) (if (null? result) item (reverse result)) (if (= count 0) (reverse (cons item result)) (loop (gen) (cons item result) (- count 1))))))) (define (padded-ggroup gen k padding) (lambda () (let ((item (gen))) (if (eof-object? item) item (let ((len (length item))) (if (= len k) item (append item (make-list (- k len) padding)))))))) ;; gmerge (define gmerge (case-lambda ((<) (error #f "wrong number of arguments for gmerge")) ((< gen) gen) ((< genleft genright) (let ((left (genleft)) (right (genright))) (lambda () (cond ((and (eof-object? left) (eof-object? right)) left) ((eof-object? left) (let ((obj right)) (set! right (genright)) obj)) ((eof-object? right) (let ((obj left)) (set! left (genleft)) obj)) ((< right left) (let ((obj right)) (set! right (genright)) obj)) (else (let ((obj left)) (set! left (genleft)) obj)))))) ((< . gens) (apply gmerge < (let loop ((gens gens) (gs '())) (cond ((null? gens) (reverse gs)) ((null? (cdr gens)) (reverse (cons (car gens) gs))) (else (loop (cddr gens) (cons (gmerge < (car gens) (cadr gens)) gs))))))))) ;; gmap (define gmap (case-lambda ((proc) (error #f "wrong number of arguments for gmap")) ((proc gen) (lambda () (let ((item (gen))) (if (eof-object? item) item (proc item))))) ((proc . gens) (lambda () (let ((items (map (lambda (x) (x)) gens))) (if (any eof-object? items) (eof-object) (apply proc items))))))) ;; gcombine (define (gcombine proc seed . gens) (lambda () (define items (map (lambda (x) (x)) gens)) (if (any eof-object? items) (eof-object) (let () (define-values (value newseed) (apply proc (append items (list seed)))) (set! seed newseed) value)))) ;; gfilter (define (gfilter pred gen) (lambda () (let loop () (let ((next (gen))) (if (or (eof-object? next) (pred next)) next (loop)))))) ;; gstate-filter (define (gstate-filter proc seed gen) (let ((state seed)) (lambda () (let loop ((item (gen))) (if (eof-object? item) item (let-values (((yes newstate) (proc item state))) (set! state newstate) (if yes item (loop (gen))))))))) ;; gremove (define (gremove pred gen) (gfilter (lambda (v) (not (pred v))) gen)) ;; gtake (define gtake (case-lambda ((gen k) (gtake gen k (eof-object))) ((gen k padding) (make-coroutine-generator (lambda (yield) (if (> k 0) (let loop ((i 0) (v (gen))) (begin (if (eof-object? v) (yield padding) (yield v)) (if (< (+ 1 i) k) (loop (+ 1 i) (gen)) (eof-object)))) (eof-object))))))) ;; gdrop (define (gdrop gen k) (lambda () (do () ((<= k 0)) (set! k (- k 1)) (gen)) (gen))) ;; gdrop-while (define (gdrop-while pred gen) (define found #f) (lambda () (let loop () (let ((val (gen))) (cond (found val) ((and (not (eof-object? val)) (pred val)) (loop)) (else (set! found #t) val)))))) ;; gtake-while (define (gtake-while pred gen) (lambda () (let ((next (gen))) (if (eof-object? next) next (if (pred next) next (begin (set! gen (generator)) (gen))))))) ;; gdelete (define gdelete (case-lambda ((item gen) (gdelete item gen equal?)) ((item gen ==) (lambda () (let loop ((v (gen))) (cond ((eof-object? v) (eof-object)) ((== item v) (loop (gen))) (else v))))))) ;; gdelete-neighbor-dups (define gdelete-neighbor-dups (case-lambda ((gen) (gdelete-neighbor-dups gen equal?)) ((gen ==) (define firsttime #t) (define prev #f) (lambda () (if firsttime (begin (set! firsttime #f) (set! prev (gen)) prev) (let loop ((v (gen))) (cond ((eof-object? v) v) ((== prev v) (loop (gen))) (else (set! prev v) v)))))))) ;; gindex (define (gindex value-gen index-gen) (let ((done? #f) (count 0)) (lambda () (if done? (eof-object) (let loop ((value (value-gen)) (index (index-gen))) (cond ((or (eof-object? value) (eof-object? index)) (set! done? #t) (eof-object)) ((= index count) (set! count (+ count 1)) value) (else (set! count (+ count 1)) (loop (value-gen) index)))))))) ;; gselect (define (gselect value-gen truth-gen) (let ((done? #f)) (lambda () (if done? (eof-object) (let loop ((value (value-gen)) (truth (truth-gen))) (cond ((or (eof-object? value) (eof-object? truth)) (set! done? #t) (eof-object)) (truth value) (else (loop (value-gen) (truth-gen))))))))) ;; generator->list (define generator->list (case-lambda ((gen n) (generator->list (gtake gen n))) ((gen) (reverse (generator->reverse-list gen))))) ;; generator->reverse-list (define generator->reverse-list (case-lambda ((gen n) (generator->reverse-list (gtake gen n))) ((gen) (generator-fold cons '() gen)))) ;; generator->vector (define generator->vector (case-lambda ((gen) (list->vector (generator->list gen))) ((gen n) (list->vector (generator->list gen n))))) ;; generator->vector! (define (generator->vector! vector at gen) (let loop ((value (gen)) (count 0) (at at)) (cond ((eof-object? value) count) ((>= at (vector-length vector)) count) (else (begin (vector-set! vector at value) (loop (gen) (+ count 1) (+ at 1))))))) ;; generator->string (define generator->string (case-lambda ((gen) (list->string (generator->list gen))) ((gen n) (list->string (generator->list gen n))))) ;; generator-fold (define (generator-fold f seed . gs) (define (inner-fold seed) (let ((vs (map (lambda (g) (g)) gs))) (if (any eof-object? vs) seed (inner-fold (apply f (append vs (list seed))))))) (inner-fold seed)) ;; generator-for-each (define (generator-for-each f . gs) (let loop () (let ((vs (map (lambda (g) (g)) gs))) (if (any eof-object? vs) (if #f #f) (begin (apply f vs) (loop)))))) (define (generator-map->list f . gs) (let loop ((result '())) (let ((vs (map (lambda (g) (g)) gs))) (if (any eof-object? vs) (reverse result) (loop (cons (apply f vs) result)))))) ;; generator-find (define (generator-find pred g) (let loop ((v (g))) ; A literal interpretation might say it only terminates on #eof if (pred #eof) but I think this makes more sense... (if (or (pred v) (eof-object? v)) v (loop (g))))) ;; generator-count (define (generator-count pred g) (generator-fold (lambda (v n) (if (pred v) (+ 1 n) n)) 0 g)) ;; generator-any (define (generator-any pred g) (let loop ((v (g))) (if (eof-object? v) #f (if (pred v) #t (loop (g)))))) ;; generator-every (define (generator-every pred g) (let loop ((v (g))) (if (eof-object? v) #t (if (pred v) (loop (g)) #f ; the spec would have me return #f, but I think it must simply be wrong... )))) ;; generator-unfold (define (generator-unfold g unfold . args) (apply unfold eof-object? (lambda (x) x) (lambda (x) (g)) (g) args)) ;; make-accumulator (define (make-accumulator kons knil finalize) (let ((state knil)) (lambda (obj) (if (eof-object? obj) (finalize state) (set! state (kons obj state)))))) ;; count-accumulator (define (count-accumulator) (make-accumulator (lambda (obj state) (+ 1 state)) 0 (lambda (x) x))) ;; list-accumulator (define (list-accumulator) (make-accumulator cons '() reverse)) ;; reverse-list-accumulator (define (reverse-list-accumulator) (make-accumulator cons '() (lambda (x) x))) ;; vector-accumulator (define (vector-accumulator) (make-accumulator cons '() (lambda (x) (list->vector (reverse x))))) ;; reverse-vector-accumulator (define (reverse-vector-accumulator) (make-accumulator cons '() list->vector)) ;; vector-accumulator! (define (vector-accumulator! vec at) (lambda (obj) (if (eof-object? obj) vec (begin (vector-set! vec at obj) (set! at (+ at 1)))))) ;; bytevector-accumulator (define (bytevector-accumulator) (make-accumulator cons '() (lambda (x) (list->bytevector (reverse x))))) (define (bytevector-accumulator! bytevec at) (lambda (obj) (if (eof-object? obj) bytevec (begin (bytevector-u8-set! bytevec at obj) (set! at (+ at 1)))))) ;; string-accumulator (define (string-accumulator) (make-accumulator cons '() (lambda (lst) (list->string (reverse lst))))) ;; sum-accumulator (define (sum-accumulator) (make-accumulator + 0 (lambda (x) x))) ;; product-accumulator (define (product-accumulator) (make-accumulator * 1 (lambda (x) x))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a16.sls000066400000000000000000000002331375154206600201620ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :16) (export case-lambda) (import (srfi :16 case-lambda)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a16/000077500000000000000000000000001375154206600174415ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a16/case-lambda.sls000066400000000000000000000004161375154206600223160ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :16 case-lambda) (export case-lambda) (import (only (rnrs control) case-lambda)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a17.sls000066400000000000000000000044511375154206600201710ustar00rootroot00000000000000;; SRFI-17 r6rs library entry ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to ;; deal in the Software without restriction, including without limitation the ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or ;; sell copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. (library (srfi :17) (export getter-with-setter set! car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr string-ref vector-ref bytevector-ieee-double-native-ref bytevector-ieee-double-ref bytevector-ieee-single-native-ref bytevector-ieee-single-ref bytevector-s16-native-ref bytevector-s16-ref bytevector-s24-ref bytevector-s32-native-ref bytevector-s32-ref bytevector-s40-ref bytevector-s48-ref bytevector-s56-ref bytevector-s64-native-ref bytevector-s64-ref bytevector-s8-ref bytevector-sint-ref bytevector-u16-native-ref bytevector-u16-ref bytevector-u24-ref bytevector-u32-native-ref bytevector-u32-ref bytevector-u40-ref bytevector-u48-ref bytevector-u56-ref bytevector-u64-native-ref bytevector-u64-ref bytevector-u8-ref bytevector-uint-ref foreign-ref fxvector-ref hashtable-ref eq-hashtable-ref symbol-hashtable-ref list-ref) (import (srfi :17 generalized-set!))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a17/000077500000000000000000000000001375154206600174425ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a17/generalized-set%21.chezscheme.sls000066400000000000000000000137141375154206600256020ustar00rootroot00000000000000;; SRFI-17 implementation for Chez Scheme ;; ;; Generalized getter and setter for built-in Chez Scheme types. ;; Uses Chez Scheme's define-proprety and syntactic environment to ;; provide generalized reference and set! syntax. Relies on helpers ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep (library (srfi :17 generalized-set!) (export getter-with-setter set! car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr string-ref vector-ref bytevector-ieee-double-native-ref bytevector-ieee-double-ref bytevector-ieee-single-native-ref bytevector-ieee-single-ref bytevector-s16-native-ref bytevector-s16-ref bytevector-s24-ref bytevector-s32-native-ref bytevector-s32-ref bytevector-s40-ref bytevector-s48-ref bytevector-s56-ref bytevector-s64-native-ref bytevector-s64-ref bytevector-s8-ref bytevector-sint-ref bytevector-u16-native-ref bytevector-u16-ref bytevector-u24-ref bytevector-u32-native-ref bytevector-u32-ref bytevector-u40-ref bytevector-u48-ref bytevector-u56-ref bytevector-u64-native-ref bytevector-u64-ref bytevector-u8-ref bytevector-uint-ref foreign-ref fxvector-ref hashtable-ref eq-hashtable-ref symbol-hashtable-ref list-ref) (import (rename (chezscheme) (set! cs:set!)) (srfi :17 helpers)) (define getter-with-setter-prop) (define-syntax getter-with-setter (syntax-rules () [(_ getter setter) (define-property getter getter-with-setter-prop #'setter)])) (define-syntax getters-and-setters (syntax-rules () [(_ [getter setter] ...) (begin (getter-with-setter getter setter) ...)])) (define-syntax set! (lambda (x) (syntax-case x () [(_ (getter e0 e1 ...) v) (lambda (r) (with-syntax ([setter (r #'getter #'getter-with-setter-prop)]) (if (datum setter) #'(setter e0 e1 ... v) (syntax-violation 'set! "no setter configured for getter" #'getter x))))] [(_ x v) (identifier? #'x) #'(cs:set! x v)]))) (getters-and-setters [car set-car!] [cdr set-cdr!] [caar $set-caar!] [cadr $set-cadr!] [cdar $set-cdar!] [cddr $set-cddr!] [caaar $set-caaar!] [caadr $set-caadr!] [cadar $set-cadar!] [caddr $set-caddr!] [cdaar $set-cdaar!] [cdadr $set-cdadr!] [cddar $set-cddar!] [cdddr $set-cdddr!] [caaaar $set-caaaar!] [caaadr $set-caaadr!] [caadar $set-caadar!] [caaddr $set-caaddr!] [cadaar $set-cadaar!] [cadadr $set-cadadr!] [caddar $set-caddar!] [cadddr $set-cadddr!] [cdaaar $set-cdaaar!] [cdaadr $set-cdaadr!] [cdadar $set-cdadar!] [cdaddr $set-cdaddr!] [cddaar $set-cddaar!] [cddadr $set-cddadr!] [cdddar $set-cdddar!] [cddddr $set-cddddr!] [string-ref string-set!] [vector-ref vector-set!] [bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!] [bytevector-ieee-double-ref $bytevector-ieee-double-set!] [bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!] [bytevector-ieee-single-ref $bytevector-ieee-single-set!] [bytevector-s16-native-ref bytevector-s16-native-set!] [bytevector-s16-ref $bytevector-s16-set!] [bytevector-s24-ref $bytevector-s24-set!] [bytevector-s32-native-ref bytevector-s32-native-set!] [bytevector-s32-ref $bytevector-s32-set!] [bytevector-s40-ref $bytevector-s40-set!] [bytevector-s48-ref $bytevector-s48-set!] [bytevector-s56-ref $bytevector-s56-set!] [bytevector-s64-native-ref bytevector-s64-native-set!] [bytevector-s64-ref $bytevector-s64-set!] [bytevector-s8-ref bytevector-s8-set!] [bytevector-sint-ref $bytevector-sint-set!] [bytevector-u16-native-ref bytevector-u16-native-set!] [bytevector-u16-ref $bytevector-u16-set!] [bytevector-u24-ref $bytevector-u24-set!] [bytevector-u32-native-ref bytevector-u32-native-set!] [bytevector-u32-ref $bytevector-u32-set!] [bytevector-u40-ref $bytevector-u40-set!] [bytevector-u48-ref $bytevector-u48-set!] [bytevector-u56-ref $bytevector-u56-set!] [bytevector-u64-native-ref bytevector-u64-native-set!] [bytevector-u64-ref $bytevector-u64-set!] [bytevector-u8-ref bytevector-u8-set!] [bytevector-uint-ref $bytevector-uint-set!] [foreign-ref foreign-set!] [fxvector-ref fxvector-set!] [hashtable-ref $hashtable-set!] [eq-hashtable-ref $eq-hashtable-set!] [symbol-hashtable-ref $symbol-hashtable-set!] [list-ref $list-set!])) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a17/helpers.chezscheme.sls000066400000000000000000000126531375154206600237530ustar00rootroot00000000000000;; SRFI-17 Chez Scheme helpers ;; ;; This file contains wrappers for some of the built-in setters used ;; by the generalized set! syntax. ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep (library (srfi :17 helpers) (export $list-set! $hashtable-set! $eq-hashtable-set! $symbol-hashtable-set! $set-caar! $set-cadr! $set-cdar! $set-cddr! $set-caaar! $set-caadr! $set-cadar! $set-caddr! $set-cdaar! $set-cdadr! $set-cddar! $set-cdddr! $set-caaaar! $set-caaadr! $set-caadar! $set-caaddr! $set-cadaar! $set-cadadr! $set-caddar! $set-cadddr! $set-cdaaar! $set-cdaadr! $set-cdadar! $set-cdaddr! $set-cddaar! $set-cddadr! $set-cdddar! $set-cddddr! $bytevector-ieee-double-set! $bytevector-ieee-single-set! $bytevector-s16-set! $bytevector-s24-set! $bytevector-s32-set! $bytevector-s40-set! $bytevector-s48-set! $bytevector-s56-set! $bytevector-s64-set! $bytevector-u16-set! $bytevector-u24-set! $bytevector-u32-set! $bytevector-u40-set! $bytevector-u48-set! $bytevector-u56-set! $bytevector-u64-set! $bytevector-sint-set! $bytevector-uint-set!) (import (chezscheme)) (define-syntax define-$set-c...r! (lambda (x) (define (build-defs-for-level k cnt defs) (let ([ls (list "a" "d")]) (let loop ([i 1] [names ls]) (if (fx= i (fx- cnt 1)) (fold-left (lambda (defs name) (fold-left (lambda (defs a) (with-syntax ([base-getter (datum->syntax #'* (string->symbol (string-append "c" name "r")))] [base-setter (datum->syntax #'* (string->symbol (string-append "set-c" a "r!")))] [full-setter (datum->syntax k (string->symbol (string-append "$set-c" a name "r!")))]) (cons #'(define full-setter (lambda (x v) (base-setter (base-getter x) v))) defs))) defs ls)) defs names) (loop (fx+ i 1) (fold-left (lambda (new-names a) (fold-left (lambda (new-names name) (cons (string-append a name) new-names)) new-names names)) '() ls)))))) (define (build-defs k s e) (do ([i s (fx+ i 1)] [defs '() (build-defs-for-level k i defs)]) ((fx> i e) defs))) (syntax-case x () [(k s e) (and (and (integer? (datum s)) (exact? (datum s))) (and (integer? (datum e)) (exact? (datum s)))) (with-syntax ([(defs ...) (build-defs #'k (datum s) (datum e))]) #'(begin defs ...))]))) (define-$set-c...r! 2 4) (define-syntax define-hashtable-set! (lambda (x) (define (build-def k) (lambda (name) (with-syntax ([out-name (datum->syntax k (string->symbol (string-append "$" name "hashtable-set!")))] [name (datum->syntax #'* (string->symbol (string-append name "hashtable-set!")))]) #'(define-syntax out-name (syntax-rules () [(_ ht k dv v) (name ht k v)]))))) (syntax-case x () [(k name ...) (andmap string? (datum (name ...))) (with-syntax ([(defs ...) (map (build-def #'k) (datum (name ...)))]) #'(begin defs ...))]))) (define-hashtable-set! "" "eq-" "symbol-") (define $list-set! (lambda (ls orig-idx v) (let loop ([ls ls] [idx orig-idx]) (if (fx= idx 0) (set-car! ls v) (if (null? ls) (errorf 'list-ref "~s index out of range" orig-idx) (loop (cdr ls) (fx+ idx 1))))))) (define-syntax define-$bv-set! (lambda (x) (define (build-defs k) (lambda (name) (let ([name (symbol->string (syntax->datum name))]) (with-syntax ([bv-set! (datum->syntax #'* (string->symbol (string-append "bytevector-" name "-set!")))] [$bv-set! (datum->syntax k (string->symbol (string-append "$bytevector-" name "-set!")))]) #'(define-syntax $bv-set! (syntax-rules () [(_ bv idx eness v) (bv-set! bv idx v eness)])))))) (syntax-case x () [(k name ...) (with-syntax ([(defs ...) (map (build-defs #'k) #'(name ...))]) #'(begin defs ...))]))) (define-$bv-set! ieee-double ieee-single s16 s24 s32 s40 s48 s56 s64 u16 u24 u32 u40 u48 u56 u64) (define-syntax define-$bv-int-set! (lambda (x) (define (build-defs k) (lambda (name) (let ([name (symbol->string (syntax->datum name))]) (with-syntax ([bv-set! (datum->syntax #'* (string->symbol (string-append "bytevector-" name "-set!")))] [$bv-set! (datum->syntax k (string->symbol (string-append "$bytevector-" name "-set!")))]) #'(define-syntax $bv-set! (syntax-rules () [(_ bv idx eness size v) (bv-set! bv idx v eness size)])))))) (syntax-case x () [(k name ...) (with-syntax ([(defs ...) (map (build-defs #'k) #'(name ...))]) #'(begin defs ...))]))) (define-$bv-int-set! sint uint)) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a17/helpers.sls000066400000000000000000000057321375154206600216360ustar00rootroot00000000000000;; SRFI-17 generic helpers ;; ;; This file contains R6RS compatible wrappers for some of the ;; built-in setters used by the generalized set! syntax. ;; ;; Note: this was never completely fleshed out. ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep (define-syntax define-$set-c...r! (lambda (x) (define (build-defs-for-level k cnt defs) (let ([ls (list "a" "d")]) (let loop ([i 1] [names ls]) (if (fx= i (fx- cnt 1)) (fold-left (lambda (defs name) (fold-left (lambda (defs a) (with-syntax ([base-getter (datum->syntax #'* (string->symbol (string-append "c" name "r")))] [base-setter (datum->syntax #'* (string->symbol (string-append "set-c" a "r!")))] [full-setter (datum->syntax k (string->symbol (string-append "$set-c" a name "r!")))]) (cons #'(define full-setter (lambda (x v) (base-setter (base-getter x) v))) defs))) defs ls)) defs names) (loop (fx+ i 1) (fold-left (lambda (new-names a) (fold-left (lambda (new-names name) (cons (string-append a name) new-names)) new-names names)) '() ls)))))) (define (build-defs k s e) (do ([i s (fx+ i 1)] [defs '() (build-defs-for-level k i defs)]) ((fx> i e) defs))) (syntax-case x () [(k s e) (and (and (integer? (datum s)) (exact? (datum s))) (and (integer? (datum e)) (exact? (datum s)))) (with-syntax ([(defs ...) (build-defs #'k (datum s) (datum e))]) #'(begin defs ...))]))) (define-$set-c...r! 2 4) (define-syntax define-hashtable-set! (lambda (x) (define (build-def k) (lambda (name) (with-syntax ([out-name (datum->syntax k (string->symbol (string-append "$" name "hashtable-set!")))] [name (datum->syntax #'* (string->symbol (string-append name "hashtable-set!")))]) #'(define-syntax out-name (syntax-rules () [(_ ht k dv v) (name ht k v)]))))) (syntax-case x () [(k name ...) (andmap string? (datum (name ...))) (with-syntax ([(defs ...) (map (build-def #'k) (datum (name ...)))]) #'(begin defs ...))]))) (define-hashtable-set! "" "eq" "symbol") (define $list-set! (lambda (ls orig-idx v) (let loop ([ls ls] [idx orig-idx]) (if (fx= idx 0) (set-car! ls v) (if (null? ls) (errorf 'list-ref "~s index out of range" orig-idx) (loop (cdr ls) (fx+ idx 1))))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a175.sls000066400000000000000000000174001375154206600202540ustar00rootroot00000000000000#!r6rs ;; Automatically generated ;; Copyright 2019 Lassi Kortela ;; SPDX-License-Identifier: MIT (library (srfi :175) (export ascii-codepoint? ascii-bytevector? ascii-char? ascii-string? ascii-control? ascii-non-control? ascii-whitespace? ascii-space-or-tab? ascii-other-graphic? ascii-upper-case? ascii-lower-case? ascii-alphabetic? ascii-alphanumeric? ascii-numeric? ascii-digit-value ascii-upper-case-value ascii-lower-case-value ascii-nth-digit ascii-nth-upper-case ascii-nth-lower-case ascii-upcase ascii-downcase ascii-control->graphic ascii-graphic->control ascii-mirror-bracket ascii-ci=? ascii-ci? ascii-ci<=? ascii-ci>=? ascii-string-ci=? ascii-string-ci? ascii-string-ci<=? ascii-string-ci>=?) (import (rnrs)) (define (ensure-int x) (if (char? x) (char->integer x) x)) (define (base-offset-limit x base offset limit) (let ((cc (ensure-int x))) (and (fx>=? cc base) (fxint->char map-int char) (let ((int (map-int (char->integer char)))) (and int (integer->char int)))) (define (ascii-codepoint? x) (and (fixnum? x) (fx<=? 0 x 127))) (define (ascii-char? x) (and (char? x) (fxinteger x) 128))) (define (ascii-bytevector? x) (and (bytevector? x) (let check ((i (fx- (bytevector-length x) 1))) (or (fxinteger char) 128) (check))))))))) (define (ascii-control? x) (let ((cc (ensure-int x))) (or (fx<=? 0 cc 31) (fx=? cc 127)))) (define (ascii-non-control? x) (let ((cc (ensure-int x))) (fx<=? 32 cc 126))) (define (ascii-whitespace? x) (let ((cc (ensure-int x))) (cond ((fxchar (fx+ 48 n)))) (define (ascii-nth-upper-case n) (integer->char (fx+ 65 (fxmod n 26)))) (define (ascii-nth-lower-case n) (integer->char (fx+ 97 (fxmod n 26)))) (define (ascii-upcase x) (if (char? x) (integer->char (ascii-upcase (char->integer x))) (or (ascii-lower-case-value x 65 26) x))) (define (ascii-downcase x) (if (char? x) (integer->char (ascii-downcase (char->integer x))) (or (ascii-upper-case-value x 97 26) x))) (define (ascii-control->graphic x) (if (char? x) (char->int->char ascii-control->graphic x) (or (and (fx<=? 0 x 31) (fx+ x 64)) (and (fx=? x 127) 63)))) (define (ascii-graphic->control x) (if (char? x) (char->int->char ascii-graphic->control x) (or (and (fx<=? 64 x 95) (fx- x 64)) (and (fx=? x 63) 127)))) (define (ascii-mirror-bracket x) (if (char? x) (case x ((#\() #\)) ((#\)) #\() ((#\[) #\]) ((#\]) #\[) ((#\{) #\}) ((#\}) #\{) ((#\<) #\>) ((#\>) #\<) (else #f)) (let ((x (ascii-mirror-bracket (integer->char x)))) (and x (char->integer x))))) (define (ascii-ci-cmp char1 char2) (let ((cc1 (ensure-int char1)) (cc2 (ensure-int char2))) (when (fx<=? 65 cc1 90) (set! cc1 (fx+ cc1 32))) (when (fx<=? 65 cc2 90) (set! cc2 (fx+ cc2 32))) (cond ((fx? cc1 cc2) 1) (else 0)))) (define (ascii-ci=? char1 char2) (fx=? (ascii-ci-cmp char1 char2) 0)) (define (ascii-ci? char1 char2) (fx>? (ascii-ci-cmp char1 char2) 0)) (define (ascii-ci<=? char1 char2) (fx<=? (ascii-ci-cmp char1 char2) 0)) (define (ascii-ci>=? char1 char2) (fx>=? (ascii-ci-cmp char1 char2) 0)) (define (ascii-string-ci-cmp string1 string2) (call-with-port (open-string-input-port string1) (lambda (in1) (call-with-port (open-string-input-port string2) (lambda (in2) (let loop () (let ((char1 (read-char in1)) (char2 (read-char in2))) (cond ((eof-object? char1) (if (eof-object? char2) 0 -1)) ((eof-object? char2) 1) (else (let ((cc1 (char->integer char1)) (cc2 (char->integer char2))) (when (fx<=? 65 cc1 90) (set! cc1 (fx+ cc1 32))) (when (fx<=? 65 cc2 90) (set! cc2 (fx+ cc2 32))) (cond ((fx? cc1 cc2) 1) (else (loop))))))))))))) (define (ascii-string-ci=? string1 string2) (fx=? (ascii-string-ci-cmp string1 string2) 0)) (define (ascii-string-ci? string1 string2) (fx>? (ascii-string-ci-cmp string1 string2) 0)) (define (ascii-string-ci<=? string1 string2) (fx<=? (ascii-string-ci-cmp string1 string2) 0)) (define (ascii-string-ci>=? string1 string2) (fx>=? (ascii-string-ci-cmp string1 string2) 0))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19.sls000066400000000000000000000034701375154206600201730ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :19) (export add-duration add-duration! copy-time current-date current-julian-day current-modified-julian-day current-time date->julian-day date->modified-julian-day date->string date->time-monotonic date->time-tai date->time-utc date-day date-hour date-minute date-month date-nanosecond date-second date-week-day date-week-number date-year date-year-day date-zone-offset date? julian-day->date julian-day->time-monotonic julian-day->time-tai julian-day->time-utc make-date make-time modified-julian-day->date modified-julian-day->time-monotonic modified-julian-day->time-tai modified-julian-day->time-utc set-time-nanosecond! set-time-second! set-time-type! string->date subtract-duration subtract-duration! time-difference time-difference! time-duration time-monotonic time-monotonic->date time-monotonic->julian-day time-monotonic->modified-julian-day time-monotonic->time-tai time-monotonic->time-tai! time-monotonic->time-utc time-monotonic->time-utc! time-nanosecond time-process time-resolution time-second time-tai 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-thread time-type 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! time<=? time=? time>? time?) (import (srfi :19 time)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/000077500000000000000000000000001375154206600174445ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/srfi-19-test-suite.scm000066400000000000000000000163351375154206600234560ustar00rootroot00000000000000;;; simple test procedures (define s19-tests (list)) (define (define-s19-test! name thunk) (let ((name (if (symbol? name) name (string->symbol name))) (pr (assoc name s19-tests))) (if pr (set-cdr! pr thunk) (set! s19-tests (append s19-tests (list (cons name thunk))))))) (define (run-s19-test name thunk verbose) (if verbose (begin (display ";;; Running ") (display name))) (let ((result (thunk))) (if verbose (begin (display ": ") (display (not (not result))) (newline))) result)) (define (run-s19-tests . verbose) (let ((runs 0) (goods 0) (bads 0) (verbose (if (cdr verbose) (cdr verbose) #f))) (for-each (lambda (pr) (set! runs (+ runs 1)) (if (run-s19-test (car pr) (cdr pr) verbose) (set! goods (+ goods 1)) (set! bads (+ bads 1)))) s19-tests) (if verbose (begin (display ";;; Results: Runs: ") (display runs) (display "; Goods: ") (display goods) (display "; Bads: ") (display bads) (if (> runs 0) (begin (display "; Pass rate: ") (display (/ goods runs))) (display "; No tests.")) (newline))) (values runs goods bads))) (set! s19-tests (list)) (define-s19-test! "Creating time structures" (lambda () (not (null? (list (current-time 'time-tai) (current-time 'time-utc) (current-time 'time-monotonic) (current-time 'time-thread) (current-time 'time-process)))))) (define-s19-test! "Testing time resolutions" (lambda () (not (null? (list (time-resolution 'time-tai) (time-resolution 'time-utc) (time-resolution 'time-monotonic) (time-resolution 'time-thread) (time-resolution 'time-process)))))) (define-s19-test! "Time comparisons (time=?, etc.)" (lambda () (let ((t1 (make-time 'time-utc 0 1)) (t2 (make-time 'time-utc 0 1)) (t3 (make-time 'time-utc 0 2)) (t11 (make-time 'time-utc 1001 1)) (t12 (make-time 'time-utc 1001 1)) (t13 (make-time 'time-utc 1001 2)) ) (and (time=? t1 t2) (time>? t3 t2) (time=? t1 t2) (time>=? t3 t2) (time<=? t1 t2) (time<=? t2 t3) (time=? t11 t12) (time>? t13 t12) (time=? t11 t12) (time>=? t13 t12) (time<=? t11 t12) (time<=? t12 t13) )))) (define-s19-test! "Time difference" (lambda () (let ((t1 (make-time 'time-utc 0 3000)) (t2 (make-time 'time-utc 0 1000)) (t3 (make-time 'time-duration 0 2000)) (t4 (make-time 'time-duration 0 -2000))) (and (time=? t3 (time-difference t1 t2)) (time=? t4 (time-difference t2 t1)))))) (define (test-one-utc-tai-edge utc tai-diff tai-last-diff) (let* (;; right on the edge they should be the same (utc-basic (make-time 'time-utc 0 utc)) (tai-basic (make-time 'time-tai 0 (+ utc tai-diff))) (utc->tai-basic (time-utc->time-tai utc-basic)) (tai->utc-basic (time-tai->time-utc tai-basic)) ;; a second before they should be the old diff (utc-basic-1 (make-time 'time-utc 0 (- utc 1))) (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1))) (utc->tai-basic-1 (time-utc->time-tai utc-basic-1)) (tai->utc-basic-1 (time-tai->time-utc tai-basic-1)) ;; a second later they should be the new diff (utc-basic+1 (make-time 'time-utc 0 (+ utc 1))) (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1))) (utc->tai-basic+1 (time-utc->time-tai utc-basic+1)) (tai->utc-basic+1 (time-tai->time-utc tai-basic+1)) ;; ok, let's move the clock half a month or so plus half a second (shy (* 15 24 60 60)) (hs (/ (expt 10 9) 2)) ;; a second later they should be the new diff (utc-basic+2 (make-time 'time-utc hs (+ utc shy))) (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy))) (utc->tai-basic+2 (time-utc->time-tai utc-basic+2)) (tai->utc-basic+2 (time-tai->time-utc tai-basic+2)) ) (and (time=? utc-basic tai->utc-basic) (time=? tai-basic utc->tai-basic) (time=? utc-basic-1 tai->utc-basic-1) (time=? tai-basic-1 utc->tai-basic-1) (time=? utc-basic+1 tai->utc-basic+1) (time=? tai-basic+1 utc->tai-basic+1) (time=? utc-basic+2 tai->utc-basic+2) (time=? tai-basic+2 utc->tai-basic+2) ))) (define-s19-test! "TAI-UTC Conversions" (lambda () (and (test-one-utc-tai-edge 915148800 32 31) (test-one-utc-tai-edge 867715200 31 30) (test-one-utc-tai-edge 820454400 30 29) (test-one-utc-tai-edge 773020800 29 28) (test-one-utc-tai-edge 741484800 28 27) (test-one-utc-tai-edge 709948800 27 26) (test-one-utc-tai-edge 662688000 26 25) (test-one-utc-tai-edge 631152000 25 24) (test-one-utc-tai-edge 567993600 24 23) (test-one-utc-tai-edge 489024000 23 22) (test-one-utc-tai-edge 425865600 22 21) (test-one-utc-tai-edge 394329600 21 20) (test-one-utc-tai-edge 362793600 20 19) (test-one-utc-tai-edge 315532800 19 18) (test-one-utc-tai-edge 283996800 18 17) (test-one-utc-tai-edge 252460800 17 16) (test-one-utc-tai-edge 220924800 16 15) (test-one-utc-tai-edge 189302400 15 14) (test-one-utc-tai-edge 157766400 14 13) (test-one-utc-tai-edge 126230400 13 12) (test-one-utc-tai-edge 94694400 12 11) (test-one-utc-tai-edge 78796800 11 10) (test-one-utc-tai-edge 63072000 10 0) (test-one-utc-tai-edge 0 0 0) ;; at the epoch (test-one-utc-tai-edge 10 0 0) ;; close to it ... (test-one-utc-tai-edge 1045789645 32 32) ;; about now ... ))) (define (tm:date= d1 d2) (and (= (date-year d1) (date-year d2)) (= (date-month d1) (date-month d2)) (= (date-day d1) (date-day d2)) (= (date-hour d1) (date-hour d2)) (= (date-second d1) (date-second d2)) (= (date-nanosecond d1) (date-nanosecond d2)) (= (date-zone-offset d1) (date-zone-offset d2)))) (define-s19-test! "TAI-Date Conversions" (lambda () (and (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0) (make-date 0 58 59 23 31 12 1998 0)) (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0) (make-date 0 59 59 23 31 12 1998 0)) (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0) (make-date 0 60 59 23 31 12 1998 0)) (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0) (make-date 0 0 0 0 1 1 1999 0))))) (define-s19-test! "Date-UTC Conversions" (lambda () (and (time=? (make-time time-utc 0 (- 915148800 2)) (date->time-utc (make-date 0 58 59 23 31 12 1998 0))) (time=? (make-time time-utc 0 (- 915148800 1)) (date->time-utc (make-date 0 59 59 23 31 12 1998 0))) ;; yes, I think this is acutally right. (time=? (make-time time-utc 0 (- 915148800 0)) (date->time-utc (make-date 0 60 59 23 31 12 1998 0))) (time=? (make-time time-utc 0 (- 915148800 0)) (date->time-utc (make-date 0 0 0 0 1 1 1999 0))) (time=? (make-time time-utc 0 (+ 915148800 1)) (date->time-utc (make-date 0 1 0 0 1 1 1999 0)))))) (define-s19-test! "TZ Offset conversions" (lambda () (let ((ct-utc (make-time time-utc 6320000 1045944859)) (ct-tai (make-time time-tai 6320000 1045944891)) (cd (make-date 6320000 19 14 15 22 2 2003 -18000))) (and (time=? ct-utc (date->time-utc cd)) (time=? ct-tai (date->time-tai cd)))))) (begin (newline) (run-s19-tests #t)) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/srfi-19.scm000066400000000000000000001471351375154206600213550ustar00rootroot00000000000000;; SRFI-19: Time Data Types and Procedures. ;; ;; Copyright (C) I/NET, Inc. (2000, 2002, 2003). All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining ;; a copy of this software and associated documentation files (the ;; "Software"), to deal in the Software without restriction, including ;; without limitation the rights to use, copy, modify, merge, publish, ;; distribute, sublicense, and/or sell copies of the Software, and to ;; permit persons to whom the Software is furnished to do so, subject to ;; the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; -- Bug fixes. ;; ;; MAKE-TIME had parameters seconds and nanoseconds reversed; change all ;; references in file to match. Will F: 2002-10-15 ;; ;; DATE-YEAR-DAY returned the wrong day; tm:year-day fixed to do the right ;; thing. Will F: 2002-10-15 ;; It also called an undefined error procedure. ;; ;; DISPLAYING procedure removed. Will F: 2002-10-15. ;; ;; TM:NANO constant corrected. 2002-11-04. ;; ;; The following fixes by Will Fitzgerald, February, 2003. ;; -- Thanks to Steven Ma and others. ;; ;; (CURRENT-TIME 'TIME-THREAD) added. ;; ;; TIME-RESOLUTION for TIME-PROCESS added. ;; ;; TIME comparison procedures (time=?, etc. fixed. ;; ;; Corrected errors in converting between TAI and UTC time. ;; ;; TAI and UTC date converters no longer look at leap seconds, ;; which was an error. ;; ;; corrections to calls to tm:time-error ;; ;; timezone offset not used in date->time-utc and date->julian-day ;; ;; typos in tm:integer-reader-exact, tm:string->date, ;; time-monotonic->time-utc!, tm:char->int fixed ;; ;; corrected "~k", "~f" formatting for date->string (includes fix for ;; "~4" ;; ;; 'split-real' fixed. ;; ;; fixed julian-day->time-utc and variants. ;; ;; changes 2003-02-26, based on comments by Martin Gasbichler. ;; ;; moronic, overly complicated COPY-TIME procedure changed ;; to simple version suggested by Martin Gasbichler. ;; ;; To provide more portability, changed #\Space to #\space ;; and #\tab to #\Tab to (integer->char 9) ;; ;; changed arity-3 calls to / and - to arity 2 calls (again, ;; for more general portability). ;; ;; split-real fixed again -- by removing it, and using ;; 'fractional part'. Will Fitzgerald 5/16/2003. ;; -------------------------------------------------------------- (define-syntax receive (syntax-rules () ((receive formals expression body ...) (call-with-values (lambda () expression) (lambda formals body ...))))) ;;; -- we want receive later on for a couple of small things ;; ;; :OPTIONAL is nice, too (define-syntax :optional (syntax-rules () ((_ val default-value) (if (null? val) default-value (car val))))) (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) ;; example of extension (MZScheme specific) (define time-gc 'time-gc) ;;-- LOCALE dependent constants (define tm:locale-number-separator ".") (define tm:locale-abbr-weekday-vector (vector "Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat")) (define tm:locale-long-weekday-vector (vector "Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) ;; note empty string in 0th place. (define tm:locale-abbr-month-vector (vector "" "Jan" "Feb" "Mar" "Apr" "May" "Jun" "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")) (define tm:locale-long-month-vector (vector "" "January" "February" "March" "April" "May" "June" "July" "August" "September" "October" "November" "December")) (define tm:locale-pm "PM") (define tm:locale-am "AM") ;; See date->string (define tm:locale-date-time-format "~a ~b ~d ~H:~M:~S~z ~Y") (define tm:locale-short-date-format "~m/~d/~y") (define tm:locale-time-format "~H:~M:~S") (define tm:iso-8601-date-time-format "~Y-~m-~dT~H:~M:~S~z") ;;-- Miscellaneous Constants. ;;-- only the tm:tai-epoch-in-jd might need changing if ;; a different epoch is used. (define tm:nano (expt 10 9)) (define tm:sid 86400) ; seconds in a day (define tm:sihd 43200) ; seconds in a half day (define tm:tai-epoch-in-jd 4881175/2) ; julian day number for 'the epoch' ;;; A Very simple Error system for the time procedures ;;; (define tm:time-error-types '(invalid-clock-type unsupported-clock-type incompatible-time-types not-duration dates-are-immutable bad-date-format-string bad-date-template-string invalid-month-specification )) (define (tm:time-error caller type value) (if (member type tm:time-error-types) (if value (error caller "TIME-ERROR type ~S: ~S" type value) (error caller "TIME-ERROR type ~S" type)) (error caller "TIME-ERROR unsupported error type ~S" type))) ;; 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! tm:leap-second-table (tm:read-tai-utc-date "tai-utc.dat")) (define (tm:read-tai-utc-data filename) (define (convert-jd jd) (* (- (inexact->exact jd) tm:tai-epoch-in-jd) tm: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 ( utc seconds since epoch . # seconds to add for tai ) ;; note they go higher to lower, and end in 1972. (define tm:leap-second-table '((1483228800 . 37) (1435708800 . 36) (1341100800 . 35) (1230768000 . 34) (1136073600 . 33) (915148800 . 32) (867715200 . 31) (820454400 . 30) (773020800 . 29) (741484800 . 28) (709948800 . 27) (662688000 . 26) (631152000 . 25) (567993600 . 24) (489024000 . 23) (425865600 . 22) (394329600 . 21) (362793600 . 20) (315532800 . 19) (283996800 . 18) (252460800 . 17) (220924800 . 16) (189302400 . 15) (157766400 . 14) (126230400 . 13) (94694400 . 12) (78796800 . 11) (63072000 . 10))) (define (read-leap-second-table filename) (set! tm:leap-second-table (tm:read-tai-utc-data filename)) (values)) (define (tm: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 tm:sid)) 0 (lsd tm:leap-second-table)))) ;; going from tai seconds to utc seconds ... (define (tm:leap-second-neg-delta tai-seconds) (letrec ( (lsd (lambda (table) (cond ((null? table) 0) ((<= (cdar table) (- tai-seconds (caar table))) (cdar table)) (else (lsd (cdr table)))))) ) (if (< tai-seconds (* (- 1972 1970) 365 tm:sid)) 0 (lsd tm:leap-second-table)))) ;;; the time structure; creates the accessors, too. ;;; wf: changed to match srfi documentation. uses mzscheme structures & inspectors (define-struct time (type nanosecond second) (make-inspector)) ;; thanks, Martin Gasbichler ... (define (copy-time time) (make-time (time-type time) (time-nanosecond time) (time-second time) )) ;;; current-time ;;; specific time getters. ;;; these should be rewritten to be os specific. ;; ;; -- using gnu gettimeofday() would be useful here -- gets ;; second + millisecond ;; let's pretend we do, using mzscheme's current-seconds & current-milliseconds ;; this is supposed to return utc. ;; (define (tm:get-time-of-day) (values (current-seconds) (abs (remainder (current-milliseconds) 1000)))) (define (tm:current-time-utc) (receive (seconds ms) (tm:get-time-of-day) (make-time time-utc (* ms 10000) seconds ))) (define (tm:current-time-tai) (receive (seconds ms) (tm:get-time-of-day) (make-time time-tai (* ms 10000) (+ seconds (tm:leap-second-delta seconds)) ))) (define (tm:current-time-ms-time time-type proc) (let ((current-ms (proc))) (make-time time-type (* (remainder current-ms 1000) 10000) (quotient current-ms 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 (tm:current-time-monotonic) (receive (seconds ms) (tm:get-time-of-day) (make-time time-monotonic (* ms 10000) (+ seconds (tm:leap-second-delta seconds)) ))) (define (tm:current-time-thread) (tm:current-time-ms-time time-process current-process-milliseconds)) (define (tm:current-time-process) (tm:current-time-ms-time time-process current-process-milliseconds)) (define (tm:current-time-gc) (tm:current-time-ms-time time-gc current-gc-milliseconds)) (define (current-time . clock-type) (let ( (clock-type (:optional clock-type time-utc)) ) (cond ((eq? clock-type time-tai) (tm:current-time-tai)) ((eq? clock-type time-utc) (tm:current-time-utc)) ((eq? clock-type time-monotonic) (tm:current-time-monotonic)) ((eq? clock-type time-thread) (tm:current-time-thread)) ((eq? clock-type time-process) (tm:current-time-process)) ((eq? clock-type time-gc) (tm:current-time-gc)) (else (tm: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 (:optional clock-type time-utc))) (cond ((eq? clock-type time-tai) 10000) ((eq? clock-type time-utc) 10000) ((eq? clock-type time-monotonic) 10000) ((eq? clock-type time-thread) 10000) ((eq? clock-type time-process) 10000) ((eq? clock-type time-gc) 10000) (else (tm:time-error 'time-resolution 'invalid-clock-type clock-type))))) ;; -- time comparisons (define (tm:time-compare-check time1 time2 caller) (if (or (not (and (time? time1) (time? time2))) (not (eq? (time-type time1) (time-type time2)))) (tm:time-error caller 'incompatible-time-types #f) #t)) (define (time=? time1 time2) (tm:time-compare-check time1 time2 'time=?) (and (= (time-second time1) (time-second time2)) (= (time-nanosecond time1) (time-nanosecond time2)))) (define (time>? time1 time2) (tm:time-compare-check time1 time2 'time>?) (or (> (time-second time1) (time-second time2)) (and (= (time-second time1) (time-second time2)) (> (time-nanosecond time1) (time-nanosecond time2))))) (define (time=? time1 time2) (tm:time-compare-check time1 time2 'time>=?) (or (> (time-second time1) (time-second time2)) (and (= (time-second time1) (time-second time2)) (>= (time-nanosecond time1) (time-nanosecond time2))))) (define (time<=? time1 time2) (tm:time-compare-check time1 time2 'time<=?) (or (< (time-second time1) (time-second time2)) (and (= (time-second time1) (time-second time2)) (<= (time-nanosecond time1) (time-nanosecond time2))))) ;; -- time arithmetic (define (tm:time->nanoseconds time) (define (sign1 n) (if (negative? n) -1 1)) (+ (* (time-second time) tm:nano) (time-nanosecond time))) (define (tm:nanoseconds->time time-type nanoseconds) (make-time time-type (remainder nanoseconds tm:nano) (quotient nanoseconds tm:nano))) (define (tm:nanoseconds->values nanoseconds) (values (abs (remainder nanoseconds tm:nano)) (quotient nanoseconds tm:nano))) (define (tm:time-difference time1 time2 time3) (if (or (not (and (time? time1) (time? time2))) (not (eq? (time-type time1) (time-type time2)))) (tm:time-error 'time-difference 'incompatible-time-types #f)) (set-time-type! time3 time-duration) (if (time=? time1 time2) (begin (set-time-second! time3 0) (set-time-nanosecond! time3 0)) (receive (nanos secs) (tm:nanoseconds->values (- (tm:time->nanoseconds time1) (tm:time->nanoseconds time2))) (set-time-second! time3 secs) (set-time-nanosecond! time3 nanos))) time3) (define (time-difference time1 time2) (tm:time-difference time1 time2 (make-time #f #f #f))) (define (time-difference! time1 time2) (tm:time-difference time1 time2 time1)) (define (tm:add-duration time1 duration time3) (if (not (and (time? time1) (time? duration))) (tm:time-error 'add-duration 'incompatible-time-types #f)) (if (not (eq? (time-type duration) time-duration)) (tm:time-error 'add-duration 'not-duration duration) (let ( (sec-plus (+ (time-second time1) (time-second duration))) (nsec-plus (+ (time-nanosecond time1) (time-nanosecond duration))) ) (let ((r (remainder nsec-plus tm:nano)) (q (quotient nsec-plus tm:nano))) ; (set-time-type! time3 (time-type time1)) (if (negative? r) (begin (set-time-second! time3 (+ sec-plus q -1)) (set-time-nanosecond! time3 (+ tm:nano r))) (begin (set-time-second! time3 (+ sec-plus q)) (set-time-nanosecond! time3 r))) time3)))) (define (add-duration time1 duration) (tm:add-duration time1 duration (make-time (time-type time1) #f #f))) (define (add-duration! time1 duration) (tm:add-duration time1 duration time1)) (define (tm:subtract-duration time1 duration time3) (if (not (and (time? time1) (time? duration))) (tm:time-error 'add-duration 'incompatible-time-types #f)) (if (not (eq? (time-type duration) time-duration)) (tm:time-error 'tm:subtract-duration 'not-duration duration) (let ( (sec-minus (- (time-second time1) (time-second duration))) (nsec-minus (- (time-nanosecond time1) (time-nanosecond duration))) ) (let ((r (remainder nsec-minus tm:nano)) (q (quotient nsec-minus tm:nano))) (if (negative? r) (begin (set-time-second! time3 (- sec-minus q 1)) (set-time-nanosecond! time3 (+ tm:nano r))) (begin (set-time-second! time3 (- sec-minus q)) (set-time-nanosecond! time3 r))) time3)))) (define (subtract-duration time1 duration) (tm:subtract-duration time1 duration (make-time (time-type time1) #f #f))) (define (subtract-duration! time1 duration) (tm:subtract-duration time1 duration time1)) ;; -- converters between types. (define (tm:time-tai->time-utc! time-in time-out caller) (if (not (eq? (time-type time-in) time-tai)) (tm: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) (tm:leap-second-neg-delta (time-second time-in)))) time-out) (define (time-tai->time-utc time-in) (tm:time-tai->time-utc! time-in (make-time #f #f #f) 'time-tai->time-utc)) (define (time-tai->time-utc! time-in) (tm:time-tai->time-utc! time-in time-in 'time-tai->time-utc!)) (define (tm:time-utc->time-tai! time-in time-out caller) (if (not (eq? (time-type time-in) time-utc)) (tm: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) (tm:leap-second-delta (time-second time-in)))) time-out) (define (time-utc->time-tai time-in) (tm:time-utc->time-tai! time-in (make-time #f #f #f) 'time-utc->time-tai)) (define (time-utc->time-tai! time-in) (tm: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)) (tm:time-error 'time-monotoinc->time-utc 'incompatible-time-types time-in)) (let ((ntime (copy-time time-in))) (set-time-type! ntime time-tai) (tm: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)) (tm:time-error 'time-monotonic->time-utc! 'incompatible-time-types time-in)) (set-time-type! time-in time-tai) (tm:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc)) (define (time-monotonic->time-tai time-in) (if (not (eq? (time-type time-in) time-monotonic)) (tm:time-error 'time-monotonic->time-tai 'incompatible-time-types time-in)) (let ((ntime (copy-time time-in))) (set-time-type! ntime time-tai) ntime)) (define (time-monotonic->time-tai! time-in) (if (not (eq? (time-type time-in) time-monotonic)) (tm:time-error 'time-monotonic->time-tai! 'incompatible-time-types time-in)) (set-time-type! time-in time-tai) time-in) (define (time-utc->time-monotonic time-in) (if (not (eq? (time-type time-in) time-utc)) (tm:time-error 'time-utc->time-monotonic 'incompatible-time-types time-in)) (let ((ntime (tm: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)) (tm:time-error 'time-utc->time-montonic! 'incompatible-time-types time-in)) (let ((ntime (tm: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)) (tm:time-error 'time-tai->time-monotonic 'incompatible-time-types time-in)) (let ((ntime (copy-time time-in))) (set-time-type! ntime time-monotonic) ntime)) (define (time-tai->time-monotonic! time-in) (if (not (eq? (time-type time-in) time-tai)) (tm:time-error 'time-tai->time-monotonic! 'incompatible-time-types time-in)) (set-time-type! time-in time-monotonic) time-in) ;; -- date structures (define-struct date (nanosecond second minute hour day month year zone-offset) (make-inspector)) ;; redefine setters (define tm:set-date-nanosecond! set-date-nanosecond!) (define tm:set-date-second! set-date-second!) (define tm:set-date-minute! set-date-minute!) (define tm:set-date-hour! set-date-hour!) (define tm:set-date-day! set-date-day!) (define tm:set-date-month! set-date-month!) (define tm:set-date-year! set-date-year!) (define tm:set-date-zone-offset! set-date-zone-offset!) (define (set-date-second! date val) (tm:time-error 'set-date-second! 'dates-are-immutable date)) (define (set-date-minute! date val) (tm:time-error 'set-date-minute! 'dates-are-immutable date)) (define (set-date-day! date val) (tm:time-error 'set-date-day! 'dates-are-immutable date)) (define (set-date-month! date val) (tm:time-error 'set-date-month! 'dates-are-immutable date)) (define (set-date-year! date val) (tm:time-error 'set-date-year! 'dates-are-immutable date)) (define (set-date-zone-offset! date val) (tm:time-error 'set-date-zone-offset! 'dates-are-immutable date)) ;; gives the julian day which starts at noon. (define (tm: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 (tm:char-pos char str index len) (cond ((>= index len) #f) ((char=? (string-ref str index) char) index) (else (tm:char-pos char str (+ index 1) len)))) (define (tm:fractional-part r) (if (integer? r) "0" (let ((str (number->string (exact->inexact r)))) (let ((ppos (tm:char-pos #\. str 0 (string-length str)))) (substring str (+ ppos 1) (string-length str)))))) ;; gives the seconds/date/month/year (define (tm:decode-julian-day-number jdn) (let* ((days (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) tm: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 (tm:local-tz-offset) (date-time-zone-offset (seconds->date (current-seconds)))) ;; special thing -- ignores nanos (define (tm:time->julian-day-number seconds tz-offset) (+ (/ (+ seconds tz-offset tm:sihd) tm:sid) tm:tai-epoch-in-jd)) (define (tm:find proc l) (if (null? l) #f (if (proc (car l)) #t (tm:find proc (cdr l))))) (define (tm:tai-before-leap-second? second) (tm:find (lambda (x) (= second (- (+ (car x) (cdr x)) 1))) tm:leap-second-table)) (define (tm:time->date time tz-offset ttype) (if (not (eq? (time-type time) ttype)) (tm:time-error 'time->date 'incompatible-time-types time)) (let* ( (offset (:optional tz-offset (tm:local-tz-offset))) ) (receive (secs date month year) (tm:decode-julian-day-number (tm:time->julian-day-number (time-second time) offset)) (let* ( (hours (quotient secs (* 60 60))) (rem (remainder secs (* 60 60))) (minutes (quotient rem 60)) (seconds (remainder rem 60)) ) (make-date (time-nanosecond time) seconds minutes hours date month year offset))))) (define (time-tai->date time . tz-offset) (if (tm:tai-before-leap-second? (time-second time)) ;; if it's *right* before the leap, we need to pretend to subtract a second ... (let ((d (tm:time->date (subtract-duration! (time-tai->time-utc time) (make-time time-duration 0 1)) tz-offset time-utc))) (tm:set-date-second! d 60) d) (tm:time->date (time-tai->time-utc time) tz-offset time-utc))) (define (time-utc->date time . tz-offset) (tm:time->date time tz-offset time-utc)) ;; again, time-monotonic is the same as time tai (define (time-monotonic->date time . tz-offset) (tm:time->date time tz-offset time-monotonic)) (define (date->time-utc date) (let ( (nanosecond (date-nanosecond date)) (second (date-second date)) (minute (date-minute date)) (hour (date-hour date)) (day (date-day date)) (month (date-month date)) (year (date-year date)) (offset (date-zone-offset date)) ) (let ( (jdays (- (tm:encode-julian-day-number day month year) tm:tai-epoch-in-jd)) ) (make-time time-utc nanosecond (+ (* (- jdays 1/2) 24 60 60) (* hour 60 60) (* minute 60) second (- offset)) )))) (define (date->time-tai d) (if (= (date-second d) 60) (subtract-duration! (time-utc->time-tai! (date->time-utc d)) (make-time time-duration 0 1)) (time-utc->time-tai! (date->time-utc d)))) (define (date->time-monotonic date) (time-utc->time-monotonic! (date->time-utc date))) (define (tm:leap-year? year) (or (= (modulo year 400) 0) (and (= (modulo year 4) 0) (not (= (modulo year 100) 0))))) (define (leap-year? date) (tm:leap-year? (date-year date))) ;; tm:year-day fixed: adding wrong number of days. (define tm:month-assoc '((0 . 0) (1 . 31) (2 . 59) (3 . 90) (4 . 120) (5 . 151) (6 . 181) (7 . 212) (8 . 243) (9 . 273) (10 . 304) (11 . 334))) (define (tm:year-day day month year) (let ((days-pr (assoc (- month 1) tm:month-assoc))) (if (not days-pr) (tm:time-error 'date-year-day 'invalid-month-specification month)) (if (and (tm:leap-year? year) (> month 2)) (+ day (cdr days-pr) 1) (+ day (cdr days-pr))))) (define (date-year-day date) (tm:year-day (date-day date) (date-month date) (date-year date))) ;; from calendar faq (define (tm: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) (tm:week-day (date-day date) (date-month date) (date-year date))) (define (tm: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) (tm:days-before-first-week date day-of-week-starting-week)) 7)) (define (current-date . tz-offset) (time-utc->date (current-time time-utc) (:optional tz-offset (tm:local-tz-offset)))) ;; given a 'two digit' number, find the year within 50 years +/- (define (tm:natural-year n) (let* ( (current-year (date-year (current-date))) (current-century (* (quotient current-year 100) 100)) ) (cond ((>= n 100) n) ((< n 0) n) ((<= (- (+ current-century n) current-year) 50) (+ current-century n)) (else (+ (- current-century 100) n))))) (define (date->julian-day date) (let ( (nanosecond (date-nanosecond date)) (second (date-second date)) (minute (date-minute date)) (hour (date-hour date)) (day (date-day date)) (month (date-month date)) (year (date-year date)) (offset (date-zone-offset date)) ) (+ (tm:encode-julian-day-number day month year) (- 1/2) (+ (/ (/ (+ (* hour 60 60) (* minute 60) second (/ nanosecond tm:nano)) tm:sid) (- offset)))))) (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)) (tm:time-error 'time-utc->julian-day 'incompatible-time-types time)) (+ (/ (+ (time-second time) (/ (time-nanosecond time) tm:nano)) tm:sid) tm: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)) (tm:time-error 'time-tai->julian-day 'incompatible-time-types time)) (+ (/ (+ (- (time-second time) (tm:leap-second-delta (time-second time))) (/ (time-nanosecond time) tm:nano)) tm:sid) tm: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)) (tm:time-error 'time-monotonic->julian-day 'incompatible-time-types time)) (+ (/ (+ (- (time-second time) (tm:leap-second-delta (time-second time))) (/ (time-nanosecond time) tm:nano)) tm:sid) tm: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 ( (nanosecs (* tm:nano tm:sid (- jdn tm:tai-epoch-in-jd))) ) (make-time time-utc (remainder nanosecs tm:nano) (floor (/ nanosecs tm:nano))))) (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 (:optional tz-offset (tm:local-tz-offset)))) (time-utc->date (julian-day->time-utc jdn) offset))) (define (modified-julian-day->date jdn . tz-offset) (let ((offset (:optional tz-offset (tm:local-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 if #f, ;; no padding is done, and it's as if number->string was used. ;; if string is longer than LENGTH, it's as if number->string was used. (define (tm:padding n pad-with length) (let* ( (str (number->string n)) (str-len (string-length str)) ) (if (or (> str-len length) (not pad-with)) str (let* ( (new-str (make-string length pad-with)) (new-str-offset (- (string-length new-str) str-len)) ) (do ((i 0 (+ i 1))) ((>= i (string-length str))) (string-set! new-str (+ new-str-offset i) (string-ref str i))) new-str)))) (define (tm:last-n-digits i n) (abs (remainder i (expt 10 n)))) (define (tm:locale-abbr-weekday n) (vector-ref tm:locale-abbr-weekday-vector n)) (define (tm:locale-long-weekday n) (vector-ref tm:locale-long-weekday-vector n)) (define (tm:locale-abbr-month n) (vector-ref tm:locale-abbr-month-vector n)) (define (tm:locale-long-month n) (vector-ref tm:locale-long-month-vector n)) (define (tm:vector-find needle haystack comparator) (let ((len (vector-length haystack))) (define (tm:vector-find-int index) (cond ((>= index len) #f) ((comparator needle (vector-ref haystack index)) index) (else (tm:vector-find-int (+ index 1))))) (tm:vector-find-int 0))) (define (tm:locale-abbr-weekday->index string) (tm:vector-find string tm:locale-abbr-weekday-vector string=?)) (define (tm:locale-long-weekday->index string) (tm:vector-find string tm:locale-long-weekday-vector string=?)) (define (tm:locale-abbr-month->index string) (tm:vector-find string tm:locale-abbr-month-vector string=?)) (define (tm:locale-long-month->index string) (tm:vector-find string tm:locale-long-month-vector string=?)) ;; do nothing. ;; Your implementation might want to do something... ;; (define (tm:locale-print-time-zone date port) (values)) ;; Again, locale specific. (define (tm:locale-am/pm hr) (if (> hr 11) tm:locale-pm tm:locale-am)) (define (tm: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 (tm:padding hours #\0 2) port) (display (tm:padding minutes #\0 2) port)))) ;; A table of output formatting directives. ;; the first time is the format char. ;; the second is a procedure that takes the date, a padding character ;; (which might be #f), and the output port. ;; (define tm:directives (list (cons #\~ (lambda (date pad-with port) (display #\~ port))) (cons #\a (lambda (date pad-with port) (display (tm:locale-abbr-weekday (date-week-day date)) port))) (cons #\A (lambda (date pad-with port) (display (tm:locale-long-weekday (date-week-day date)) port))) (cons #\b (lambda (date pad-with port) (display (tm:locale-abbr-month (date-month date)) port))) (cons #\B (lambda (date pad-with port) (display (tm:locale-long-month (date-month date)) port))) (cons #\c (lambda (date pad-with port) (display (date->string date tm:locale-date-time-format) port))) (cons #\d (lambda (date pad-with port) (display (tm: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 (tm:padding (date-day date) #\space 2) port))) (cons #\f (lambda (date pad-with port) (if (> (date-nanosecond date) tm:nano) (display (tm:padding (+ (date-second date) 1) pad-with 2) port) (display (tm:padding (date-second date) pad-with 2) port)) (let* ((ns (tm:fractional-part (/ (date-nanosecond date) tm:nano 1.0))) (le (string-length ns))) (if (> le 2) (begin (display tm: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 (tm:padding (date-hour date) pad-with 2) port))) (cons #\I (lambda (date pad-with port) (let ((hr (date-hour date))) (if (> hr 12) (display (tm:padding (- hr 12) pad-with 2) port) (display (tm:padding hr pad-with 2) port))))) (cons #\j (lambda (date pad-with port) (display (tm:padding (date-year-day date) pad-with 3) port))) (cons #\k (lambda (date pad-with port) (display (tm:padding (date-hour date) #\0 2) port))) (cons #\l (lambda (date pad-with port) (let ((hr (if (> (date-hour date) 12) (- (date-hour date) 12) (date-hour date)))) (display (tm:padding hr #\space 2) port)))) (cons #\m (lambda (date pad-with port) (display (tm:padding (date-month date) pad-with 2) port))) (cons #\M (lambda (date pad-with port) (display (tm: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 (tm:padding (date-nanosecond date) pad-with 9) port))) (cons #\p (lambda (date pad-with port) (display (tm: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) tm:nano) (display (tm:padding (+ (date-second date) 1) pad-with 2) port) (display (tm:padding (date-second date) pad-with 2) port)))) (cons #\t (lambda (date pad-with port) (display (integer->char 9) port))) (cons #\T (lambda (date pad-with port) (display (date->string date "~H:~M:~S") port))) (cons #\U (lambda (date pad-with port) (if (> (tm:days-before-first-week date 0) 0) (display (tm:padding (+ (date-week-number date 0) 1) #\0 2) port) (display (tm:padding (date-week-number date 0) #\0 2) port)))) (cons #\V (lambda (date pad-with port) (display (tm: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 tm:locale-short-date-format) port))) (cons #\X (lambda (date pad-with port) (display (date->string date tm:locale-time-format) port))) (cons #\W (lambda (date pad-with port) (if (> (tm:days-before-first-week date 1) 0) (display (tm:padding (+ (date-week-number date 1) 1) #\0 2) port) (display (tm:padding (date-week-number date 1) #\0 2) port)))) (cons #\y (lambda (date pad-with port) (display (tm:padding (tm:last-n-digits (date-year date) 2) pad-with 2) port))) (cons #\Y (lambda (date pad-with port) (display (tm:padding (date-year date) pad-with 4) port))) (cons #\z (lambda (date pad-with port) (tm:tz-printer (date-zone-offset date) port))) (cons #\Z (lambda (date pad-with port) (tm: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 (tm:get-formatter char) (let ( (associated (assoc char tm:directives)) ) (if associated (cdr associated) #f))) (define (tm: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) (tm:date-printer date (+ index 1) format-string str-len port)) (if (= (+ index 1) str-len) ; bad format string. (tm:time-error 'tm: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. (tm:time-error 'tm:date-printer 'bad-date-format-string format-string) (let ( (formatter (tm:get-formatter (string-ref format-string (+ index 2)))) ) (if (not formatter) (tm:time-error 'tm:date-printer 'bad-date-format-string format-string) (begin (formatter date #f port) (tm:date-printer date (+ index 3) format-string str-len port)))))) ((char=? pad-char? #\_) (if (= (+ index 2) str-len) ; bad format string. (tm:time-error 'tm:date-printer 'bad-date-format-string format-string) (let ( (formatter (tm:get-formatter (string-ref format-string (+ index 2)))) ) (if (not formatter) (tm:time-error 'tm:date-printer 'bad-date-format-string format-string) (begin (formatter date #\space port) (tm:date-printer date (+ index 3) format-string str-len port)))))) (else (let ( (formatter (tm:get-formatter (string-ref format-string (+ index 1)))) ) (if (not formatter) (tm:time-error 'tm:date-printer 'bad-date-format-string format-string) (begin (formatter date #\0 port) (tm:date-printer date (+ index 2) format-string str-len port)))))))))))) (define (date->string date . format-string) (let ( (str-port (open-output-string)) (fmt-str (:optional format-string "~c")) ) (tm:date-printer date 0 fmt-str (string-length fmt-str) str-port) (get-output-string str-port))) (define (tm:char->int ch) (cond ((char=? ch #\0) 0) ((char=? ch #\1) 1) ((char=? ch #\2) 2) ((char=? ch #\3) 3) ((char=? ch #\4) 4) ((char=? ch #\5) 5) ((char=? ch #\6) 6) ((char=? ch #\7) 7) ((char=? ch #\8) 8) ((char=? ch #\9) 9) (else (tm:time-error 'string->date 'bad-date-template-string (list "Non-integer character" ch ))))) ;; read an integer upto n characters long on port; upto -> #f if any length (define (tm:integer-reader upto port) (define (accum-int port accum nchars) (let ((ch (peek-char port))) (if (or (eof-object? ch) (not (char-numeric? ch)) (and upto (>= nchars upto ))) accum (accum-int port (+ (* accum 10) (tm:char->int (read-char port))) (+ nchars 1))))) (accum-int port 0 0)) (define (tm:make-integer-reader upto) (lambda (port) (tm:integer-reader upto port))) ;; read an fractional integer upto n characters long on port; upto -> #f if any length ;; ;; The return value is normalized to upto decimal places. For example, if upto is 9 and ;; the string read is "123", the return value is 123000000. (define (tm:fractional-integer-reader upto port) (define (accum-int port accum nchars) (let ((ch (peek-char port))) (if (or (eof-object? ch) (not (char-numeric? ch)) (and upto (>= nchars upto ))) (* accum (expt 10 (- upto nchars))) (accum-int port (+ (* accum 10) (tm:char->int (read-char port))) (+ nchars 1))))) (accum-int port 0 0)) (define (tm:make-fractional-integer-reader upto) (lambda (port) (tm:fractional-integer-reader upto port))) ;; read *exactly* n characters and convert to integer; could be padded (define (tm: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) (tm: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) (tm: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 (tm:time-error 'string->date 'bad-date-template-string "Non-numeric characters in integer read."))))) (accum-int port 0 0))) (define (tm:make-integer-exact-reader n) (lambda (port) (tm:integer-reader-exact n port))) (define (tm:zone-reader port) (let ( (offset 0) (positive? #f) ) (let ( (ch (read-char port)) ) (if (eof-object? ch) (tm: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 (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone +/-" ch)))) (let ((ch (read-char port))) (if (eof-object? ch) (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch))) (set! offset (* (tm:char->int ch) 10 60 60))) (let ((ch (read-char port))) (if (eof-object? ch) (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch))) (set! offset (+ offset (* (tm:char->int ch) 60 60)))) (let ((ch (read-char port))) (if (eof-object? ch) (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch))) (set! offset (+ offset (* (tm:char->int ch) 10 60)))) (let ((ch (read-char port))) (if (eof-object? ch) (tm:time-error 'string->date 'bad-date-template-string (list "Invalid time zone number" ch))) (set! offset (+ offset (* (tm:char->int ch) 60)))) (if positive? offset (- offset))))))) ;; looking at a char, read the char string, run thru indexer, return index (define (tm:locale-reader port indexer) (let ( (string-port (open-output-string)) ) (define (read-char-string) (let ((ch (peek-char port))) (if (char-alphabetic? ch) (begin (write-char (read-char port) string-port) (read-char-string)) (get-output-string string-port)))) (let* ( (str (read-char-string)) (index (indexer str)) ) (if index index (tm:time-error 'string->date 'bad-date-template-string (list "Invalid string for " indexer)))))) (define (tm:make-locale-reader indexer) (lambda (port) (tm:locale-reader port indexer))) (define (tm:make-char-id-reader char) (lambda (port) (if (char=? char (read-char port)) char (tm: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 tm:read-directives (let ( (ireader4 (tm:make-integer-reader 4)) (ireader2 (tm:make-integer-reader 2)) (fireader9 (tm:make-fractional-integer-reader 9)) (ireaderf (tm:make-integer-reader #f)) (eireader2 (tm:make-integer-exact-reader 2)) (eireader4 (tm:make-integer-exact-reader 4)) (locale-reader-abbr-weekday (tm:make-locale-reader tm:locale-abbr-weekday->index)) (locale-reader-long-weekday (tm:make-locale-reader tm:locale-long-weekday->index)) (locale-reader-abbr-month (tm:make-locale-reader tm:locale-abbr-month->index)) (locale-reader-long-month (tm:make-locale-reader tm:locale-long-month->index)) (char-fail (lambda (ch) #t)) (do-nothing (lambda (val object) (values))) ) (list (list #\~ char-fail (tm: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) (tm:set-date-month! object val))) (list #\B char-alphabetic? locale-reader-long-month (lambda (val object) (tm:set-date-month! object val))) (list #\d char-numeric? ireader2 (lambda (val object) (tm:set-date-day! object val))) (list #\e char-fail eireader2 (lambda (val object) (tm:set-date-day! object val))) (list #\h char-alphabetic? locale-reader-abbr-month (lambda (val object) (tm:set-date-month! object val))) (list #\H char-numeric? ireader2 (lambda (val object) (tm:set-date-hour! object val))) (list #\k char-fail eireader2 (lambda (val object) (tm:set-date-hour! object val))) (list #\m char-numeric? ireader2 (lambda (val object) (tm:set-date-month! object val))) (list #\M char-numeric? ireader2 (lambda (val object) (tm:set-date-minute! object val))) (list #\N char-numeric? fireader9 (lambda (val object) (tm:set-date-nanosecond! object val))) (list #\S char-numeric? ireader2 (lambda (val object) (tm:set-date-second! object val))) (list #\y char-fail eireader2 (lambda (val object) (tm:set-date-year! object (tm:natural-year val)))) (list #\Y char-numeric? ireader4 (lambda (val object) (tm:set-date-year! object val))) (list #\z (lambda (c) (or (char=? c #\Z) (char=? c #\z) (char=? c #\+) (char=? c #\-))) tm:zone-reader (lambda (val object) (tm:set-date-zone-offset! object val))) ))) (define (tm:string->date date index format-string str-len port template-string) (define (skip-until port skipper) (let ((ch (peek-char port))) (if (eof-object? ch) (tm: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))) (tm:time-error 'string->date 'bad-date-format-string template-string)) (tm:string->date date (+ index 1) format-string str-len port template-string)) ;; otherwise, it's an escape, we hope (if (> (+ index 1) str-len) (tm:time-error 'string->date 'bad-date-format-string template-string) (let* ( (format-char (string-ref format-string (+ index 1))) (format-info (assoc format-char tm:read-directives)) ) (if (not format-info) (tm: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) (tm:time-error 'string->date 'bad-date-format-string template-string) (actor val date))) (tm:string->date date (+ index 2) format-string str-len port template-string)))))))))) (define (string->date input-string template-string) (define (tm: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 (tm:local-tz-offset))) ) (tm:string->date newdate 0 template-string (string-length template-string) (open-input-string input-string) template-string) (if (tm:date-ok? newdate) newdate (tm:time-error 'string->date 'bad-date-format-string (list "Incomplete date read. " newdate template-string))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/time.sls000066400000000000000000000133311375154206600211260ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :19 time) (export time-duration time-monotonic time-process time-tai time-thread time-utc current-date current-julian-day current-modified-julian-day current-time time-resolution make-time time? time-type time-nanosecond time-second set-time-type! set-time-nanosecond! set-time-second! copy-time time<=? time=? time>? time-difference time-difference! add-duration add-duration! subtract-duration subtract-duration! 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 date->julian-day date->modified-julian-day date->time-monotonic date->time-tai date->time-utc julian-day->date julian-day->time-monotonic julian-day->time-tai julian-day->time-utc modified-julian-day->date modified-julian-day->time-monotonic modified-julian-day->time-tai modified-julian-day->time-utc time-monotonic->date time-monotonic->julian-day time-monotonic->modified-julian-day time-monotonic->time-tai time-monotonic->time-tai! time-monotonic->time-utc time-monotonic->time-utc! time-tai->date time-tai->julian-day time-tai->modified-julian-day time-tai->time-monotonic time-tai->time-monotonic! time-tai->time-utc time-tai->time-utc! time-utc->date time-utc->julian-day time-utc->modified-julian-day time-utc->time-monotonic time-utc->time-monotonic! time-utc->time-tai time-utc->time-tai! date->string string->date) (import (rnrs) (rnrs r5rs) (rnrs mutable-strings) (prefix (srfi :19 time compat) host:) (srfi :6 basic-string-ports) (for (srfi private vanish) expand) (srfi private include)) (define-syntax define-struct (lambda (stx) (define (id-append x . r) (datum->syntax x (string->symbol (apply string-append (map (lambda (y) (if (identifier? y) (symbol->string (syntax->datum y)) y)) r))))) (syntax-case stx () ((_ name (field ...) _) (with-syntax (((accessor ...) (map (lambda (x) (id-append x #'name "-" x)) #'(field ...))) ((mutator ...) (map (lambda (x) (id-append x "set-" #'name "-" x "!")) #'(field ...)))) #'(define-record-type name (fields (mutable field accessor mutator) ...))))))) (define read-line get-line) (define (tm:time-error caller type value) (define (message x) (if (symbol? x) (list->string (map (lambda (c) (if (char=? #\- c) #\space c)) (string->list (symbol->string x)))) (call-with-string-output-port (lambda (sop) (write x sop))))) (apply assertion-violation caller (message type) (if value (list value) '()))) (define (my:time-helper current-time type proc) (let ((x (current-time))) (make-time type (host:time-nanosecond x) (proc (host:time-second x))))) (define (my:leap-second-helper s) (+ s (tm:leap-second-delta s))) (define (tm:current-time-utc) (my:time-helper host:current-time time-utc values)) (define (tm:current-time-tai) (my:time-helper host:current-time time-tai my:leap-second-helper)) (define (tm:current-time-monotonic) (my:time-helper host:current-time time-monotonic my:leap-second-helper)) (define (tm:current-time-thread) (my:time-helper host:cumulative-thread-time time-thread values)) (define (tm:current-time-process) (my:time-helper host:cumulative-process-time time-process values)) (define (tm:current-time-gc) (my:time-helper host:cumulative-gc-time time-gc values)) (define (time-resolution . clock-type) host:time-resolution) (define (tm:local-tz-offset) host:timezone-offset) (define eof (eof-object)) (let-syntax ((define (vanish-define define (tm:time-error-types tm:time-error tm:get-time-of-day tm:current-time-utc tm:current-time-tai tm:current-time-ms-time tm:current-time-monotonic tm:current-time-thread tm:current-time-process tm:current-time-gc time-resolution set-date-nanosecond! set-date-second! set-date-minute! set-date-hour! set-date-day! set-date-month! set-date-year! set-date-zone-offset! tm:local-tz-offset)))) (include/resolve ("srfi" "%3a19") "srfi-19.scm")) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/time/000077500000000000000000000000001375154206600204025ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/time/compat.chezscheme.sls000066400000000000000000000025461375154206600245340ustar00rootroot00000000000000;;; Copyright (c) 2012 Aaron W. Hsu ;;; ;;; Permission to use, copy, modify, and distribute this software for ;;; any purpose with or without fee is hereby granted, provided that the ;;; above copyright notice and this permission notice appear in all ;;; copies. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE ;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL ;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA ;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR ;;; PERFORMANCE OF THIS SOFTWARE. (library (srfi :19 time compat) (export time-resolution timezone-offset current-time cumulative-thread-time (rename (cpu-time cumulative-process-time)) cumulative-gc-time time-nanosecond time-second) (import (chezscheme)) (define time-resolution 1) (define (cumulative-thread-time . args) (assertion-violation 'cumulative-thread-time "not implemented")) (define (cumulative-gc-time) (sstats-gc-cpu (statistics))) (define timezone-offset (date-zone-offset (time-utc->date (current-time)))) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/time/compat.ikarus.sls000066400000000000000000000013551375154206600237110ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :19 time compat) (export time-resolution timezone-offset current-time cumulative-thread-time cumulative-process-time cumulative-gc-time time-nanosecond time-second) (import (rnrs base) (only (ikarus) current-time time-nanosecond time-second time-gmt-offset) (srfi :19 time not-implemented)) ;; Ikarus uses gettimeofday() which gives microseconds, ;; so our resolution is 1000 nanoseconds (define time-resolution 1000) (define timezone-offset (time-gmt-offset (current-time))) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/time/compat.ironscheme.sls000066400000000000000000000025431375154206600245470ustar00rootroot00000000000000#!r6rs ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an ;; MIT-style license. My license is in the file named LICENSE from the original ;; collection this file is distributed with. If this file is redistributed with ;; some other collection, my license must also be included. (library (srfi :19 time compat) (export time-resolution current-time time-nanosecond time-second timezone-offset cumulative-thread-time cumulative-process-time cumulative-gc-time) (import (rnrs base) (ironscheme datetime) (ironscheme process) (only (srfi :19 time not-implemented) cumulative-gc-time)) (define time-resolution 100) (define base (datetime->local (make-utc-datetime 1970 1 1))) (define (current-time) (now)) ; since 1970, but fractional (100ns per tick in .NET) (define (time-nanosecond t) (mod (* 100 (ticks (difference t base))) #e1e9)) (define (time-second t) (exact (truncate (total-seconds (difference t base))))) (define timezone-offset (exact (truncate (total-seconds (difference (now) (datetime->utc (now))))))) ;; todo: check if parameters correct (define (cumulative-thread-time) (datetime-add base (process-user-cpu-time (get-current-process)))) (define (cumulative-process-time) (datetime-add base (process-total-cpu-time (get-current-process)))) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/time/compat.larceny.sls000066400000000000000000000017461375154206600240540ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :19 time compat) (export time-resolution (rename (my:timezone-offset timezone-offset)) current-time cumulative-thread-time cumulative-process-time cumulative-gc-time time-nanosecond time-second) (import (rnrs base) (primitives r5rs:require current-utc-time timezone-offset) (srfi :19 time not-implemented)) (define dummy (begin (r5rs:require 'time) #F)) ;; Larceny uses gettimeofday() which gives microseconds, ;; so our resolution is 1000 nanoseconds (define time-resolution 1000) (define my:timezone-offset (let-values (((secs _) (current-utc-time))) (timezone-offset secs))) (define (current-time) (let-values (((secs micros) (current-utc-time))) (cons secs (* micros 1000)))) (define time-nanosecond cdr) (define time-second car) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/time/compat.loko.sls000066400000000000000000000013711375154206600233550ustar00rootroot00000000000000;; Copyright © 2019 Göran Weinholt ;; SPDX-License-Identifier: MIT #!r6rs (library (srfi :19 time compat) (export time-resolution timezone-offset current-time cumulative-thread-time cumulative-process-time cumulative-gc-time time-nanosecond time-second) (import (rnrs) (except (loko system time) time-resolution) (prefix (only (loko system time) time-resolution) loko:)) (define time-resolution (loko:time-resolution (current-time))) (define (cumulative-thread-time) (error 'cumulative-thread-time "not implemented")) (define (cumulative-gc-time) (error 'cumulative-gc-time "not implemented")) ;; Loko currently doesn't parse the timezone database (define timezone-offset 0)) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/time/compat.mzscheme.sls000066400000000000000000000025351375154206600242270ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :19 time compat) (export time-resolution timezone-offset current-time cumulative-thread-time cumulative-process-time cumulative-gc-time time-nanosecond time-second) (import (rnrs base) (only (scheme base) current-seconds seconds->date date-time-zone-offset current-inexact-milliseconds current-thread current-process-milliseconds current-gc-milliseconds)) ;; MzScheme uses milliseconds, so our resolution in nanoseconds is #e1e6 (define time-resolution #e1e6) (define timezone-offset (date-time-zone-offset (seconds->date (current-seconds)))) (define (millis->repr x) (let-values (((d m) (div-and-mod x 1000))) (cons d (* m #e1e6)))) (define (current-time) (millis->repr (exact (floor (current-inexact-milliseconds))))) (define (cumulative-thread-time) (millis->repr (current-process-milliseconds (current-thread)))) (define (cumulative-process-time) (millis->repr (current-process-milliseconds #F))) (define (cumulative-gc-time) (millis->repr (current-gc-milliseconds))) (define time-nanosecond cdr) (define time-second car) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/time/compat.ypsilon.sls000066400000000000000000000014271375154206600241100ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :19 time compat) (export time-resolution timezone-offset current-time cumulative-thread-time cumulative-process-time cumulative-gc-time time-nanosecond time-second) (import (rnrs base) (only (core) microsecond microsecond->utc) (srfi :19 time not-implemented)) (define time-resolution 1000) (define timezone-offset (let ((t (microsecond))) (/ (- t (microsecond->utc t)) #e1e6))) (define (current-time) (let-values (((d m) (div-and-mod (microsecond) #e1e6))) (cons d (* m 1000)))) (define time-nanosecond cdr) (define time-second car) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a19/time/not-implemented.sls000066400000000000000000000011711375154206600242260ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :19 time not-implemented) (export cumulative-thread-time cumulative-process-time cumulative-gc-time) (import (rnrs base)) (define (NI who) (lambda _ (assertion-violation who "not implemented"))) (define-syntax not-implemented (syntax-rules () ((_ name ...) (begin (define name (NI 'name)) ...)))) (not-implemented cumulative-thread-time cumulative-process-time cumulative-gc-time) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a2.sls000066400000000000000000000002231375154206600200740ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :2) (export and-let*) (import (srfi :2 and-let*)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a2/000077500000000000000000000000001375154206600173545ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a2/and-let%2a.sls000066400000000000000000000014431375154206600217150ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :2 and-let*) (export and-let*) (import (rnrs)) (define-syntax and-let* (syntax-rules () ((_ . r) (and-let*-core #T . r)))) (define-syntax and-let*-core (lambda (stx) (syntax-case stx () ((kw _ ((var expr) . c) . b) #'(let ((var expr)) (and var (kw var c . b)))) ((kw last ((expr) . c) . b) #'(kw last ((t expr) . c) . b)) ((kw _ (id . c) . b) (identifier? #'id) #'(and id (kw id c . b))) ((_ last ()) #'last) ((_ _ () . b) #'(let () . b))))) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a23.sls000066400000000000000000000002171375154206600201620ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :23) (export error) (import (srfi :23 error)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a23/000077500000000000000000000000001375154206600174375ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a23/error.sls000066400000000000000000000005051375154206600213130ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :23 error) (export error) (import (rename (rnrs base) (error rnrs:error))) (define (error . args) (apply rnrs:error #F args)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a23/error/000077500000000000000000000000001375154206600205705ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a23/error/tricks.sls000066400000000000000000000026401375154206600226140ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :23 error tricks) (export SRFI-23-error->R6RS) (import (rnrs)) (define-syntax error-wrap (lambda (stx) (syntax-case stx () ((_ ctxt signal . forms) (with-syntax ((e (datum->syntax #'ctxt 'error))) #'(let-syntax ((e (identifier-syntax signal))) . forms)))))) (define (AV who) (lambda args (apply assertion-violation who args))) (define-syntax SRFI-23-error->R6RS (lambda (stx) (syntax-case stx () ((ctxt ewho . forms) (with-syntax ((e (datum->syntax #'ctxt 'error)) (d (datum->syntax #'ctxt 'define))) #'(let-syntax ((e (identifier-syntax (AV 'ewho))) (d (lambda (stx) (syntax-case stx () ((kw (id . formals) . body) (identifier? #'id) #'(error-wrap kw (AV 'id) (d (id . formals) . body))) ((kw id . r) (identifier? #'id) #'(error-wrap kw (AV 'id) (d id . r))))))) . forms)))))) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25.sls000066400000000000000000000004401375154206600201620ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :25) (export array array-end array-rank array-ref array-set! array-start array? make-array shape share-array) (import (srfi :25 multi-dimensional-arrays)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25/000077500000000000000000000000001375154206600174415ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25/arlib.scm000066400000000000000000000446461375154206600212540ustar00rootroot00000000000000;;; array arlib ;;; 2001 Jussi Piitulainen ;;; This is a high level implementation of some generally useful ;;; array procedures. In addition to R5RS and SRFI-25, only one ;;; tool is used, namely array:apply-to-vector and friends. Thus ;;; this library serves to prove that the primitives really are ;;; primitives. - A lower level implementation would access some ;;; implementation details to bypass redundant checking and such. ;;; Note that these procedures are not necessarily designed with ;;; full care. Think of them as examples of what can be done. ;;; Important tools are also missing, including scans and reduces ;;; and many thinks that I have not even heard of yet. ;;; (array-shape arr) (array-length arr dim) (array-size arr) ;;; (array-equal? arr1 arr2) ;;; (shape-for-each shp proc [ind]) ;;; (array-for-each-index arr proc [ind]) ;;; (tabulate-array shp proc) (tabulate-array! shp proc ind) ;;; (array-retabulate! arr shp proc [ind]) ;;; (array-map [shp] proc arr0 arr1 ...) ;;; (array-map! arr [shp] proc arr0 arr1 ...) ;;; (array->vector arr) (array->list arr) ;;; (share-array/prefix arr k ...) (share-row arr k) (share-column arr k) ;;; (share-array/origin arr k ...) (share-array/origin arr ind) ;;; (array-append dim arr0 arr1 ...) ;;; (transpose arr dim ...) ;;; (share-nths arr dim n) ;;; Naming problem: should all those index-object using procedures ;;; bang? The main argument, like shape, is not mutated. ;;; (array-shape arr) (define (array-shape arr) (let ((r (array-rank arr))) (let ((m (make-array (shape 0 r 0 2)))) (do ((d 0 (+ d 1))) ((= d r) m) (array-set! m d 0 (array-start arr d)) (array-set! m d 1 (array-end arr d)))))) ;;; (array-length arr dim) (define (array-length arr dim) (- (array-end arr dim) (array-start arr dim))) ;;; (array-size arr) (define (array-size arr) (let ((r (array-rank arr))) (do ((k 0 (+ k 1)) (p 1 (* p (array-length arr k)))) ((= k r) p)))) ;;; (array-equal? a b) ;;; compares elements with equal? so elements better not contain ;;; arrays. (define (array-equal? a b) (let ((r (array-rank a))) (and (= r (array-rank b)) (and (do ((k 0 (+ k 1)) (true #t (and true (= (array-start a k) (array-start b k)) (= (array-end a k) (array-end b k))))) ((= k r) true)) (let ((ks (make-vector r 0))) (let wok ((d 0)) (if (< d r) (let ((e (array-end a d))) (do ((k (array-start a d) (+ k 1)) (true #t (and true (wok (+ d 1))))) ((= k e) true) (vector-set! ks d k))) (equal? (array-ref a ks) (array-ref b ks))))))))) ;;; (shape-for-each shp proc [index-object]) ;;; passes each index in shape to proc in row-major orderd, using ;;; index-object if provided. (define (shape-for-each shp proc . o) (if (null? o) (array:arlib:shape-for-each/arguments shp proc) (if (vector? (car o)) (array:arlib:shape-for-each/vector shp proc (car o)) (array:arlib:shape-for-each/array shp proc (car o))))) (define (array:arlib:shape-for-each/arguments shp proc) (let ((r (array-end shp 0))) (let ((vec (make-vector r))) (let do-dim ((d 0)) (if (= d r) (array:apply-to-vector r proc vec) (let ((e (array-ref shp d 1))) (do ((k (array-ref shp d 0) (+ k 1))) ((= k e)) (vector-set! vec d k) (do-dim (+ d 1))))))))) (define (array:arlib:shape-for-each/vector shp proc vec) (let ((r (array-end shp 0))) (let do-dim ((d 0)) (if (= d r) (proc vec) (let ((e (array-ref shp d 1))) (do ((k (array-ref shp d 0) (+ k 1))) ((= k e)) (vector-set! vec d k) (do-dim (+ d 1)))))))) (define (array:arlib:shape-for-each/array shp proc arr) ;; arr is not vector (let ((r (array-end shp 0))) (let do-dim ((d 0)) (if (= d r) (proc arr) (let ((e (array-ref shp d 1))) (do ((k (array-ref shp d 0) (+ k 1))) ((= k e)) (array-set! arr d k) (do-dim (+ d 1)))))))) ;;; (array-for-each-index arr proc [ind]) ;;; is equivalent to ;;; ;;; (shape-for-each-index (array-shape arr) proc [ind]) ;;; ;;; but is implemented without allocation of the shape, to prove ;;; that it can be so implemented. (define (array-for-each-index arr proc . o) (if (null? o) (array:arlib:array-for-each-index/arguments arr proc) (if (vector? (car o)) (array:arlib:array-for-each-index/vector arr proc (car o)) (array:arlib:array-for-each-index/array arr proc (car o))))) (define (array:arlib:array-for-each-index/arguments arr proc) (let ((r (array-rank arr))) (let ((vec (make-vector r)) (apply (array:applier-to-vector r))) (let do-dim ((d 0)) (if (= d r) (apply proc vec) (let ((e (array-end arr d))) (do ((k (array-start arr d) (+ k 1))) ((= k e)) (vector-set! vec d k) (do-dim (+ d 1))))))))) (define (array:arlib:array-for-each-index/vector arr proc ind) ;; ind is a vector (let ((r (array-rank arr))) (let do-dim ((d 0)) (if (= d r) (proc ind) (let ((e (array-end arr d))) (do ((k (array-start arr d) (+ k 1))) ((= k e)) (vector-set! ind d k) (do-dim (+ d 1)))))))) (define (array:arlib:array-for-each-index/array arr proc ind) ;; ind is an array but not a vector (let ((r (array-rank arr))) (let do-dim ((d 0)) (if (= d r) (proc ind) (let ((e (array-end arr d))) (do ((k (array-start arr d) (+ k 1))) ((= k e)) (array-set! ind d k) (do-dim (+ d 1)))))))) ;;; (tabulate-array shp proc) ;;; (tabulate-array! shp proc ind) ;;; returns a newly allocated array of the given shape with initial ;;; contents at each index whatever proc returns given the indices. ;;; The latter procedure reuses ind for package of indices. (define (tabulate-array shp proc) (let ((arr (make-array shp))) (array:arlib:shape-for-each/vector shp (let ((apply (array:applier-to-vector (array-end shp 0)))) (lambda (ix) (array-set! arr ix (apply proc ix)))) (make-vector (array-end shp 0))) arr)) (define (tabulate-array! shp proc ind) (let ((arr (make-array shp))) (if (vector? ind) (array:arlib:shape-for-each/vector shp (lambda (ix) (array-set! arr ix (proc ix))) ind) (array:arlib:shape-for-each/array shp (lambda (ix) (array-set! arr ix (proc ix))) ind)) arr)) ;;; (array-retabulate! arr shp proc [index-object]) ;;; sets the elements of arr in shape to the value of proc at that ;;; index, using index-object if provided. (define (array-retabulate! arr shp proc . o) (if (null? o) (array:arlib:shape-for-each/vector shp (let ((apply (array:applier-to-vector (array-end shp 0)))) (lambda (ix) (array-set! arr ix (apply proc ix)))) (make-vector (array-end shp 0))) (if (vector? (car o)) (array:arlib:shape-for-each/vector shp (lambda (ix) (array-set! arr ix (proc ix))) (car o)) (array:arlib:shape-for-each/array shp (lambda (ix) (array-set! arr ix (proc ix))) (car o))))) ;;; (array-map! array [shape] proc array0 array1...) ;;; stores to the elements of array (in shape) the values of proc at ;;; the contents of arrayk at corresponding index. (define (array-map! arr x y . o) (if (array:array? x) (array:arlib:map! arr x y (apply vector o)) (array:arlib:map! arr (array-shape arr) x (apply vector y o)))) (define (array:arlib:map! arr shp proc args) (let ((rank (vector-length args))) (let ((argv (make-vector rank))) (array:arlib:shape-for-each/vector shp (let ((apply (array:applier-to-vector rank))) (lambda (ix) (do ((k 0 (+ k 1))) ((= k rank)) (vector-set! argv k (array-ref (vector-ref args k) ix))) (array-set! arr ix (apply proc argv)))) (make-vector (array-end shp 0)))))) ;;; (array-map [shape] proc array0 array1 ...) ;;; creates a new array with elements initialized to the values of ;;; proc at contents of arrayk (in shape). (define (array-map x y . o) (if (array:array? x) (let ((arr (make-array x))) (array:arlib:map! arr x y (apply vector o)) arr) (let ((shp (array-shape y))) (let ((arr (make-array shp))) (array:arlib:map! arr shp x (apply vector y o)) arr)))) ;;; SRFI-25 mailing list requested array->vector; they also requested the ;;; ability to use an array as an index of an element, and array->list is ;;; an attempt to provide for that. (define (array->vector arr) (let ((vec (make-vector (array-size arr)))) (let ((k 0)) (shape-for-each (array-shape arr) (lambda (index) (vector-set! vec k (array-ref arr index)) (set! k (+ k 1))) (make-vector (array-rank arr))) vec))) ;;; It needs to be said that more efficient implementations are ;;; possible, even within SRFI-25. (define (array->list arr) (vector->list (array->vector arr))) ;;; (share-row arr k) ;;; shares whatever the first index is about. ;;; The result has one dimension less. (define (share-row arr k) (share-array arr (let ((bounds (array->list (array-shape arr)))) (apply shape (cddr bounds))) (lambda ks (apply values k ks)))) ;;; (share-array/prefix arr k ...) (define (share-array/prefix arr . js) (if (or (null? js) (integer? (car js))) (share-array arr (let ((bounds (array->list (array-shape arr)))) (apply shape (list-tail bounds (* 2 (length js))))) (lambda ks (apply values (append js ks)))) (apply (lambda (fix) (share-array/prefix! arr fix (make-vector (- (array-rank arr) (if (vector? fix) (vector-length fix) (array-end fix 0)))))) js))) (define (share-array/prefix! arr fix in . out) (let* ((out (if (pair? out) ((lambda (out) out) out) (make-vector (array-rank arr)))) (fix-ref (if (vector? fix) vector-ref array-ref)) (in-ref (if (vector? in) vector-ref array-ref)) (out-set! (if (vector? out) vector-set! array-set!)) (m (if (vector? fix) (vector-length fix) (array-end fix 0))) (n (if (vector? out) (vector-length out) (array-end out 0)))) (do ((k 0 (+ k 1))) ((= k m)) (out-set! out k (fix-ref fix k))) (share-array/index! arr (let ((bounds (array->list (array-shape arr)))) (apply shape (list-tail bounds (if (vector? fix) (* 2 (vector-length fix)) (* 2 (array-end fix 0)))))) (lambda (in) (do ((k m (+ k 1))) ((= k n)) (out-set! out k (in-ref in (- k m)))) out) in))) ;;; (share-column arr k) ;;; shares whatever the second index is about. ;;; The result has one dimension less. (define (share-column arr k) (share-array arr (let ((bounds (array->list (array-shape arr)))) (apply shape (car bounds) (cadr bounds) (cddddr bounds))) (lambda ks (apply values (car ks) k (cdr ks))))) ;;; (share-array/origin arr k ...) ;;; (share-array/origin arr index) ;;; change origin to k ..., with index a vector or zero-based ;;; one-dimensional array that contains k ... ;;; ;;; This is useful for writing array-append. Maybe for something ;;; else too - who knows. (define (share-array/origin arr . xs) (let ((new (if (or (null? xs) (integer? (car xs))) xs (apply (lambda (x) (if (vector? x) (vector->list x) (if (array? x) (array->list x) (error "share-array/origin: bad thing")))) xs)))) (do ((k (array-rank arr) (- k 1)) (old '() (cons (array-start arr (- k 1)) old))) ((= k 0) (let ((ds (map - new old))) (share-array arr (tabulate-array (shape 0 (array-rank arr) 0 2) (lambda (r k) (case k ((0) (+ (array-start arr r) (list-ref ds r))) ((1) (+ (array-end arr r) (list-ref ds r)))))) (lambda ks (apply values (map - ks ds))))))))) ;;; SRFI-25 mailing list requested making shapes their own type. Here's ;;; an example of how manipulating shapes as arrays can be useful. The ;;; example also tests that higher level libraries are indeed easy to ;;; write on top of this SRFI. ;;; (array-append arr1 arr2 dim) ;;; appends two arrays along a specified dimension. The arrays must ;;; have equally many dimensions and all other dimensions equally long. ;;; ;;; Generalize to more arrays and maybe rewrite with shape-for-each or ;;; what have you. (define (array-append dim arr . ars) (let* ((total (do ((m (array-length arr dim) (+ m (array-length (car r) dim))) (r ars (cdr r))) ((null? r) m))) (common (array-shape arr)) (origin (array->vector (share-column common 0))) (index (make-vector (array-rank arr)))) (array-set! common dim 1 (+ (array-start arr dim) total)) (let ((result (make-array common))) (array-set! common dim 1 (array-start arr dim)) (let wok ((arr arr) (ars ars)) (vector-set! origin dim (array-ref common dim 1)) (let ((arr1 (share-array/origin arr origin))) (array-set! common dim 0 (array-start arr1 dim)) (array-set! common dim 1 (array-end arr1 dim)) (shape-for-each common (lambda (index) (array-set! result index (array-ref arr1 index))) index)) (if (pair? ars) (wok (car ars) (cdr ars)))) result))) ;;; Transpose, as permutation of dimensions, is applicable to all ;;; arrays. The default is reversal. ;;; The implementation uses multiplication by permutation ;;; matrix but matrix multiplication is not exported. (define (array:arlib:matrix-times a b) (or (and (= (array-rank a) 2) (= (array-rank b) 2)) (error "times: arrays are not matrices")) (let ((r0 (array-start a 0)) (rn (array-end a 0)) (t0 (array-start a 1)) (tn (array-end a 1)) (u0 (array-start b 0)) (un (array-end b 0)) (k0 (array-start b 1)) (kn (array-end b 1))) (or (= (- tn t0) (- un u0)) (error "times: matrices are not compatible")) (let ((ab (make-array (shape r0 rn k0 kn)))) (do ((r r0 (+ r 1))) ((= r rn)) (do ((k k0 (+ k 1))) ((= k kn)) (do ((t t0 (+ t 1)) (u u0 (+ u 1)) (s 0 (+ s (* (array-ref a r t) (array-ref b u k))))) ((and (= t tn) (= u un)) (array-set! ab r k s))))) ab))) ; This is a generalized transpose. It can permute the dimensions any which ; way. The permutation is provided by a permutation matrix: a square matrix ; of zeros and ones, with exactly one one in each row and column, or a ; permutation of the rows of an identity matrix; the size of the matrix ; must match the number of dimensions of the array. ; ; The default permutation is [ 0 1 | 1 0 ] of course, but any permutation ; array can be specified, and the shape array of the original array is then ; multiplied with it, and index column vectors of the new array with its ; inverse, from left, to permute the rows appropriately. (define (array:arlib:permutation-matrix . ds) (let* ((n (length ds)) (arr (make-array (shape 0 n 0 n) 0))) (do ((k 0 (+ k 1)) (ds ds (cdr ds))) ((= k n)) (array-set! arr k (car ds) 1)) arr)) ;;; (transpose arr k ...) ;;; shares arr with permuted dimensions. Each dimension from 0 ;;; inclusive to rank exclusive must appear once in k ... (define (transpose a . p0) (let* ((r (array-rank a)) (permutation (apply array:arlib:permutation-matrix (if (pair? p0) p0 (do ((ds '() (cons d ds)) (d 0 (+ d 1))) ((= d r) ;; reverse dimensions ds))))) (inverse-permutation (share-array permutation (array-shape permutation) (lambda (r k) ;; transpose (values k r))))) (share-array a (array:arlib:matrix-times permutation (array-shape a)) (lambda ks0 (apply values (array->list (array:arlib:matrix-times inverse-permutation (apply array (shape 0 r 0 1) ks0)))))))) ;;; (share-array/index! array subshape proc index) (define (share-array/index! array subshape proc index) (array:share/index! array subshape proc index)) ;;; Take every nth slice along dimension d into a shared array. This ;;; preserves the origin. (define (share-nths arr d n) (let* ((bounds (array->vector (array-shape arr))) (b (vector-ref bounds (* 2 d))) (e (vector-ref bounds (+ (* 2 d) 1)))) (vector-set! bounds (+ (* 2 d) 1) (+ b (quotient (+ n (- e b 1)) n))) (share-array arr (apply shape (vector->list bounds)) (lambda ks (apply values (let d/nk ((u 0) (ks ks)) (if (= u d) (cons (+ b (* n (- (car ks) b))) (cdr ks)) (cons (car ks) (d/nk (+ u 1) (cdr ks)))))))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25/array.scm000066400000000000000000000553001375154206600212660ustar00rootroot00000000000000;;; array ;;; 1997 - 2001 Jussi Piitulainen ;;; --- Intro --- ;;; This interface to arrays is based on Alan Bawden's array.scm of ;;; 1993 (earlier version in the Internet Repository and another ;;; version in SLIB). This is a complete rewrite, to be consistent ;;; with the rest of Scheme and to make arrays independent of lists. ;;; Some modifications are due to discussion in srfi-25 mailing list. ;;; (array? obj) ;;; (make-array shape [obj]) changed arguments ;;; (shape bound ...) new ;;; (array shape obj ...) new ;;; (array-rank array) changed name back ;;; (array-start array dimension) new ;;; (array-end array dimension) new ;;; (array-ref array k ...) ;;; (array-ref array index) new variant ;;; (array-set! array k ... obj) changed argument order ;;; (array-set! array index obj) new variant ;;; (share-array array shape proc) changed arguments ;;; All other variables in this file have names in "array:". ;;; Should there be a way to make arrays with initial values mapped ;;; from indices? Sure. The current "initial object" is lame. ;;; ;;; Removed (array-shape array) from here. There is a new version ;;; in arlib though. ;;; --- Representation type dependencies --- ;;; The mapping from array indices to the index to the underlying vector ;;; is whatever array:optimize returns. The file "opt" provides three ;;; representations: ;;; ;;; mbda) mapping is a procedure that allows an optional argument ;;; tter) mapping is two procedures that takes exactly the indices ;;; ctor) mapping is a vector of a constant term and coefficients ;;; ;;; Choose one in "opt" to make the optimizer. Then choose the matching ;;; implementation of array-ref and array-set!. ;;; ;;; These should be made macros to inline them. Or have a good compiler ;;; and plant the package as a module. ;;; 1. Pick an optimizer. ;;; 2. Pick matching index representation. ;;; 3. Pick a record implementation; as-procedure is generic; syntax inlines. ;;; 3. This file is otherwise portable. ;;; --- Portable R5RS (R4RS and multiple values) --- ;;; (array? obj) ;;; returns #t if `obj' is an array and #t or #f otherwise. (define (array? obj) (array:array? obj)) ;;; (make-array shape) ;;; (make-array shape obj) ;;; makes array of `shape' with each cell containing `obj' initially. (define (make-array shape . rest) (or (array:good-shape? shape) (error "make-array: shape is not a shape")) (apply array:make-array shape rest)) (define (array:make-array shape . rest) (let ((size (array:size shape))) (array:make (if (pair? rest) (apply (lambda (o) (make-vector size o)) rest) (make-vector size)) (if (= size 0) (array:optimize-empty (vector-ref (array:shape shape) 1)) (array:optimize (array:make-index shape) (vector-ref (array:shape shape) 1))) (array:shape->vector shape)))) ;;; (shape bound ...) ;;; makes a shape. Bounds must be an even number of exact, pairwise ;;; non-decreasing integers. Note that any such array can be a shape. (define (shape . bounds) (let ((v (list->vector bounds))) (or (even? (vector-length v)) (error (string-append "shape: uneven number of bounds: " (array:list->string bounds)))) (let ((shp (array:make v (if (pair? bounds) (array:shape-index) (array:empty-shape-index)) (vector 0 (quotient (vector-length v) 2) 0 2)))) (or (array:good-shape? shp) (error (string-append "shape: bounds are not pairwise " "non-decreasing exact integers: " (array:list->string bounds)))) shp))) ;;; (array shape obj ...) ;;; is analogous to `vector'. (define (array shape . elts) (or (array:good-shape? shape) (error (string-append "array: shape " (array:thing->string shape) " is not a shape"))) (let ((size (array:size shape))) (let ((vector (list->vector elts))) (or (= (vector-length vector) size) (error (string-append "array: an array of shape " (array:shape-vector->string (array:vector shape)) " has " (number->string size) " elements but got " (number->string (vector-length vector)) " values: " (array:list->string elts)))) (array:make vector (if (= size 0) (array:optimize-empty (vector-ref (array:shape shape) 1)) (array:optimize (array:make-index shape) (vector-ref (array:shape shape) 1))) (array:shape->vector shape))))) ;;; (array-rank array) ;;; returns the number of dimensions of `array'. (define (array-rank array) (quotient (vector-length (array:shape array)) 2)) ;;; (array-start array k) ;;; returns the lower bound index of array along dimension k. This is ;;; the least valid index along that dimension if the dimension is not ;;; empty. (define (array-start array d) (vector-ref (array:shape array) (+ d d))) ;;; (array-end array k) ;;; returns the upper bound index of array along dimension k. This is ;;; not a valid index. If the dimension is empty, this is the same as ;;; the lower bound along it. (define (array-end array d) (vector-ref (array:shape array) (+ d d 1))) ;;; (share-array array shape proc) ;;; makes an array that shares elements of `array' at shape `shape'. ;;; The arguments to `proc' are indices of the result. The values of ;;; `proc' are indices of `array'. ;;; Todo: in the error message, should recognise the mapping and show it. (define (share-array array subshape f) (or (array:good-shape? subshape) (error (string-append "share-array: shape " (array:thing->string subshape) " is not a shape"))) (let ((subsize (array:size subshape))) (or (array:good-share? subshape subsize f (array:shape array)) (error (string-append "share-array: subshape " (array:shape-vector->string (array:vector subshape)) " does not map into supershape " (array:shape-vector->string (array:shape array)) " under mapping " (array:map->string f (vector-ref (array:shape subshape) 1))))) (let ((g (array:index array))) (array:make (array:vector array) (if (= subsize 0) (array:optimize-empty (vector-ref (array:shape subshape) 1)) (array:optimize (lambda ks (call-with-values (lambda () (apply f ks)) (lambda ks (array:vector-index g ks)))) (vector-ref (array:shape subshape) 1))) (array:shape->vector subshape))))) ;;; --- Hrmph --- ;;; (array:share/index! ...) ;;; reuses a user supplied index object when recognising the ;;; mapping. The mind balks at the very nasty side effect that ;;; exposes the implementation. So this is not in the spec. ;;; But letting index objects in at all creates a pressure ;;; to go the whole hog. Arf. ;;; Use array:optimize-empty for an empty array to get a ;;; clearly invalid vector index. ;;; Surely it's perverse to use an actor for index here? But ;;; the possibility is provided for completeness. (define (array:share/index! array subshape proc index) (array:make (array:vector array) (if (= (array:size subshape) 0) (array:optimize-empty (quotient (vector-length (array:shape array)) 2)) ((if (vector? index) array:optimize/vector array:optimize/actor) (lambda (subindex) (let ((superindex (proc subindex))) (if (vector? superindex) (array:index/vector (quotient (vector-length (array:shape array)) 2) (array:index array) superindex) (array:index/array (quotient (vector-length (array:shape array)) 2) (array:index array) (array:vector superindex) (array:index superindex))))) index)) (array:shape->vector subshape))) (define (array:optimize/vector f v) (let ((r (vector-length v))) (do ((k 0 (+ k 1))) ((= k r)) (vector-set! v k 0)) (let ((n0 (f v)) (cs (make-vector (+ r 1))) (apply (array:applier-to-vector (+ r 1)))) (vector-set! cs 0 n0) (let wok ((k 0)) (if (< k r) (let ((k1 (+ k 1))) (vector-set! v k 1) (let ((nk (- (f v) n0))) (vector-set! v k 0) (vector-set! cs k1 nk) (wok k1))))) (apply (array:maker r) cs)))) (define (array:optimize/actor f a) (let ((r (array-end a 0)) (v (array:vector a)) (i (array:index a))) (do ((k 0 (+ k 1))) ((= k r)) (vector-set! v (array:actor-index i k) 0)) (let ((n0 (f a)) (cs (make-vector (+ r 1))) (apply (array:applier-to-vector (+ r 1)))) (vector-set! cs 0 n0) (let wok ((k 0)) (if (< k r) (let ((k1 (+ k 1)) (t (array:actor-index i k))) (vector-set! v t 1) (let ((nk (- (f a) n0))) (vector-set! v t 0) (vector-set! cs k1 nk) (wok k1))))) (apply (array:maker r) cs)))) ;;; --- Internals --- (define (array:shape->vector shape) (let ((idx (array:index shape)) (shv (array:vector shape)) (rnk (vector-ref (array:shape shape) 1))) (let ((vec (make-vector (* rnk 2)))) (do ((k 0 (+ k 1))) ((= k rnk) vec) (vector-set! vec (+ k k) (vector-ref shv (array:shape-vector-index idx k 0))) (vector-set! vec (+ k k 1) (vector-ref shv (array:shape-vector-index idx k 1))))))) ;;; (array:size shape) ;;; returns the number of elements in arrays of shape `shape'. (define (array:size shape) (let ((idx (array:index shape)) (shv (array:vector shape)) (rnk (vector-ref (array:shape shape) 1))) (do ((k 0 (+ k 1)) (s 1 (* s (- (vector-ref shv (array:shape-vector-index idx k 1)) (vector-ref shv (array:shape-vector-index idx k 0)))))) ((= k rnk) s)))) ;;; (array:make-index shape) ;;; returns an index function for arrays of shape `shape'. This is a ;;; runtime composition of several variable arity procedures, to be ;;; passed to array:optimize for recognition as an affine function of ;;; as many variables as there are dimensions in arrays of this shape. (define (array:make-index shape) (let ((idx (array:index shape)) (shv (array:vector shape)) (rnk (vector-ref (array:shape shape) 1))) (do ((f (lambda () 0) (lambda (k . ks) (+ (* s (- k (vector-ref shv (array:shape-vector-index idx (- j 1) 0)))) (apply f ks)))) (s 1 (* s (- (vector-ref shv (array:shape-vector-index idx (- j 1) 1)) (vector-ref shv (array:shape-vector-index idx (- j 1) 0))))) (j rnk (- j 1))) ((= j 0) f)))) ;;; --- Error checking --- ;;; (array:good-shape? shape) ;;; returns true if `shape' is an array of the right shape and its ;;; elements are exact integers that pairwise bound intervals `[lo..hi). (define (array:good-shape? shape) (and (array:array? shape) (let ((u (array:shape shape)) (v (array:vector shape)) (x (array:index shape))) (and (= (vector-length u) 4) (= (vector-ref u 0) 0) (= (vector-ref u 2) 0) (= (vector-ref u 3) 2)) (let ((p (vector-ref u 1))) (do ((k 0 (+ k 1)) (true #t (let ((lo (vector-ref v (array:shape-vector-index x k 0))) (hi (vector-ref v (array:shape-vector-index x k 1)))) (and true (integer? lo) (exact? lo) (integer? hi) (exact? hi) (<= lo hi))))) ((= k p) true)))))) ;;; (array:good-share? subv subsize mapping superv) ;;; returns true if the extreme indices in the subshape vector map ;;; into the bounds in the supershape vector. ;;; If some interval in `subv' is empty, then `subv' is empty and its ;;; image under `f' is empty and it is trivially alright. One must ;;; not call `f', though. (define (array:good-share? subshape subsize f super) (or (zero? subsize) (letrec ((sub (array:vector subshape)) (dex (array:index subshape)) (ck (lambda (k ks) (if (zero? k) (call-with-values (lambda () (apply f ks)) (lambda qs (array:good-indices? qs super))) (and (ck (- k 1) (cons (vector-ref sub (array:shape-vector-index dex (- k 1) 0)) ks)) (ck (- k 1) (cons (- (vector-ref sub (array:shape-vector-index dex (- k 1) 1)) 1) ks))))))) (let ((rnk (vector-ref (array:shape subshape) 1))) (or (array:unchecked-share-depth? rnk) (ck rnk '())))))) ;;; Check good-share on 10 dimensions at most. The trouble is, ;;; the cost of this check is exponential in the number of dimensions. (define (array:unchecked-share-depth? rank) (if (> rank 10) (begin (display `(warning: unchecked depth in share: ,rank subdimensions)) (newline) #t) #f)) ;;; (array:check-indices caller indices shape-vector) ;;; (array:check-indices.o caller indices shape-vector) ;;; (array:check-index-vector caller index-vector shape-vector) ;;; return if the index is in bounds, else signal error. ;;; ;;; Shape-vector is the internal representation, with ;;; b and e for dimension k at 2k and 2k + 1. (define (array:check-indices who ks shv) (or (array:good-indices? ks shv) (error (array:not-in who ks shv)))) (define (array:check-indices.o who ks shv) (or (array:good-indices.o? ks shv) (error (array:not-in who (reverse (cdr (reverse ks))) shv)))) (define (array:check-index-vector who ks shv) (or (array:good-index-vector? ks shv) (error (array:not-in who (vector->list ks) shv)))) (define (array:check-index-actor who ks shv) (let ((shape (array:shape ks))) (or (and (= (vector-length shape) 2) (= (vector-ref shape 0) 0)) (error "not an actor")) (or (array:good-index-actor? (vector-ref shape 1) (array:vector ks) (array:index ks) shv) (array:not-in who (do ((k (vector-ref shape 1) (- k 1)) (m '() (cons (vector-ref (array:vector ks) (array:actor-index (array:index ks) (- k 1))) m))) ((= k 0) m)) shv)))) (define (array:good-indices? ks shv) (let ((d2 (vector-length shv))) (do ((kp ks (if (pair? kp) (cdr kp))) (k 0 (+ k 2)) (true #t (and true (pair? kp) (array:good-index? (car kp) shv k)))) ((= k d2) (and true (null? kp)))))) (define (array:good-indices.o? ks.o shv) (let ((d2 (vector-length shv))) (do ((kp ks.o (if (pair? kp) (cdr kp))) (k 0 (+ k 2)) (true #t (and true (pair? kp) (array:good-index? (car kp) shv k)))) ((= k d2) (and true (pair? kp) (null? (cdr kp))))))) (define (array:good-index-vector? ks shv) (let ((r2 (vector-length shv))) (and (= (* 2 (vector-length ks)) r2) (do ((j 0 (+ j 1)) (k 0 (+ k 2)) (true #t (and true (array:good-index? (vector-ref ks j) shv k)))) ((= k r2) true))))) (define (array:good-index-actor? r v i shv) (and (= (* 2 r) (vector-length shv)) (do ((j 0 (+ j 1)) (k 0 (+ k 2)) (true #t (and true (array:good-index? (vector-ref v (array:actor-index i j)) shv k)))) ((= j r) true)))) ;;; (array:good-index? index shape-vector 2d) ;;; returns true if index is within bounds for dimension 2d/2. (define (array:good-index? w shv k) (and (integer? w) (exact? w) (<= (vector-ref shv k) w) (< w (vector-ref shv (+ k 1))))) (define (array:not-in who ks shv) (let ((index (array:list->string ks)) (bounds (array:shape-vector->string shv))) (error (string-append who ": index " index " not in bounds " bounds)))) (define (array:list->string ks) (do ((index "" (string-append index (array:thing->string (car ks)) " ")) (ks ks (cdr ks))) ((null? ks) index))) (define (array:shape-vector->string shv) (do ((bounds "" (string-append bounds "[" (number->string (vector-ref shv t)) ".." (number->string (vector-ref shv (+ t 1))) ")" " ")) (t 0 (+ t 2))) ((= t (vector-length shv)) bounds))) (define (array:thing->string thing) (cond ((number? thing) (number->string thing)) ((symbol? thing) (string-append "#" (symbol->string thing))) ((char? thing) "#") ((string? thing) "#") ((list? thing) (string-append "#" (number->string (length thing)) "")) ((pair? thing) "#") ((array? thing) "#") ((vector? thing) (string-append "#" (number->string (vector-length thing)) "")) ((procedure? thing) "#") (else (case thing ((()) "()") ((#t) "#t") ((#f) "#f") (else "#"))))) ;;; And to grok an affine map, vector->vector type. Column k of arr ;;; will contain coefficients n0 ... nm of 1 k1 ... km for kth value. ;;; ;;; These are for the error message when share fails. (define (array:index-ref ind k) (if (vector? ind) (vector-ref ind k) (vector-ref (array:vector ind) (array:actor-index (array:index ind) k)))) (define (array:index-set! ind k o) (if (vector? ind) (vector-set! ind k o) (vector-set! (array:vector ind) (array:actor-index (array:index ind) k) o))) (define (array:index-length ind) (if (vector? ind) (vector-length ind) (vector-ref (array:shape ind) 1))) (define (array:map->string proc r) (let* ((m (array:grok/arguments proc r)) (s (vector-ref (array:shape m) 3))) (do ((i "" (string-append i c "k" (number->string k))) (c "" ", ") (k 1 (+ k 1))) ((< r k) (do ((o "" (string-append o c (array:map-column->string m r k))) (c "" ", ") (k 0 (+ k 1))) ((= k s) (string-append i " => " o))))))) (define (array:map-column->string m r k) (let ((v (array:vector m)) (i (array:index m))) (let ((n0 (vector-ref v (array:vector-index i (list 0 k))))) (let wok ((j 1) (e (if (= n0 0) "" (number->string n0)))) (if (<= j r) (let ((nj (vector-ref v (array:vector-index i (list j k))))) (if (= nj 0) (wok (+ j 1) e) (let* ((nj (if (= nj 1) "" (if (= nj -1) "-" (string-append (number->string nj) " ")))) (njkj (string-append nj "k" (number->string j)))) (if (string=? e "") (wok (+ j 1) njkj) (wok (+ j 1) (string-append e " + " njkj)))))) (if (string=? e "") "0" e)))))) (define (array:grok/arguments proc r) (array:grok/index! (lambda (vec) (call-with-values (lambda () (array:apply-to-vector r proc vec)) vector)) (make-vector r))) (define (array:grok/index! proc in) (let ((m (array:index-length in))) (do ((k 0 (+ k 1))) ((= k m)) (array:index-set! in k 0)) (let* ((n0 (proc in)) (n (array:index-length n0))) (let ((arr (make-array (shape 0 (+ m 1) 0 n)))) ; (*) (do ((k 0 (+ k 1))) ((= k n)) (array-set! arr 0 k (array:index-ref n0 k))) ; (**) (do ((j 0 (+ j 1))) ((= j m)) (array:index-set! in j 1) (let ((nj (proc in))) (array:index-set! in j 0) (do ((k 0 (+ k 1))) ((= k n)) (array-set! arr (+ j 1) k (- (array:index-ref nj k) ; (**) (array:index-ref n0 k)))))) arr)))) ;; (*) Should not use `make-array' and `shape' here ;; (**) Should not use `array-set!' here ;; Should use something internal to the library instead: either lower ;; level code (preferable but complex) or alternative names to these same. chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25/ix-ctor.scm000066400000000000000000000062251375154206600215370ustar00rootroot00000000000000(define (array-ref a . xs) (or (array:array? a) (error "not an array")) (let ((shape (array:shape a))) (if (null? xs) (array:check-indices "array-ref" xs shape) (let ((x (car xs))) (if (vector? x) (array:check-index-vector "array-ref" x shape) (if (integer? x) (array:check-indices "array-ref" xs shape) (if (array:array? x) (array:check-index-actor "array-ref" x shape) (error "not an index object")))))) (vector-ref (array:vector a) (if (null? xs) (vector-ref (array:index a) 0) (let ((x (car xs))) (if (vector? x) (array:index/vector (quotient (vector-length shape) 2) (array:index a) x) (if (integer? x) (array:vector-index (array:index a) xs) (if (array:array? x) (array:index/array (quotient (vector-length shape) 2) (array:index a) (array:vector x) (array:index x)) (error "array-ref: bad index object"))))))))) (define (array-set! a x . xs) (or (array:array? a) (error "array-set!: not an array")) (let ((shape (array:shape a))) (if (null? xs) (array:check-indices "array-set!" '() shape) (if (vector? x) (array:check-index-vector "array-set!" x shape) (if (integer? x) (array:check-indices.o "array-set!" (cons x xs) shape) (if (array:array? x) (array:check-index-actor "array-set!" x shape) (error "not an index object"))))) (if (null? xs) (vector-set! (array:vector a) (vector-ref (array:index a) 0) x) (if (vector? x) (vector-set! (array:vector a) (array:index/vector (quotient (vector-length shape) 2) (array:index a) x) (car xs)) (if (integer? x) (let ((v (array:vector a)) (i (array:index a)) (r (quotient (vector-length shape) 2))) (do ((sum (* (vector-ref i 0) x) (+ sum (* (vector-ref i k) (car ks)))) (ks xs (cdr ks)) (k 1 (+ k 1))) ((= k r) (vector-set! v (+ sum (vector-ref i k)) (car ks))))) (if (array:array? x) (vector-set! (array:vector a) (array:index/array (quotient (vector-length shape) 2) (array:index a) (array:vector x) (array:index x)) (car xs)) (error (string-append "array-set!: bad index object: " (array:thing->string x))))))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25/list.scm000066400000000000000000000627461375154206600211370ustar00rootroot00000000000000;;; An identity matrix. (define i_4 (let* ((i (make-array (shape 0 4 0 4) 0)) (d (share-array i (shape 0 4) (lambda (k) (values k k))))) (do ((k 0 (+ k 1))) ((= k 4)) (array-set! d k 1)) i)) (past "i_4") (or (array-equal? i_4 (tabulate-array (shape 0 4 0 4) (lambda (j k) (if (= j k) 1 0)))) (error "failed to build i_4")) (past "i_4 vs tabulate-array") (or (array-equal? i_4 (array (shape 0 4 0 4) 1 0 0 0 0 1 0 0 0 0 1 0 0 0 0 1)) (error "failed to array i_4")) (past "i_4 vs array") (or (array-equal? (share-array i_4 (shape 0 4) (lambda (k) (values k k))) (share-array (array (shape) 1) (shape 0 4) (lambda (k) (values)))) (error "failed to share diagonal of i_4 or cell of 1")) (past "i_4 diagonal") (or (array-equal? (share-array i_4 (shape 0 4) (lambda (k) (values (- 3 k) k))) (share-array (array (shape) 0) (shape 0 4) (lambda (k) (values)))) (error "failed to share codiagonal of i_4 or cell of 0")) (past "i_4 codiagonal") (or (array-equal? (share-array i_4 (shape 0 2 0 2) (lambda (j k) (values (* 3 j) (* 3 k)))) (share-array i_4 (shape 0 2 0 2) (lambda (j k) (values (+ j 1) (+ k 1))))) (error "failed to share corners or center of i_4")) (past "i_4 corners and center") (or (array-equal? i_4 (transpose i_4)) (error "failed to transpose i_4")) (past "i_4 transpose") ;;; Try a three dimensional transpose. This will also exercise matrix ;;; multiplication. (define threed123 (array (shape 0 1 0 2 0 3) 'a 'b 'c 'd 'e 'f)) (past "threed123") (define threed312 (array (shape 0 3 0 1 0 2) 'a 'd 'b 'e 'c 'f)) (past "threed312") (define rot231 (list 1 2 0)) ;; 0 1 0 ;; 0 0 1 ;; 1 0 0 (or (array-equal? threed123 (apply transpose threed312 rot231)) (error "failed to transpose three dimensions")) (past "threed123 transpose") ;;; The frivolous board game exercises share of share of share. ;;; A three dimensional chess board with two phases: piece and colour ;;; of piece. Think of pieces in a cube with height, width and depth, ;;; and piece colours in a parallel cube. We put pink jays around and ;;; grey crows inside the board proper. Later we put in a blue rook. (define board (tabulate-array (shape -1 9 -1 9 -1 9 0 2) (lambda (t u v w) (case w ((0) (if (and (< -1 u 8) (< -1 v 8) (< -1 t 8)) 'crow 'jay)) ((1) (if (and (< -1 u 8) (< -1 v 8) (< -1 t 8)) 'grey 'pink)))))) (past "board") ;;; A cylinder with height 4, width 4, depth 6, both phases, centered ;;; inside the board. Top left front corner is at 0 0 0 of cylinder but ;;; 2 2 1 of board. (define board-cylinder (share-array board (shape 0 4 0 4 0 6 0 2) (lambda (t u v w) (values (+ t 2) (+ u 2) (+ v 1) w)))) (past "board-cylinder") ;;; The center cube with side 2 of the cylinder, hence of the board, ;;; with both phases. Top left corner is 0 0 0 of center but 1 1 2 ;;; of cylinder and 3 3 3 of board. (define board-center (share-array board-cylinder (shape 0 2 0 2 0 2 0 2) (lambda (t u v w) (values (+ t 1) (+ u 1) (+ v 2) w)))) (past "board-center") ;;; Front face of center cube, in two dimensions plus phase. Top left ;;; corner is 0 0 of face but 0 0 0 of center and 1 1 2 of cylinder ;;; 3 3 3 of board. (define board-face (share-array board-center (shape 0 2 0 2 0 2) (lambda (t u w) (values t u 0 w)))) (past "board-face") ;;; Left side of face in three dimensions plus phase. Top is 0 0 0 of ;;; pillar but 0 0 of face and 0 0 0 of center and 1 1 2 of cylinder ;;; and 3 3 3 of board. Bottom is 1 0 0 of pillar but 1 0 of face and ;;; 1 0 0 of center and 2 1 2 of cylinder and 4 3 3 of board. (define board-pillar (share-array board-face (shape 0 2 0 1 0 1 0 2) (lambda (t u v w) (values t 0 w)))) (past "board-pillar") ;;; Pillar upside down. Now top 0 0 0 is 1 0 of face and 1 0 0 of center ;;; and 2 1 2 of cylinder and 4 3 3 of board. (define board-reverse-pillar (share-array board-pillar (shape 0 2 0 1 0 1 0 2) (lambda (t u v w) (values (- 1 t) u v w)))) (past "board-reverse-pillar") ;;; Bottom of pillar. (define board-cubicle (share-array board-pillar (shape 0 2) (lambda (w) (values 1 0 0 w)))) (past "board-cubicle") ;;; Top of upside down pair. (define board-reverse-cubicle (share-array board-reverse-pillar (shape 0 2) (lambda (w) (values 0 0 0 w)))) (past "board-reverse-cubicle") ;;; Piece phase of cubicle. (define board-piece (share-array board-cubicle (shape) (lambda () (values 0)))) (past "board-piece") ;;; Colour phase of the other cubicle that is actually the same cubicle. (define board-colour (share-array board-reverse-cubicle (shape) (lambda () (values 1)))) (past "board-colour") ;;; Put a blue rook at the bottom of the pillar and at the top of the ;;; upside pillar. (array-set! board-piece 'rook) (array-set! board-colour 'blue) (past "array-set! to board-piece and board-colour") ;;; Build the same chess position directly. (define board-two (tabulate-array (shape -1 9 -1 9 -1 9 0 2) (lambda (t u v w) (if (and (= t 4) (= u 3) (= v 3)) (case w ((0) 'rook) ((1) 'blue)) (case w ((0) (if (and (< -1 u 8) (< -1 v 8) (< -1 t 8)) 'crow 'jay)) ((1) (if (and (< -1 u 8) (< -1 v 8) (< -1 t 8)) 'grey 'pink))))))) (past "board-two") (or (array-equal? board board-two) (error "failed in three dimensional chess")) (past "board vs board-two") ;;; Permute the dimensions of the chess board in two different ways. ;;; The transpose also exercises matrix multiplication. (define board-three (share-array board-two (shape 0 2 -1 9 -1 9 -1 9) (lambda (w t u v) (values t u v w)))) (past "board-three") (or (array-equal? board-three (transpose board-two 3 0 1 2)) ;; 0 0 0 1 ;; 1 0 0 0 ;; 0 1 0 0 ;; 0 0 1 0 (error "failed to permute chess board dimensions")) (past "board-three vs transpose of board-two") (or (array-equal? (share-array board-two (shape -1 9 0 2 -1 9 -1 9) (lambda (t w u v) (values t u v w))) (transpose board-two 0 3 1 2)) ;; 1 0 0 0 ;; 0 0 0 1 ;; 0 1 0 0 ;; 0 0 1 0 (error "failed to permute chess board dimensions another way")) (past "board-two versus transpose of board-two") ;;; Just see that empty share does not crash. No index is valid. Just by ;;; the way. There is nothing to be done with it. (define board-nothing (share-array board (shape 0 3 1 1 0 3) (lambda (t u v) (values 0 0 0)))) (or (array-equal? board-nothing (array (array-shape board-nothing))) (error "board-nothing failed")) (past "board-nothing") ;;; --- (or (array-equal? (tabulate-array (shape 4 8 2 5 0 1) *) (tabulate-array! (shape 4 8 2 5 0 1) (lambda (v) (* (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))) (vector * * *))) (error "tabulate-array! with vector failed")) (past "tabulate-array! with vector") (or (array-equal? (tabulate-array (shape 4 8 2 5 0 1) *) (let ((index (share-array (make-array (shape 0 2 0 3)) (shape 0 3) (lambda (k) (values 1 k))))) (tabulate-array! (shape 4 8 2 5 0 1) (lambda (a) (* (array-ref a 0) (array-ref a 1) (array-ref a 2))) index))) (error "tabulate-array! with array failed")) (past "tabulate-array! with array") ;;; Sum of constants (or (array-equal? (array-map + (share-array (array (shape) 0) (shape 1 2 1 4) (lambda _ (values))) (share-array (array (shape) 1) (shape 1 2 1 4) (lambda _ (values))) (share-array (array (shape) 2) (shape 1 2 1 4) (lambda _ (values)))) (array (shape 1 2 1 4) 3 3 3)) (error "failed to map constants to their constant sum")) (past "array-map sum") ;;; Multiplication table (define four-by-four (array (shape 0 4 0 4) 0 0 0 0 0 1 2 3 0 2 4 6 0 3 6 9)) (past "four-by-four") (or (array-equal? four-by-four (tabulate-array (shape 0 4 0 4) *)) (error "failed to tabulate four by four")) (past "four-by-four vs tabulate-array") (or (array-equal? four-by-four (let ((table (make-array (shape 0 4 0 4) 19101))) (array-retabulate! table (array-shape table) *) table)) (error "failed to retabulate four by four simply")) (past "four-by-four vs array-retabulate!") (or (array-equal? four-by-four (let ((table (make-array (shape 0 4 0 4) 19101))) (array-retabulate! table (shape 1 2 1 4) (lambda (v) (* (vector-ref v 0) (vector-ref v 1))) (vector - -)) (array-retabulate! table (shape 2 4 0 4) (lambda (a) (* (array-ref a (vector 0)) (array-ref a (vector 1)))) (make-array (shape 0 2))) (array-set! table 0 0 0) (array-set! table (vector 0 1) 0) (array-set! table (array (shape 0 2) 0 2) 0) (shape-for-each (shape 0 1 3 4) (lambda (v) (array-set! table v (vector-ref v 0))) (vector - -)) (let ((arr (share-array table (shape 1 2 0 1 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8) (lambda (r k . _) (values r k))))) (array-retabulate! arr (array-shape arr) *)) table)) (error "failed to retabulate four by four in a hard way")) (past "four-by-four vs array-retabulate! on parts") ;;; An argument was missing in a call in arlib when ;;; shape-for-each was called without an index object. (or (let ((em '())) (shape-for-each (shape 0 2 -2 0 0 1) (lambda (u v w) (set! em (cons (list u v w) em)))) (equal? (reverse em) '((0 -2 0) (0 -1 0) (1 -2 0) (1 -1 0)))) (error "shape-for-each without index object")) (past "shape-for-each without index object") ;;; Exercise share-array/index! (or (let ((arr (tabulate-array (shape 2 4 3 5 4 7) *))) (array-equal? (share-array/index! arr (array-shape arr) (lambda (v) v) (vector * * *)) arr)) (error "share-array/index! with identity and vector failed")) (past "share-array/index! with identity and vector") (or (let ((arr (tabulate-array (shape 2 4 3 5 4 7) *)) (ind (share-array (make-array (shape 0 2 0 3)) (shape 0 3) (lambda (k) (values 1 k))))) (array-equal? (share-array/index! arr (array-shape arr) (lambda (a) a) ind) arr)) (error "share-array/index! with identity and array failed")) (past "share-array/index! with identity and array") (or (let ((arr (tabulate-array (shape 3 5 4 5 4 7) *)) (in (vector * *)) (out (array (shape 0 3) 4 * *))) (array-equal? (share-array/index! arr (shape 4 5 4 7) (lambda (in) (array-set! out 1 (vector-ref in 0)) (array-set! out 2 (vector-ref in 1)) out) in) (share-array arr (shape 4 5 4 7) (lambda (j k) (values 4 j k))))) (error "share-array/index! with vector in array out failed")) (past "share-array/index! with vector in array out") (or (let ((arr (tabulate-array (shape 3 5 4 5 4 7) *)) (in (array (shape 0 2) * *)) (out (vector 4 * *))) (array-equal? (share-array/index! arr (shape 4 5 4 7) (lambda (in) (vector-set! out 1 (array-ref in 0)) (vector-set! out 2 (array-ref in 1)) out) in) (share-array arr (shape 4 5 4 7) (lambda (j k) (values 4 j k))))) (error "share-array/index! with array in vector out failed")) (past "share-array/index! with array in vector out") (let ((x (array (shape 2 4 3 5 4 5 5 7 6 8) 10 11 12 13 20 21 22 23 30 31 32 33 40 41 42 43))) (or (array-equal? (share-array/origin x 3 3 3 3 3) (array-append 0 (array (shape 3 3 3 5 3 4 3 5 3 5)) x)) (error "share-array/origin against empty array-append failed")) (or (array-equal? (share-array/origin x 3 3 3 3 3) (array-append 3 (array (shape 3 5 3 5 3 4 3 3 3 5)) x)) (error "share-array/origin against empty array-append failed"))) (past "share-array/origin against empty array-append") (let ((a* (make-array (shape 4 6 7 9 100 101) 'a)) (b* (make-array (shape 3 6 7 8 200 201) 'b)) (c* (make-array (shape 0 1 2 4 300 301) 'c))) (or (array-equal? (array-append 1 (array-append 0 a* c*) b* b* b*) (apply array (shape 4 7 7 12 100 101) '(a a b b b a a b b b c c b b b))) (error "array-append failed"))) (past "array-append") (let ((a* (make-array (shape 4 6 7 9 100 101) 'a)) (b* (make-array (shape 3 6 7 8 200 201) 'b)) (c* (make-array (shape 0 1 2 4 300 301) 'c))) (or (array-equal? (array-append 1 a* (transpose c* 1 0 2) (array-append 0 (transpose b* 1 0 2) (transpose b* 1 0 2))) (apply array (shape 4 6 7 13 100 101) '(a a c b b b a a c b b b))) (error "array-append with transpose failed"))) (past "array-append with transpose") ;;; Check that share-array/index! agrees with share-array. (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? m (share-array m (shape 1 3 1 3) values)) (error "share-array identity failed")) (or (array-equal? m (share-array/index! m (shape 1 3 1 3) (lambda (x) x) (vector * *))) (error "share-array/index! identity with vector failed")) (or (array-equal? m (share-array/index! m (shape 1 3 1 3) (lambda (x) x) (make-array (shape 0 2)))) (error "share-array/index! identity with actor failed"))) (past "share-array/index! identity") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array m (shape 1 3) (lambda (r) (values r 1))) (share-array/index! m (shape 1 3) (lambda (x) (vector (vector-ref x 0) 1)) (vector *))) (error "share-array/index! 1-d column failed"))) (past "share-array/index! 1-d column") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array m (shape 1 3 1 3) (lambda (r k) (values r 1))) (share-array/index! m (shape 1 3 1 3) (lambda (x) (vector (vector-ref x 0) 1)) (vector * *))) (error "share-array/index! 2-d column failed"))) (past "share-array/index! 2-d column") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array m (shape 1 3) (lambda (k) (values 1 k))) (share-array/index! m (shape 1 3) (lambda (x) (vector 1 (vector-ref x 0))) (vector *))) (error "share-array/index! 1-d row failed"))) (past "share-array/index! 1-d row") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array m (shape 1 2 1 3) (lambda (r k) (values 1 k))) (share-array/index! m (shape 1 2 1 3) (lambda (x) (vector 1 (vector-ref x 1))) (vector * *))) (error "share-array/index! 2-d row failed"))) (past "share-array/index! 2-d row") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array m (shape 1 3) (lambda (r) (values r r))) (share-array/index! m (shape 1 3) (lambda (x) (vector (vector-ref x 0) (vector-ref x 0))) (vector *))) (error "share-array/index! diagonal failed"))) (past "share-array/index! diagonal") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array m (shape) (lambda () (values 1 2))) (share-array/index! m (shape) (lambda (x) (vector 1 2)) (vector))) (error "share-array/index! 0-d corner failed"))) (past "share-array/index! 0-d corner") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array m (shape 1 2) (lambda (_) (values 1 2))) (share-array/index! m (shape 1 2) (lambda (x) (vector 1 2)) (vector *))) (error "share-array/index! 1-d corner failed"))) (past "share-array/index! 1-d corner") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array m (shape 1 2 1 2) (lambda (r k) (values 1 2))) (share-array/index! m (shape 1 2 1 2) (lambda (x) (vector 1 2)) (vector * *))) (error "share-array/index! 2-d corner failed"))) (past "share-array/index! 2-d corner") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array/prefix m 1) (share-array/index! m (shape 1 3) (lambda (x) (vector 1 (vector-ref x 0))) (vector *))) (error "share-array/index! with prefix 1 failed"))) (past "share-array/{prefix,index!} 1") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array/prefix m (vector 1)) (share-array/index! m (shape 1 3) (lambda (x) (vector 1 (vector-ref x 0))) (vector *))) (error "share-array/prefix with vector failed"))) (past "share-array/prefix with vector") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array/prefix m 2) (share-array/index! m (shape 1 3) (lambda (x) (vector 2 (vector-ref x 0))) (vector *))) (error "share-array/index! with prefix 2 failed"))) (past "share-array/{prefix,index!} 2") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array/prefix m (array (shape 0 1) 2)) (share-array/index! m (shape 1 3) (lambda (x) (vector 2 (vector-ref x 0))) (vector *))) (error "share-array/prefix with array failed"))) (past "share-array/prefix with array") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array/prefix m) (share-array/index! m (shape 1 3 1 3) (lambda (x) x) (vector * *))) (error "share-array/index! with empty prefix failed"))) (past "share-array/{prefix,index!} e") (let ((m (array (shape 1 3 1 3) 'a 'b 'c 'd))) (or (array-equal? (share-array/prefix m 1 2) (share-array/index! m (shape) (lambda (x) (vector 1 2)) (vector))) (error "share-array/index! with prefix 1 2 failed"))) (past "share-array/{prefix,index!} 1 2") ;;; Uh oh. (let* ((hape (tabulate-array (shape 0 57 0 2) (lambda (r k) (case k ((0) r) ((1) (case r ((0) (+ r 2)) ((56) (+ r 4)) (else (+ r 1)))))))) (tape (tabulate-array (shape 0 34 0 2) (lambda (r k) (case k ((0) (+ r 23)) ((1) (case r ((33) (+ r 27)) (else (+ r 24)))))))) (long (make-vector 57 *)) (shot (make-vector 34 *)) (huge (tabulate-array! hape (lambda (ix) (vector-ref '#(a b) (vector-ref ix 0))) long)) (tiny0 (share-array/index! huge tape (begin (do ((k 0 (+ k 1))) ((= k 23)) (vector-set! long k k)) (lambda (ix) (do ((k 23 (+ k 1))) ((= k 57)) (vector-set! long k (vector-ref ix (- k 23)))) long)) shot)) (tiny1 (share-array/index! huge tape (begin (vector-set! long 0 1) (do ((k 1 (+ k 1))) ((= k 23)) (vector-set! long k k)) (lambda (ix) (do ((k 23 (+ k 1))) ((= k 57)) (vector-set! long k (vector-ref ix (- k 23)))) long)) shot))) (or (and (equal? (array->vector huge) '#(a a a a b b b b)) (equal? (array->vector tiny0) '#(a a a a)) (equal? (array->vector tiny1) '#(b b b b))) (error "share-array/index! failed huge or tiny contents")) (or (array-equal? huge (share-array/index! (array (shape 4 6) 'a 'b) hape (lambda (ix) (vector-ref '#(#(4) #(5)) (vector-ref ix 0))) long)) (error "share-array/index! failed huge")) (or (array-equal? tiny0 (share-array/index! (array (shape 6 7) 'a) tape (lambda (ix) '#(6)) shot)) (error "share-array/index! failed tiny0")) (or (array-equal? tiny1 (share-array/index! (array (shape 6 7 8 9) 'b) tape (lambda (ix) '#(6 8)) shot)) (error "share-array/index! failed tiny1"))) (past "share-array/index! huge as tiny") chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25/multi-dimensional-arrays.sls000066400000000000000000000006271375154206600251220ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :25 multi-dimensional-arrays) (export array? make-array shape array array-rank array-start array-end array-ref array-set! share-array) (import (srfi :25 multi-dimensional-arrays all)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25/multi-dimensional-arrays/000077500000000000000000000000001375154206600243725ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25/multi-dimensional-arrays/all.sls000066400000000000000000000042441375154206600256710ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :25 multi-dimensional-arrays all) (export array:make array:array? array:vector array:index array:shape array-ref array-set! array:opt-args array:optimize array:optimize-empty array:coefficients array:vector-index array:shape-index array:empty-shape-index array:shape-vector-index array:actor-index array:0 array:1 array:2 array:3 array:n array:maker array:indexer/vector array:indexer/array array:applier-to-vector array:applier-to-actor array:applier-to-backing-vector array:index/vector array:index/array array:apply-to-vector array:apply-to-actor array? make-array array:make-array shape array array-rank array-start array-end share-array array:share/index! array:optimize/vector array:optimize/actor array:shape->vector array:size array:make-index array:good-shape? array:good-share? array:unchecked-share-depth? array:check-indices array:check-indices.o array:check-index-vector array:check-index-actor array:good-indices? array:good-indices.o? array:good-index-vector? array:good-index-actor? array:good-index? array:not-in array:list->string array:shape-vector->string array:thing->string array:index-ref array:index-set! array:index-length array:map->string array:map-column->string array:grok/arguments array:grok/index!) (import (rnrs) (rnrs mutable-pairs) (rnrs r5rs) (srfi :23 error tricks) (srfi private include)) (define-record-type (array-type array:make array:array?) (fields (immutable vec array:vector) (immutable ind array:index) (immutable shp array:shape))) (SRFI-23-error->R6RS "(library (srfi :25 multi-dimensional-arrays))" (include/resolve ("srfi" "%3a25") "ix-ctor.scm") (include/resolve ("srfi" "%3a25") "op-ctor.scm") (include/resolve ("srfi" "%3a25") "array.scm")) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25/multi-dimensional-arrays/arlib.sls000066400000000000000000000015431375154206600262110ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :25 multi-dimensional-arrays arlib) (export array-shape array-length array-size array-equal? shape-for-each array-for-each-index tabulate-array tabulate-array! array-retabulate! array-map array-map! array->vector array->list share-array/prefix share-row share-column share-array/origin share-array/index! array-append transpose share-nths) (import (rnrs) (rnrs r5rs) (srfi :23 error tricks) (srfi :25 multi-dimensional-arrays all) (srfi private include)) (SRFI-23-error->R6RS "(library (srfi :25 multi-dimensional-arrays arlib))" (include/resolve ("srfi" "%3a25") "arlib.scm")) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25/op-ctor.scm000066400000000000000000000555061375154206600215430ustar00rootroot00000000000000(begin (define array:opt-args '(ctor (4))) (define (array:optimize f r) (case r ((0) (let ((n0 (f))) (array:0 n0))) ((1) (let ((n0 (f 0))) (array:1 n0 (- (f 1) n0)))) ((2) (let ((n0 (f 0 0))) (array:2 n0 (- (f 1 0) n0) (- (f 0 1) n0)))) ((3) (let ((n0 (f 0 0 0))) (array:3 n0 (- (f 1 0 0) n0) (- (f 0 1 0) n0) (- (f 0 0 1) n0)))) (else (let ((v (do ((k 0 (+ k 1)) (v '() (cons 0 v))) ((= k r) v)))) (let ((n0 (apply f v))) (apply array:n n0 (array:coefficients f n0 v v))))))) (define (array:optimize-empty r) (let ((x (make-vector (+ r 1) 0))) (vector-set! x r -1) x)) (define (array:coefficients f n0 vs vp) (case vp ((()) '()) (else (set-car! vp 1) (let ((n (- (apply f vs) n0))) (set-car! vp 0) (cons n (array:coefficients f n0 vs (cdr vp))))))) (define (array:vector-index x ks) (do ((sum 0 (+ sum (* (vector-ref x k) (car ks)))) (ks ks (cdr ks)) (k 0 (+ k 1))) ((null? ks) (+ sum (vector-ref x k))))) (define (array:shape-index) '#(2 1 0)) (define (array:empty-shape-index) '#(0 0 -1)) (define (array:shape-vector-index x r k) (+ (* (vector-ref x 0) r) (* (vector-ref x 1) k) (vector-ref x 2))) (define (array:actor-index x k) (+ (* (vector-ref x 0) k) (vector-ref x 1))) (define (array:0 n0) (vector n0)) (define (array:1 n0 n1) (vector n1 n0)) (define (array:2 n0 n1 n2) (vector n1 n2 n0)) (define (array:3 n0 n1 n2 n3) (vector n1 n2 n3 n0)) (define (array:n n0 n1 n2 n3 n4 . ns) (apply vector n1 n2 n3 n4 (append ns (list n0)))) (define (array:maker r) (case r ((0) array:0) ((1) array:1) ((2) array:2) ((3) array:3) (else array:n))) (define array:indexer/vector (let ((em (vector (lambda (x i) (+ (vector-ref x 0))) (lambda (x i) (+ (* (vector-ref x 0) (vector-ref i 0)) (vector-ref x 1))) (lambda (x i) (+ (* (vector-ref x 0) (vector-ref i 0)) (* (vector-ref x 1) (vector-ref i 1)) (vector-ref x 2))) (lambda (x i) (+ (* (vector-ref x 0) (vector-ref i 0)) (* (vector-ref x 1) (vector-ref i 1)) (* (vector-ref x 2) (vector-ref i 2)) (vector-ref x 3))) (lambda (x i) (+ (* (vector-ref x 0) (vector-ref i 0)) (* (vector-ref x 1) (vector-ref i 1)) (* (vector-ref x 2) (vector-ref i 2)) (* (vector-ref x 3) (vector-ref i 3)) (vector-ref x 4))) (lambda (x i) (+ (* (vector-ref x 0) (vector-ref i 0)) (* (vector-ref x 1) (vector-ref i 1)) (* (vector-ref x 2) (vector-ref i 2)) (* (vector-ref x 3) (vector-ref i 3)) (* (vector-ref x 4) (vector-ref i 4)) (vector-ref x 5))) (lambda (x i) (+ (* (vector-ref x 0) (vector-ref i 0)) (* (vector-ref x 1) (vector-ref i 1)) (* (vector-ref x 2) (vector-ref i 2)) (* (vector-ref x 3) (vector-ref i 3)) (* (vector-ref x 4) (vector-ref i 4)) (* (vector-ref x 5) (vector-ref i 5)) (vector-ref x 6))) (lambda (x i) (+ (* (vector-ref x 0) (vector-ref i 0)) (* (vector-ref x 1) (vector-ref i 1)) (* (vector-ref x 2) (vector-ref i 2)) (* (vector-ref x 3) (vector-ref i 3)) (* (vector-ref x 4) (vector-ref i 4)) (* (vector-ref x 5) (vector-ref i 5)) (* (vector-ref x 6) (vector-ref i 6)) (vector-ref x 7))) (lambda (x i) (+ (* (vector-ref x 0) (vector-ref i 0)) (* (vector-ref x 1) (vector-ref i 1)) (* (vector-ref x 2) (vector-ref i 2)) (* (vector-ref x 3) (vector-ref i 3)) (* (vector-ref x 4) (vector-ref i 4)) (* (vector-ref x 5) (vector-ref i 5)) (* (vector-ref x 6) (vector-ref i 6)) (* (vector-ref x 7) (vector-ref i 7)) (vector-ref x 8))) (lambda (x i) (+ (* (vector-ref x 0) (vector-ref i 0)) (* (vector-ref x 1) (vector-ref i 1)) (* (vector-ref x 2) (vector-ref i 2)) (* (vector-ref x 3) (vector-ref i 3)) (* (vector-ref x 4) (vector-ref i 4)) (* (vector-ref x 5) (vector-ref i 5)) (* (vector-ref x 6) (vector-ref i 6)) (* (vector-ref x 7) (vector-ref i 7)) (* (vector-ref x 8) (vector-ref i 8)) (vector-ref x 9))))) (it (lambda (w) (lambda (x i) (+ (* (vector-ref x 0) (vector-ref i 0)) (* (vector-ref x 1) (vector-ref i 1)) (* (vector-ref x 2) (vector-ref i 2)) (* (vector-ref x 3) (vector-ref i 3)) (* (vector-ref x 4) (vector-ref i 4)) (* (vector-ref x 5) (vector-ref i 5)) (* (vector-ref x 6) (vector-ref i 6)) (* (vector-ref x 7) (vector-ref i 7)) (* (vector-ref x 8) (vector-ref i 8)) (* (vector-ref x 9) (vector-ref i 9)) (do ((xi 0 (+ (* (vector-ref x u) (vector-ref i u)) xi)) (u (- w 1) (- u 1))) ((< u 10) xi)) (vector-ref x w)))))) (lambda (r) (if (< r 10) (vector-ref em r) (it r))))) (define array:indexer/array (let ((em (vector (lambda (x v i) (+ (vector-ref x 0))) (lambda (x v i) (+ (* (vector-ref x 0) (vector-ref v (array:actor-index i 0))) (vector-ref x 1))) (lambda (x v i) (+ (* (vector-ref x 0) (vector-ref v (array:actor-index i 0))) (* (vector-ref x 1) (vector-ref v (array:actor-index i 1))) (vector-ref x 2))) (lambda (x v i) (+ (* (vector-ref x 0) (vector-ref v (array:actor-index i 0))) (* (vector-ref x 1) (vector-ref v (array:actor-index i 1))) (* (vector-ref x 2) (vector-ref v (array:actor-index i 2))) (vector-ref x 3))) (lambda (x v i) (+ (* (vector-ref x 0) (vector-ref v (array:actor-index i 0))) (* (vector-ref x 1) (vector-ref v (array:actor-index i 1))) (* (vector-ref x 2) (vector-ref v (array:actor-index i 2))) (* (vector-ref x 3) (vector-ref v (array:actor-index i 3))) (vector-ref x 4))) (lambda (x v i) (+ (* (vector-ref x 0) (vector-ref v (array:actor-index i 0))) (* (vector-ref x 1) (vector-ref v (array:actor-index i 1))) (* (vector-ref x 2) (vector-ref v (array:actor-index i 2))) (* (vector-ref x 3) (vector-ref v (array:actor-index i 3))) (* (vector-ref x 4) (vector-ref v (array:actor-index i 4))) (vector-ref x 5))) (lambda (x v i) (+ (* (vector-ref x 0) (vector-ref v (array:actor-index i 0))) (* (vector-ref x 1) (vector-ref v (array:actor-index i 1))) (* (vector-ref x 2) (vector-ref v (array:actor-index i 2))) (* (vector-ref x 3) (vector-ref v (array:actor-index i 3))) (* (vector-ref x 4) (vector-ref v (array:actor-index i 4))) (* (vector-ref x 5) (vector-ref v (array:actor-index i 5))) (vector-ref x 6))) (lambda (x v i) (+ (* (vector-ref x 0) (vector-ref v (array:actor-index i 0))) (* (vector-ref x 1) (vector-ref v (array:actor-index i 1))) (* (vector-ref x 2) (vector-ref v (array:actor-index i 2))) (* (vector-ref x 3) (vector-ref v (array:actor-index i 3))) (* (vector-ref x 4) (vector-ref v (array:actor-index i 4))) (* (vector-ref x 5) (vector-ref v (array:actor-index i 5))) (* (vector-ref x 6) (vector-ref v (array:actor-index i 6))) (vector-ref x 7))) (lambda (x v i) (+ (* (vector-ref x 0) (vector-ref v (array:actor-index i 0))) (* (vector-ref x 1) (vector-ref v (array:actor-index i 1))) (* (vector-ref x 2) (vector-ref v (array:actor-index i 2))) (* (vector-ref x 3) (vector-ref v (array:actor-index i 3))) (* (vector-ref x 4) (vector-ref v (array:actor-index i 4))) (* (vector-ref x 5) (vector-ref v (array:actor-index i 5))) (* (vector-ref x 6) (vector-ref v (array:actor-index i 6))) (* (vector-ref x 7) (vector-ref v (array:actor-index i 7))) (vector-ref x 8))) (lambda (x v i) (+ (* (vector-ref x 0) (vector-ref v (array:actor-index i 0))) (* (vector-ref x 1) (vector-ref v (array:actor-index i 1))) (* (vector-ref x 2) (vector-ref v (array:actor-index i 2))) (* (vector-ref x 3) (vector-ref v (array:actor-index i 3))) (* (vector-ref x 4) (vector-ref v (array:actor-index i 4))) (* (vector-ref x 5) (vector-ref v (array:actor-index i 5))) (* (vector-ref x 6) (vector-ref v (array:actor-index i 6))) (* (vector-ref x 7) (vector-ref v (array:actor-index i 7))) (* (vector-ref x 8) (vector-ref v (array:actor-index i 8))) (vector-ref x 9))))) (it (lambda (w) (lambda (x v i) (+ (* (vector-ref x 0) (vector-ref v (array:actor-index i 0))) (* (vector-ref x 1) (vector-ref v (array:actor-index i 1))) (* (vector-ref x 2) (vector-ref v (array:actor-index i 2))) (* (vector-ref x 3) (vector-ref v (array:actor-index i 3))) (* (vector-ref x 4) (vector-ref v (array:actor-index i 4))) (* (vector-ref x 5) (vector-ref v (array:actor-index i 5))) (* (vector-ref x 6) (vector-ref v (array:actor-index i 6))) (* (vector-ref x 7) (vector-ref v (array:actor-index i 7))) (* (vector-ref x 8) (vector-ref v (array:actor-index i 8))) (* (vector-ref x 9) (vector-ref v (array:actor-index i 9))) (do ((xi 0 (+ (* (vector-ref x u) (vector-ref v (array:actor-index i u))) xi)) (u (- w 1) (- u 1))) ((< u 10) xi)) (vector-ref x w)))))) (lambda (r) (if (< r 10) (vector-ref em r) (it r))))) (define array:applier-to-vector (let ((em (vector (lambda (p v) (p)) (lambda (p v) (p (vector-ref v 0))) (lambda (p v) (p (vector-ref v 0) (vector-ref v 1))) (lambda (p v) (p (vector-ref v 0) (vector-ref v 1) (vector-ref v 2))) (lambda (p v) (p (vector-ref v 0) (vector-ref v 1) (vector-ref v 2) (vector-ref v 3))) (lambda (p v) (p (vector-ref v 0) (vector-ref v 1) (vector-ref v 2) (vector-ref v 3) (vector-ref v 4))) (lambda (p v) (p (vector-ref v 0) (vector-ref v 1) (vector-ref v 2) (vector-ref v 3) (vector-ref v 4) (vector-ref v 5))) (lambda (p v) (p (vector-ref v 0) (vector-ref v 1) (vector-ref v 2) (vector-ref v 3) (vector-ref v 4) (vector-ref v 5) (vector-ref v 6))) (lambda (p v) (p (vector-ref v 0) (vector-ref v 1) (vector-ref v 2) (vector-ref v 3) (vector-ref v 4) (vector-ref v 5) (vector-ref v 6) (vector-ref v 7))) (lambda (p v) (p (vector-ref v 0) (vector-ref v 1) (vector-ref v 2) (vector-ref v 3) (vector-ref v 4) (vector-ref v 5) (vector-ref v 6) (vector-ref v 7) (vector-ref v 8))))) (it (lambda (r) (lambda (p v) (apply p (vector-ref v 0) (vector-ref v 1) (vector-ref v 2) (vector-ref v 3) (vector-ref v 4) (vector-ref v 5) (vector-ref v 6) (vector-ref v 7) (vector-ref v 8) (vector-ref v 9) (do ((k r (- k 1)) (r '() (cons (vector-ref v (- k 1)) r))) ((= k 10) r))))))) (lambda (r) (if (< r 10) (vector-ref em r) (it r))))) (define array:applier-to-actor (let ((em (vector (lambda (p a) (p)) (lambda (p a) (p (array-ref a 0))) (lambda (p a) (p (array-ref a 0) (array-ref a 1))) (lambda (p a) (p (array-ref a 0) (array-ref a 1) (array-ref a 2))) (lambda (p a) (p (array-ref a 0) (array-ref a 1) (array-ref a 2) (array-ref a 3))) (lambda (p a) (p (array-ref a 0) (array-ref a 1) (array-ref a 2) (array-ref a 3) (array-ref a 4))) (lambda (p a) (p (array-ref a 0) (array-ref a 1) (array-ref a 2) (array-ref a 3) (array-ref a 4) (array-ref a 5))) (lambda (p a) (p (array-ref a 0) (array-ref a 1) (array-ref a 2) (array-ref a 3) (array-ref a 4) (array-ref a 5) (array-ref a 6))) (lambda (p a) (p (array-ref a 0) (array-ref a 1) (array-ref a 2) (array-ref a 3) (array-ref a 4) (array-ref a 5) (array-ref a 6) (array-ref a 7))) (lambda (p a) (p (array-ref a 0) (array-ref a 1) (array-ref a 2) (array-ref a 3) (array-ref a 4) (array-ref a 5) (array-ref a 6) (array-ref a 7) (array-ref a 8))))) (it (lambda (r) (lambda (p a) (apply a (array-ref a 0) (array-ref a 1) (array-ref a 2) (array-ref a 3) (array-ref a 4) (array-ref a 5) (array-ref a 6) (array-ref a 7) (array-ref a 8) (array-ref a 9) (do ((k r (- k 1)) (r '() (cons (array-ref a (- k 1)) r))) ((= k 10) r))))))) (lambda (r) "These are high level, hiding implementation at call site." (if (< r 10) (vector-ref em r) (it r))))) (define array:applier-to-backing-vector (let ((em (vector (lambda (p ai av) (p)) (lambda (p ai av) (p (vector-ref av (array:actor-index ai 0)))) (lambda (p ai av) (p (vector-ref av (array:actor-index ai 0)) (vector-ref av (array:actor-index ai 1)))) (lambda (p ai av) (p (vector-ref av (array:actor-index ai 0)) (vector-ref av (array:actor-index ai 1)) (vector-ref av (array:actor-index ai 2)))) (lambda (p ai av) (p (vector-ref av (array:actor-index ai 0)) (vector-ref av (array:actor-index ai 1)) (vector-ref av (array:actor-index ai 2)) (vector-ref av (array:actor-index ai 3)))) (lambda (p ai av) (p (vector-ref av (array:actor-index ai 0)) (vector-ref av (array:actor-index ai 1)) (vector-ref av (array:actor-index ai 2)) (vector-ref av (array:actor-index ai 3)) (vector-ref av (array:actor-index ai 4)))) (lambda (p ai av) (p (vector-ref av (array:actor-index ai 0)) (vector-ref av (array:actor-index ai 1)) (vector-ref av (array:actor-index ai 2)) (vector-ref av (array:actor-index ai 3)) (vector-ref av (array:actor-index ai 4)) (vector-ref av (array:actor-index ai 5)))) (lambda (p ai av) (p (vector-ref av (array:actor-index ai 0)) (vector-ref av (array:actor-index ai 1)) (vector-ref av (array:actor-index ai 2)) (vector-ref av (array:actor-index ai 3)) (vector-ref av (array:actor-index ai 4)) (vector-ref av (array:actor-index ai 5)) (vector-ref av (array:actor-index ai 6)))) (lambda (p ai av) (p (vector-ref av (array:actor-index ai 0)) (vector-ref av (array:actor-index ai 1)) (vector-ref av (array:actor-index ai 2)) (vector-ref av (array:actor-index ai 3)) (vector-ref av (array:actor-index ai 4)) (vector-ref av (array:actor-index ai 5)) (vector-ref av (array:actor-index ai 6)) (vector-ref av (array:actor-index ai 7)))) (lambda (p ai av) (p (vector-ref av (array:actor-index ai 0)) (vector-ref av (array:actor-index ai 1)) (vector-ref av (array:actor-index ai 2)) (vector-ref av (array:actor-index ai 3)) (vector-ref av (array:actor-index ai 4)) (vector-ref av (array:actor-index ai 5)) (vector-ref av (array:actor-index ai 6)) (vector-ref av (array:actor-index ai 7)) (vector-ref av (array:actor-index ai 8)))))) (it (lambda (r) (lambda (p ai av) (apply p (vector-ref av (array:actor-index ai 0)) (vector-ref av (array:actor-index ai 1)) (vector-ref av (array:actor-index ai 2)) (vector-ref av (array:actor-index ai 3)) (vector-ref av (array:actor-index ai 4)) (vector-ref av (array:actor-index ai 5)) (vector-ref av (array:actor-index ai 6)) (vector-ref av (array:actor-index ai 7)) (vector-ref av (array:actor-index ai 8)) (vector-ref av (array:actor-index ai 9)) (do ((k r (- k 1)) (r '() (cons (vector-ref av (array:actor-index ai (- k 1))) r))) ((= k 10) r))))))) (lambda (r) "These are low level, exposing implementation at call site." (if (< r 10) (vector-ref em r) (it r))))) (define (array:index/vector r x v) ((array:indexer/vector r) x v)) (define (array:index/array r x av ai) ((array:indexer/array r) x av ai)) (define (array:apply-to-vector r p v) ((array:applier-to-vector r) p v)) (define (array:apply-to-actor r p a) ((array:applier-to-actor r) p a))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a25/test.scm000066400000000000000000000412041375154206600211250ustar00rootroot00000000000000;;; array test ;;; 2001 Jussi Piitulainen (define past (let ((stones '())) (lambda stone (if (null? stone) (reverse stones) (set! stones (cons (apply (lambda (stone) stone) stone) stones)))))) (define (tail n) (if (< n (length (past))) (list-tail (past) (- (length (past)) n)) (past))) ;;; Simple tests (or (and (shape) (shape -1 -1) (shape -1 0) (shape -1 1) (shape 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8)) (error "(shape ...) failed")) (past "shape") (or (and (make-array (shape)) (make-array (shape) *) (make-array (shape -1 -1)) (make-array (shape -1 -1) *) (make-array (shape -1 1)) (make-array (shape 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8 1 2 3 4) *)) (error "(make-array (shape ...) [o]) failed")) (past "make-array") (or (and (array (shape) *) (array (shape -1 -1)) (array (shape -1 1) * *) (array (shape 1 2 3 4 5 6 7 8 1 2 3 4 5 6 7 8) *)) (error "(array (shape ...) ...) failed")) (past "array") (or (and (= (array-rank (shape)) 2) (= (array-rank (shape -1 -1)) 2) (= (array-rank (shape -1 1)) 2) (= (array-rank (shape 1 2 3 4 5 6 7 8)) 2)) (error "(array-rank (shape ...)) failed")) (past "array-rank of shape") (or (and (= (array-rank (make-array (shape))) 0) (= (array-rank (make-array (shape -1 -1))) 1) (= (array-rank (make-array (shape -1 1))) 1) (= (array-rank (make-array (shape 1 2 3 4 5 6 7 8))) 4)) (error "(array-rank (make-array ...)) failed")) (past "array-rank of make-array") (or (and (= (array-rank (array (shape) *)) 0) (= (array-rank (array (shape -1 -1))) 1) (= (array-rank (array (shape -1 1) * *)) 1) (= (array-rank (array (shape 1 2 3 4 5 6 7 8) *)) 4)) (error "(array-rank (array ...)) failed")) (past "array-rank of array") (or (and (= (array-start (shape -1 -1) 0) 0) (= (array-start (shape -1 -1) 1) 0) (= (array-start (shape -1 1) 0) 0) (= (array-start (shape -1 1) 1) 0) (= (array-start (shape 1 2 3 4 5 6 7 8) 0) 0) (= (array-start (shape 1 2 3 4 5 6 7 8) 1) 0)) (error "(array-start (shape ...)) failed")) (past "array-start of shape") (or (and (= (array-end (shape -1 -1) 0) 1) (= (array-end (shape -1 -1) 1) 2) (= (array-end (shape -1 1) 0) 1) (= (array-end (shape -1 1) 1) 2) (= (array-end (shape 1 2 3 4 5 6 7 8) 0) 4) (= (array-end (shape 1 2 3 4 5 6 7 8) 1) 2)) (error "(array-end (shape ...)) failed")) (past "array-end of shape") (or (and (= (array-start (make-array (shape -1 -1)) 0) -1) (= (array-start (make-array (shape -1 1)) 0) -1) (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 0) 1) (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 1) 3) (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 2) 5) (= (array-start (make-array (shape 1 2 3 4 5 6 7 8)) 3) 7)) (error "(array-start (make-array ...)) failed")) (past "array-start of make-array") (or (and (= (array-end (make-array (shape -1 -1)) 0) -1) (= (array-end (make-array (shape -1 1)) 0) 1) (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 0) 2) (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 1) 4) (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 2) 6) (= (array-end (make-array (shape 1 2 3 4 5 6 7 8)) 3) 8)) (error "(array-end (make-array ...)) failed")) (past "array-end of make-array") (or (and (= (array-start (array (shape -1 -1)) 0) -1) (= (array-start (array (shape -1 1) * *) 0) -1) (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 0) 1) (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 1) 3) (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 2) 5) (= (array-start (array (shape 1 2 3 4 5 6 7 8) *) 3) 7)) (error "(array-start (array ...)) failed")) (past "array-start of array") (or (and (= (array-end (array (shape -1 -1)) 0) -1) (= (array-end (array (shape -1 1) * *) 0) 1) (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 0) 2) (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 1) 4) (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 2) 6) (= (array-end (array (shape 1 2 3 4 5 6 7 8) *) 3) 8)) (error "(array-end (array ...)) failed")) (past "array-end of array") (or (and (eq? (array-ref (make-array (shape) 'a)) 'a) (eq? (array-ref (make-array (shape -1 1) 'b) -1) 'b) (eq? (array-ref (make-array (shape -1 1) 'c) 0) 'c) (eq? (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd) 1 3 5 7) 'd)) (error "array-ref of make-array with arguments failed")) (past "array-ref of make-array with arguments") (or (and (eq? (array-ref (make-array (shape) 'a) '#()) 'a) (eq? (array-ref (make-array (shape -1 1) 'b) '#(-1)) 'b) (eq? (array-ref (make-array (shape -1 1) 'c) '#(0)) 'c) (eq? (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd) '#(1 3 5 7)) 'd)) (error "array-ref of make-array with vector failed")) (past "array-ref of make-array with vector") (or (and (eq? (array-ref (make-array (shape) 'a) (array (shape 0 0))) 'a) (eq? (array-ref (make-array (shape -1 1) 'b) (array (shape 0 1) -1)) 'b) (eq? (array-ref (make-array (shape -1 1) 'c) (array (shape 0 1) 0)) 'c) (eq? (array-ref (make-array (shape 1 2 3 4 5 6 7 8) 'd) (array (shape 0 4) 1 3 5 7)) 'd)) (error "(array-ref of make-array with array failed")) (past "array-ref of make-array with array") (or (and (let ((arr (make-array (shape) 'o))) (array-set! arr 'a) (eq? (array-ref arr) 'a)) (let ((arr (make-array (shape -1 1) 'o))) (array-set! arr -1 'b) (array-set! arr 0 'c) (and (eq? (array-ref arr -1) 'b) (eq? (array-ref arr 0) 'c))) (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o))) (array-set! arr 1 3 5 7 'd) (eq? (array-ref arr 1 3 5 7) 'd))) (error "array-set! with arguments failed")) (past "array-set! of make-array with arguments") (or (and (let ((arr (make-array (shape) 'o))) (array-set! arr '#() 'a) (eq? (array-ref arr) 'a)) (let ((arr (make-array (shape -1 1) 'o))) (array-set! arr '#(-1) 'b) (array-set! arr '#(0) 'c) (and (eq? (array-ref arr -1) 'b) (eq? (array-ref arr 0) 'c))) (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o))) (array-set! arr '#(1 3 5 7) 'd) (eq? (array-ref arr 1 3 5 7) 'd))) (error "array-set! with vector failed")) (past "array-set! of make-array with vector") (or (and (let ((arr (make-array (shape) 'o))) (array-set! arr 'a) (eq? (array-ref arr) 'a)) (let ((arr (make-array (shape -1 1) 'o))) (array-set! arr (array (shape 0 1) -1) 'b) (array-set! arr (array (shape 0 1) 0) 'c) (and (eq? (array-ref arr -1) 'b) (eq? (array-ref arr 0) 'c))) (let ((arr (make-array (shape 1 2 3 4 5 6 7 8) 'o))) (array-set! arr (array (shape 0 4) 1 3 5 7) 'd) (eq? (array-ref arr 1 3 5 7) 'd))) (error "array-set! with arguments failed")) (past "array-set! of make-array with array") ;;; Share and change: ;;; ;;; org brk swp box ;;; ;;; 0 1 1 2 5 6 ;;; 6 a b 2 a b 3 d c 0 2 4 6 8: e ;;; 7 c d 3 e f 4 f e ;;; 8 e f (or (let* ((org (array (shape 6 9 0 2) 'a 'b 'c 'd 'e 'f)) (brk (share-array org (shape 2 4 1 3) (lambda (r k) (values (+ 6 (* 2 (- r 2))) (- k 1))))) (swp (share-array org (shape 3 5 5 7) (lambda (r k) (values (+ 7 (- r 3)) (- 1 (- k 5)))))) (box (share-array swp (shape 0 1 2 3 4 5 6 7 8 9) (lambda _ (values 4 6)))) (org-contents (lambda () (list (array-ref org 6 0) (array-ref org 6 1) (array-ref org 7 0) (array-ref org 7 1) (array-ref org 8 0) (array-ref org 8 1)))) (brk-contents (lambda () (list (array-ref brk 2 1) (array-ref brk 2 2) (array-ref brk 3 1) (array-ref brk 3 2)))) (swp-contents (lambda () (list (array-ref swp 3 5) (array-ref swp 3 6) (array-ref swp 4 5) (array-ref swp 4 6)))) (box-contents (lambda () (list (array-ref box 0 2 4 6 8))))) (and (equal? (org-contents) '(a b c d e f)) (equal? (brk-contents) '(a b e f)) (equal? (swp-contents) '(d c f e)) (equal? (box-contents) '(e)) (begin (array-set! org 6 0 'x) #t) (equal? (org-contents) '(x b c d e f)) (equal? (brk-contents) '(x b e f)) (equal? (swp-contents) '(d c f e)) (equal? (box-contents) '(e)) (begin (array-set! brk 3 1 'y) #t) (equal? (org-contents) '(x b c d y f)) (equal? (brk-contents) '(x b y f)) (equal? (swp-contents) '(d c f y)) (equal? (box-contents) '(y)) (begin (array-set! swp 4 5 'z) #t) (equal? (org-contents) '(x b c d y z)) (equal? (brk-contents) '(x b y z)) (equal? (swp-contents) '(d c z y)) (equal? (box-contents) '(y)) (begin (array-set! box 0 2 4 6 8 'e) #t) (equal? (org-contents) '(x b c d e z)) (equal? (brk-contents) '(x b e z)) (equal? (swp-contents) '(d c z e)) (equal? (box-contents) '(e)))) (error "shared change failed")) (past "shared change") ;;; Check that arrays copy the shape specification (or (let ((shp (shape 10 12))) (let ((arr (make-array shp)) (ars (array shp * *)) (art (share-array (make-array shp) shp (lambda (k) k)))) (array-set! shp 0 0 '?) (array-set! shp 0 1 '!) (and (= (array-rank shp) 2) (= (array-start shp 0) 0) (= (array-end shp 0) 1) (= (array-start shp 1) 0) (= (array-end shp 1) 2) (eq? (array-ref shp 0 0) '?) (eq? (array-ref shp 0 1) '!) (= (array-rank arr) 1) (= (array-start arr 0) 10) (= (array-end arr 0) 12) (= (array-rank ars) 1) (= (array-start ars 0) 10) (= (array-end ars 0) 12) (= (array-rank art) 1) (= (array-start art 0) 10) (= (array-end art 0) 12)))) (error "array-set! of shape failed")) (past "array-set! of shape") ;;; Check that index arrays work even when they share ;;; ;;; arr ixn ;;; 5 6 0 1 ;;; 4 nw ne 0 4 6 ;;; 5 sw se 1 5 4 (or (let ((arr (array (shape 4 6 5 7) 'nw 'ne 'sw 'se)) (ixn (array (shape 0 2 0 2) 4 6 5 4))) (let ((col0 (share-array ixn (shape 0 2) (lambda (k) (values k 0)))) (row0 (share-array ixn (shape 0 2) (lambda (k) (values 0 k)))) (wor1 (share-array ixn (shape 0 2) (lambda (k) (values 1 (- 1 k))))) (cod (share-array ixn (shape 0 2) (lambda (k) (case k ((0) (values 1 0)) ((1) (values 0 1)))))) (box (share-array ixn (shape 0 2) (lambda (k) (values 1 0))))) (and (eq? (array-ref arr col0) 'nw) (eq? (array-ref arr row0) 'ne) (eq? (array-ref arr wor1) 'nw) (eq? (array-ref arr cod) 'se) (eq? (array-ref arr box) 'sw) (begin (array-set! arr col0 'ul) (array-set! arr row0 'ur) (array-set! arr cod 'lr) (array-set! arr box 'll) #t) (eq? (array-ref arr 4 5) 'ul) (eq? (array-ref arr 4 6) 'ur) (eq? (array-ref arr 5 5) 'll) (eq? (array-ref arr 5 6) 'lr) (begin (array-set! arr wor1 'xx) (eq? (array-ref arr 4 5) 'xx))))) (error "array access with sharing index array failed")) (past "array access with sharing index array") ;;; Check that shape arrays work even when they share ;;; ;;; arr shp shq shr shs ;;; 1 2 3 4 0 1 0 1 0 1 0 1 ;;; 1 10 12 16 20 0 10 12 0 12 20 0 10 10 0 12 12 ;;; 2 10 11 12 13 1 10 11 1 11 13 1 11 12 1 12 12 ;;; 2 12 16 ;;; 3 13 20 (or (let ((arr (array (shape 1 3 1 5) 10 12 16 20 10 11 12 13))) (let ((shp (share-array arr (shape 0 2 0 2) (lambda (r k) (values (+ r 1) (+ k 1))))) (shq (share-array arr (shape 0 2 0 2) (lambda (r k) (values (+ r 1) (* 2 (+ 1 k)))))) (shr (share-array arr (shape 0 4 0 2) (lambda (r k) (values (- 2 k) (+ r 1))))) (shs (share-array arr (shape 0 2 0 2) (lambda (r k) (values 2 3))))) (and (let ((arr-p (make-array shp))) (and (= (array-rank arr-p) 2) (= (array-start arr-p 0) 10) (= (array-end arr-p 0) 12) (= (array-start arr-p 1) 10) (= (array-end arr-p 1) 11))) (let ((arr-q (array shq * * * * * * * * * * * * * * * *))) (and (= (array-rank arr-q) 2) (= (array-start arr-q 0) 12) (= (array-end arr-q 0) 20) (= (array-start arr-q 1) 11) (= (array-end arr-q 1) 13))) (let ((arr-r (share-array (array (shape) *) shr (lambda _ (values))))) (and (= (array-rank arr-r) 4) (= (array-start arr-r 0) 10) (= (array-end arr-r 0) 10) (= (array-start arr-r 1) 11) (= (array-end arr-r 1) 12) (= (array-start arr-r 2) 12) (= (array-end arr-r 2) 16) (= (array-start arr-r 3) 13) (= (array-end arr-r 3) 20))) (let ((arr-s (make-array shs))) (and (= (array-rank arr-s) 2) (= (array-start arr-s 0) 12) (= (array-end arr-s 0) 12) (= (array-start arr-s 1) 12) (= (array-end arr-s 1) 12)))))) (error "sharing shape array failed")) (past "sharing shape array") (let ((super (array (shape 4 7 4 7) 1 * * * 2 * * * 3)) (subshape (share-array (array (shape 0 2 0 3) * 4 * * 7 *) (shape 0 1 0 2) (lambda (r k) (values k 1))))) (let ((sub (share-array super subshape (lambda (k) (values k k))))) ;(array-equal? subshape (shape 4 7)) (or (and (= (array-rank subshape) 2) (= (array-start subshape 0) 0) (= (array-end subshape 0) 1) (= (array-start subshape 1) 0) (= (array-end subshape 1) 2) (= (array-ref subshape 0 0) 4) (= (array-ref subshape 0 1) 7)) (error "sharing subshape failed")) ;(array-equal? sub (array (shape 4 7) 1 2 3)) (or (and (= (array-rank sub) 1) (= (array-start sub 0) 4) (= (array-end sub 0) 7) (= (array-ref sub 4) 1) (= (array-ref sub 5) 2) (= (array-ref sub 6) 3)) (error "sharing with sharing subshape failed")))) (past "sharing with sharing subshape") chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a26.sls000066400000000000000000000002451375154206600201660ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :26) (export cut cute <> <...>) (import (srfi :26 cut)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a26/000077500000000000000000000000001375154206600174425ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a26/check.scm000066400000000000000000000043241375154206600212260ustar00rootroot00000000000000; CONFIDENCE TEST FOR IMPLEMENTATION OF SRFI-26 ; ============================================= ; ; Sebastian.Egner@philips.com, 3-Jun-2002. ; ; This file checks a few assertions about the implementation. ; If you run it and no error message is issued, the implementation ; is correct on the cases that have been tested. ; ; compliance: ; Scheme R5RS with ; SRFI-23: error ; ; loading this file into Scheme 48 0.57 after 'cut.scm' has been loaded: ; ,open srfi-23 ; ,load check.scm ; (check expr) ; evals expr and issues an error if it is not #t. (define (check expr) (if (not (eq? (eval expr (interaction-environment)) #t)) (error "check failed" expr))) ; (check-all) ; runs several tests on cut and reports. (define (check-all) (for-each check '( ; cuts (equal? ((cut list)) '()) (equal? ((cut list <...>)) '()) (equal? ((cut list 1)) '(1)) (equal? ((cut list <>) 1) '(1)) (equal? ((cut list <...>) 1) '(1)) (equal? ((cut list 1 2)) '(1 2)) (equal? ((cut list 1 <>) 2) '(1 2)) (equal? ((cut list 1 <...>) 2) '(1 2)) (equal? ((cut list 1 <...>) 2 3 4) '(1 2 3 4)) (equal? ((cut list 1 <> 3 <>) 2 4) '(1 2 3 4)) (equal? ((cut list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6)) (equal? (let* ((x 'wrong) (y (cut list x))) (set! x 'ok) (y)) '(ok)) (equal? (let ((a 0)) (map (cut + (begin (set! a (+ a 1)) a) <>) '(1 2)) a) 2) ; cutes (equal? ((cute list)) '()) (equal? ((cute list <...>)) '()) (equal? ((cute list 1)) '(1)) (equal? ((cute list <>) 1) '(1)) (equal? ((cute list <...>) 1) '(1)) (equal? ((cute list 1 2)) '(1 2)) (equal? ((cute list 1 <>) 2) '(1 2)) (equal? ((cute list 1 <...>) 2) '(1 2)) (equal? ((cute list 1 <...>) 2 3 4) '(1 2 3 4)) (equal? ((cute list 1 <> 3 <>) 2 4) '(1 2 3 4)) (equal? ((cute list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6)) (equal? (let* ((x 'ok) (y (cute list x))) (set! x 'wrong) (y)) '(ok)) (equal? (let ((a 0)) (map (cute + (begin (set! a (+ a 1)) a) <>) '(1 2)) a) 1)))) ; run the checks when loading (check-all) (display "passed") (newline)chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a26/cut-impl.scm000066400000000000000000000100661375154206600217030ustar00rootroot00000000000000; REFERENCE IMPLEMENTATION FOR SRFI-26 "CUT" ; ========================================== ; ; Sebastian.Egner@philips.com, 5-Jun-2002. ; adapted from the posting by Al Petrofsky ; placed in the public domain ; ; The code to handle the variable argument case was originally ; proposed by Michael Sperber and has been adapted to the new ; syntax of the macro using an explicit rest-slot symbol. The ; code to evaluate the non-slots for cute has been proposed by ; Dale Jordan. The code to allow a slot for the procedure position ; and to process the macro using an internal macro is based on ; a suggestion by Al Petrofsky. The code found below is, with ; exception of this header and some changes in variable names, ; entirely written by Al Petrofsky. ; ; compliance: ; Scheme R5RS (including macros). ; ; loading this file into Scheme 48 0.57: ; ,load cut.scm ; ; history of this file: ; SE, 6-Feb-2002: initial version as 'curry' with ". <>" notation ; SE, 14-Feb-2002: revised for <...> ; SE, 27-Feb-2002: revised for 'cut' ; SE, 03-Jun-2002: revised for proc-slot, cute ; SE, 04-Jun-2002: rewritten with internal transformer (no "loop" pattern) ; SE, 05-Jun-2002: replace my code by Al's; substituted "constant" etc. ; to match the convention in the SRFI-document ; (srfi-26-internal-cut slot-names combination . se) ; transformer used internally ; slot-names : the internal names of the slots ; combination : procedure being specialized, followed by its arguments ; se : slots-or-exprs, the qualifiers of the macro (define-syntax srfi-26-internal-cut (syntax-rules (<> <...>) ;; construct fixed- or variable-arity procedure: ;; (begin proc) throws an error if proc is not an ((srfi-26-internal-cut (slot-name ...) (proc arg ...)) (lambda (slot-name ...) ((begin proc) arg ...))) ((srfi-26-internal-cut (slot-name ...) (proc arg ...) <...>) (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot))) ;; process one slot-or-expr ((srfi-26-internal-cut (slot-name ...) (position ...) <> . se) (srfi-26-internal-cut (slot-name ... x) (position ... x) . se)) ((srfi-26-internal-cut (slot-name ...) (position ...) nse . se) (srfi-26-internal-cut (slot-name ...) (position ... nse) . se)))) ; (srfi-26-internal-cute slot-names nse-bindings combination . se) ; transformer used internally ; slot-names : the internal names of the slots ; nse-bindings : let-style bindings for the non-slot expressions. ; combination : procedure being specialized, followed by its arguments ; se : slots-or-exprs, the qualifiers of the macro (define-syntax srfi-26-internal-cute (syntax-rules (<> <...>) ;; If there are no slot-or-exprs to process, then: ;; construct a fixed-arity procedure, ((srfi-26-internal-cute (slot-name ...) nse-bindings (proc arg ...)) (let nse-bindings (lambda (slot-name ...) (proc arg ...)))) ;; or a variable-arity procedure ((srfi-26-internal-cute (slot-name ...) nse-bindings (proc arg ...) <...>) (let nse-bindings (lambda (slot-name ... . x) (apply proc arg ... x)))) ;; otherwise, process one slot: ((srfi-26-internal-cute (slot-name ...) nse-bindings (position ...) <> . se) (srfi-26-internal-cute (slot-name ... x) nse-bindings (position ... x) . se)) ;; or one non-slot expression ((srfi-26-internal-cute slot-names nse-bindings (position ...) nse . se) (srfi-26-internal-cute slot-names ((x nse) . nse-bindings) (position ... x) . se)))) ; exported syntax (define-syntax <> (identifier-syntax (error #f "misplaced aux keyword <>"))) (define-syntax <...> (identifier-syntax (error #f "misplaced aux keyword <...>"))) (define-syntax cut (syntax-rules () ((cut . slots-or-exprs) (srfi-26-internal-cut () () . slots-or-exprs)))) (define-syntax cute (syntax-rules () ((cute . slots-or-exprs) (srfi-26-internal-cute () () () . slots-or-exprs)))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a26/cut.sls000066400000000000000000000004631375154206600207630ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :26 cut) (export cut cute <> <...>) (import (rnrs) (srfi private include)) (include/resolve ("srfi" "%3a26") "cut-impl.scm") ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a27.sls000066400000000000000000000006511375154206600201700ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :27) (export default-random-source make-random-source random-integer random-real random-source-make-integers random-source-make-reals random-source-pseudo-randomize! random-source-randomize! random-source-state-ref random-source-state-set! random-source?) (import (srfi :27 random-bits)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a27/000077500000000000000000000000001375154206600174435ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a27/conftest.scm000066400000000000000000000237321375154206600220030ustar00rootroot00000000000000; CONFIDENCE TESTS FOR SRFI-27 "Sources of Random Bits" ; ===================================================== ; ; Sebastian.Egner@philips.com, 2002. ; ; This file contains a small collection of checks for the ; implementation of SRFI-27. It is not meant to be complete ; or to test the actual properties of the underlying generator. ; It is merely meant to run the code and to check some of the ; assumptions made by specification. There is an interface to ; G. Marsaglia's DIEHARD battery of tests for random number ; generators, though. ; ; running this file in Scheme 48 0.57 with SRFI-27 installed: ; ; ,open srfi-27 srfi-23 ascii ; ,load conftest.scm ; ; speed in Scheme 48 0.57 with SRFI-27 opened: ; ; ,time (do ((k 0 (+ k 1))) ((= k 100000)) (random-integer 2)) ; ; about 30000/s on P3@800MHz for the Scheme-impl. ; ; about 160000/s on P3@800MHz for the C/Scheme-impl. ; ; ,time (do ((k 0 (+ k 1))) ((= k 100000)) (random-real)) ; ; about 3000/s on P3@800MHz for the Scheme-impl. ; ; about 180000/s on P3@800MHz for the C/Scheme-impl. ; ; running this file in Gambit 3.0 (interpreter) with SRFI-27 loaded: ; ; (define ascii->char integer->char) ; (load "conftest.scm") ; ; compiling a simple program in Gambit 3.0 (compiler) using this file: ; ; 1. create 'a.scm' with content; ; (include "srfi-27-c.scm") ; (time (do ((k 0 (+ k 1))) ((= k 1000000)) (random-integer 2))) ; (time (do ((k 0 (+ k 1))) ((= k 1000000)) (random-real))) ; 2. compile Scheme into C (verbose paths for clarity) ; GAMBCDIR=$GAMBIT/lib LD_LIBRARY_PATH=$GAMBIT/lib $GAMBIT/gsc/gsc a ; 3. compile and link C code into an executable ; gcc -I$GAMBIT/lib -o a a.c a_.c -lm -lgambc -L$GAMBIT/lib ; 4. run the executable ; GAMBCDIR=$GAMBIT/lib LD_LIBRARY_PATH=$GAMBIT/lib a ; ; speed in Gambit 3.0 with SRFI-27 loaded: ; ; (time (do ((k 0 (+ k 1))) ((= k 100000)) (random-integer 2))) ; ; about 5000/s on P3@800MHz, interpreted ; ; about 200000/s on P3@800MHz, compiled ; ; (time (do ((k 0 (+ k 1))) ((= k 100000)) (random-real))) ; ; about 25000/s on P3@800MHz, interpreted ; ; about 400000/s on P3@800MHz, compiled ; ; history of this file: ; SE, 19-Mar-2002: initial version, based on earlier tests ; SE, 22-Mar-2002: adapted to new procedure names ; SE, 25-Mar-2002: more descriptive output ; SE, 04-Apr-2002: some quick timings; check up ; (check expr) ; evals expr and issues an error if it is not #t. (define (check expr) (if (not (eq? (eval expr (interaction-environment)) #t)) (error "check failed" expr))) ; Basic Tests of the Interface ; ============================ (define (my-random-integer n) (let ((x (random-integer n))) (if (<= 0 x (- n 1)) x (error "(random-integer n) returned illegal value" x)))) (define (my-random-real) (let ((x (random-real))) (if (< 0 x 1) x (error "(random-real) returned illegal value" x)))) (define (check-basics-1) ; generate increasingly large numbers (display "; generating large numbers [bits]: ") (do ((k 0 (+ k 1)) (n 1 (* n 2))) ((> k 1024)) (display k) (display " ") (my-random-integer n)) (display "ok") (newline) ; generate some reals (display "; generating reals [1000 times]: ") (do ((k 0 (+ k 1)) (x (my-random-real) (+ x (my-random-real)))) ((= k 1000) x)) (display "ok") (newline) ; get/set the state (display "; get/set state: ") (let* ((state1 (random-source-state-ref default-random-source)) (x1 (my-random-integer (expt 2 32))) (state2 (random-source-state-ref default-random-source)) (x2 (my-random-integer (expt 2 32)))) (random-source-state-set! default-random-source state1) (let ((y1 (my-random-integer (expt 2 32)))) (if (not (= x1 y1)) (error "state get/set doesn't work" x1 y1 state1))) (random-source-state-set! default-random-source state2) (let ((y2 (my-random-integer (expt 2 32)))) (if (not (= x2 y2)) (error "state get/set doesn't work" x2 y2 state2)))) (display "ok") (newline) ; randomize! (display "; randomize!: ") (let* ((state1 (random-source-state-ref default-random-source)) (x1 (my-random-integer (expt 2 32)))) (random-source-state-set! default-random-source state1) (random-source-randomize! default-random-source) (let ((y1 (my-random-integer (expt 2 32)))) (if (= x1 y1) (error "random-source-randomize! didn't work" x1 state1)))) (display "ok") (newline) ; pseudo-randomize! (display "; pseudo-randomize!: ") (let* ((state1 (random-source-state-ref default-random-source)) (x1 (my-random-integer (expt 2 32)))) (random-source-state-set! default-random-source state1) (random-source-pseudo-randomize! default-random-source 0 1) (let ((y1 (my-random-integer (expt 2 32)))) (if (= x1 y1) (error "random-source-pseudo-randomize! didn't work" x1 state1))) (random-source-state-set! default-random-source state1) (random-source-pseudo-randomize! default-random-source 1 0) (let ((y1 (my-random-integer (expt 2 32)))) (if (= x1 y1) (error "random-source-pseudo-randomize! didn't work" x1 state1)))) (display "ok") (newline) (newline)) ; Testing the MRG32k3a Generator (if implemented) ; =============================================== ; (check-mrg32k3a) ; tests if the underlying generator is the MRG32k3a generator ; as implemented in the reference implementation. This function ; is useful to check whether the reference implementation computes ; the right numbers. (define (check-mrg32k3a) ; check if the initial state is A^16 * (1 0 0 1 0 0) (display "; check A^16 * (1 0 0 1 0 0)") (let* ((s (make-random-source)) (state1 (random-source-state-ref s)) (rand (random-source-make-reals s))) (random-source-state-set! s '(lecuyer-mrg32k3a 1 0 0 1 0 0)) (do ((k 0 (+ k 1))) ((= k 16) (let ((state2 (random-source-state-ref s))) (if (not (equal? state1 state2)) (error "16-th state after (1 0 0 1 0 0) is wrong")))) (rand))) (display "ok") (newline) ; check if pseudo-randomize! advances properly (display "; checking (random-source-pseudo-randomize! s 1 2)") (let ((s (make-random-source))) (random-source-pseudo-randomize! s 1 2) (if (not (equal? (random-source-state-ref s) '(lecuyer-mrg32k3a 1250826159 3004357423 431373563 3322526864 623307378 2983662421))) (error "pseudo-randomize! gives wrong result"))) (display "ok") (newline) ; run the check published by Pierre L'Ecuyer: ; Note that the reference implementation deals slightly different ; with reals mapping m1-1 into 1-1/(m1+1) and not into 0 as in ; L'Ecuyer's original proposal. However, for the first 10^7 reals ; that makes no difference as m1-1 is not generated. (display "; checking (random-source-pseudo-randomize! s 1 2)...") (let* ((x 0.0) (s (make-random-source)) (rand (random-source-make-reals s))) (random-source-state-set! s '(lecuyer-mrg32k3a 12345 12345 12345 12345 12345 12345)) (do ((k 0 (+ k 1))) ((= k 10000000) (if (not (< (abs (- x 5001090.95)) 0.01)) (error "bad sum over 10^7 reals" x))) (set! x (+ x (rand))))) (display "ok") (newline)) ; Writing Data to DIEHARD ; ======================= ; (write-diehard filename s bytes-per-call calls) ; creates a binary file to which bytes-per-call * calls bytes are ; written. The bytes are obtained from the random source s using ; the range n = (expt 256 bytes-per-call). ; The intention of write-diehard is to give implementors a ; '15 min.'-way of running their favourite random number generator ; through a pretty tough testsuite. ; ; try: For the reference implementation, the call ; ; (write-diehard "outfile" (make-random-source) 4 2867200) ; ; should create a file that looks as follows (od -A x -t x1 outfile): ; ; 0000000 92 bb 7e db 1b 14 f6 bb bb 54 a1 55 c2 3e cd ca ; 0000010 23 01 20 35 06 47 65 b0 52 4c b8 c0 21 48 af 67 ; 0000020 63 a9 8c 78 50 73 29 08 62 d1 22 7f a6 89 96 77 ; 0000030 98 28 65 2d 2d 8b f9 52 41 be 8e 3f c5 84 0f ca ; 0000040 c0 fa 03 d6 f0 65 9d 3a 9b ab 6f fe d1 aa 5f 92 ; 0000050 0f ea f6 3b 78 b9 fe ad 63 5e 49 f1 9d c9 8e 2f ; 0000060 53 a9 5d 32 d4 20 51 1d 1c 2e 82 f0 8b 26 40 c0 ; ...total length is 11468800 bytes. ; ; The message digest is md5sum = 4df554f56cb5ed251bd04b0d50767443. ; ; try: For the reference implementation, the call ; ; (write-diehard "outfile" (make-random-source) 3 3822934) ; ; should create a file that looks as follows (od -A x -t x1 outfile): ; ; 000000 bb 7e db 30 a3 49 14 f6 bb d0 f2 d0 54 a1 55 8b ; 000010 8c 03 3e cd ca a3 88 1d 01 20 35 e8 50 c8 47 65 ; 000020 b0 e7 d9 28 4c b8 c0 f2 82 35 48 af 67 42 3e 8a ; 000030 a9 8c 78 12 ef b6 73 29 08 ff e9 71 d1 22 7f 52 ; 000040 b8 f0 89 96 77 dc 71 86 28 65 2d c2 82 fc 8b f9 ; 000050 52 d7 23 2a be 8e 3f 61 a8 99 84 0f ca 44 83 65 ; 000060 fa 03 d6 c2 11 c0 65 9d 3a c2 7a dd ab 6f fe 1c ; ...total length is 11468802 bytes. ; ; The message digest is md5sum = 750ac219ff40c50bb2d04ff5eff9b24c. (define (write-diehard filename s bytes-per-call calls) (let ((port (open-output-file filename)) (rand (random-source-make-integers s)) (n (expt 256 bytes-per-call))) (do ((i 0 (+ i 1))) ((= i calls) (close-output-port port)) (let ((x (rand n))) (do ((k 0 (+ k 1))) ((= k bytes-per-call)) (write-char (ascii->char (modulo x 256)) port) (set! x (quotient x 256))))))) ; run some tests (check-basics-1) (display "passed (check-basics-1)") (newline) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a27/mrg32k3a-a.scm000066400000000000000000000034231375154206600217200ustar00rootroot00000000000000; 54-BIT INTEGER IMPLEMENTATION OF THE "MRG32K3A"-GENERATOR ; ========================================================= ; ; Sebastian.Egner@philips.com, Mar-2002. ; ; This file is an implementation of Pierre L'Ecuyer's MRG32k3a ; pseudo random number generator. Please refer to 'mrg32k3a.scm' ; for more information. ; ; compliance: ; Scheme R5RS with integers covering at least {-2^53..2^53-1}. ; ; history of this file: ; SE, 18-Mar-2002: initial version ; SE, 22-Mar-2002: comments adjusted, range added ; SE, 25-Mar-2002: pack/unpack just return their argument ; the actual generator (define (mrg32k3a-random-m1 state) (let ((x11 (vector-ref state 0)) (x12 (vector-ref state 1)) (x13 (vector-ref state 2)) (x21 (vector-ref state 3)) (x22 (vector-ref state 4)) (x23 (vector-ref state 5))) (let ((x10 (modulo (- (* 1403580 x12) (* 810728 x13)) 4294967087)) (x20 (modulo (- (* 527612 x21) (* 1370589 x23)) 4294944443))) (vector-set! state 0 x10) (vector-set! state 1 x11) (vector-set! state 2 x12) (vector-set! state 3 x20) (vector-set! state 4 x21) (vector-set! state 5 x22) (modulo (- x10 x20) 4294967087)))) ; interface to the generic parts of the generator (define (mrg32k3a-pack-state unpacked-state) unpacked-state) (define (mrg32k3a-unpack-state state) state) (define (mrg32k3a-random-range) ; m1 4294967087) (define (mrg32k3a-random-integer state range) ; rejection method (let* ((q (quotient 4294967087 range)) (qn (* q range))) (do ((x (mrg32k3a-random-m1 state) (mrg32k3a-random-m1 state))) ((< x qn) (quotient x q))))) (define (mrg32k3a-random-real state) ; normalization is 1/(m1+1) (* 0.0000000002328306549295728 (+ 1.0 (mrg32k3a-random-m1 state)))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a27/mrg32k3a.scm000066400000000000000000000420661375154206600215100ustar00rootroot00000000000000; GENERIC PART OF MRG32k3a-GENERATOR FOR SRFI-27 ; ============================================== ; ; Sebastian.Egner@philips.com, 2002. ; ; This is the generic R5RS-part of the implementation of the MRG32k3a ; generator to be used in SRFI-27. It is based on a separate implementation ; of the core generator (presumably in native code) and on code to ; provide essential functionality not available in R5RS (see below). ; ; compliance: ; Scheme R5RS with integer covering at least {-2^53..2^53-1}. ; In addition, ; SRFI-23: error ; ; history of this file: ; SE, 22-Mar-2002: refactored from earlier versions ; SE, 25-Mar-2002: pack/unpack need not allocate ; SE, 27-Mar-2002: changed interface to core generator ; SE, 10-Apr-2002: updated spec of mrg32k3a-random-integer ; Generator ; ========= ; ; Pierre L'Ecuyer's MRG32k3a generator is a Combined Multiple Recursive ; Generator. It produces the sequence {(x[1,n] - x[2,n]) mod m1 : n} ; defined by the two recursive generators ; ; x[1,n] = ( a12 x[1,n-2] + a13 x[1,n-3]) mod m1, ; x[2,n] = (a21 x[2,n-1] + a23 x[2,n-3]) mod m2, ; ; where the constants are ; m1 = 4294967087 = 2^32 - 209 modulus of 1st component ; m2 = 4294944443 = 2^32 - 22853 modulus of 2nd component ; a12 = 1403580 recursion coefficients ; a13 = -810728 ; a21 = 527612 ; a23 = -1370589 ; ; The generator passes all tests of G. Marsaglia's Diehard testsuite. ; Its period is (m1^3 - 1)(m2^3 - 1)/2 which is nearly 2^191. ; L'Ecuyer reports: "This generator is well-behaved in all dimensions ; up to at least 45: ..." [with respect to the spectral test, SE]. ; ; The period is maximal for all values of the seed as long as the ; state of both recursive generators is not entirely zero. ; ; As the successor state is a linear combination of previous ; states, it is possible to advance the generator by more than one ; iteration by applying a linear transformation. The following ; publication provides detailed information on how to do that: ; ; [1] P. L'Ecuyer, R. Simard, E. J. Chen, W. D. Kelton: ; An Object-Oriented Random-Number Package With Many Long ; Streams and Substreams. 2001. ; To appear in Operations Research. ; ; Arithmetics ; =========== ; ; The MRG32k3a generator produces values in {0..2^32-209-1}. All ; subexpressions of the actual generator fit into {-2^53..2^53-1}. ; The code below assumes that Scheme's "integer" covers this range. ; In addition, it is assumed that floating point literals can be ; read and there is some arithmetics with inexact numbers. ; ; However, for advancing the state of the generator by more than ; one step at a time, the full range {0..2^32-209-1} is needed. ; Required: Backbone Generator ; ============================ ; ; At this point in the code, the following procedures are assumed ; to be defined to execute the core generator: ; ; (mrg32k3a-pack-state unpacked-state) -> packed-state ; (mrg32k3a-unpack-state packed-state) -> unpacked-state ; pack/unpack a state of the generator. The core generator works ; on packed states, passed as an explicit argument, only. This ; allows native code implementations to store their state in a ; suitable form. Unpacked states are #(x10 x11 x12 x20 x21 x22) ; with integer x_ij. Pack/unpack need not allocate new objects ; in case packed and unpacked states are identical. ; ; (mrg32k3a-random-range) -> m-max ; (mrg32k3a-random-integer packed-state range) -> x in {0..range-1} ; advance the state of the generator and return the next random ; range-limited integer. ; Note that the state is not necessarily advanced by just one ; step because we use the rejection method to avoid any problems ; with distribution anomalies. ; The range argument must be an exact integer in {1..m-max}. ; It can be assumed that range is a fixnum if the Scheme system ; has such a number representation. ; ; (mrg32k3a-random-real packed-state) -> x in (0,1) ; advance the state of the generator and return the next random ; real number between zero and one (both excluded). The type of ; the result should be a flonum if possible. ; Required: Record Data Type ; ========================== ; ; At this point in the code, the following procedures are assumed ; to be defined to create and access a new record data type: ; ; (:random-source-make a0 a1 a2 a3 a4 a5) -> s ; constructs a new random source object s consisting of the ; objects a0 .. a5 in this order. ; ; (:random-source? obj) -> bool ; tests if a Scheme object is a :random-source. ; ; (:random-source-state-ref s) -> a0 ; (:random-source-state-set! s) -> a1 ; (:random-source-randomize! s) -> a2 ; (:random-source-pseudo-randomize! s) -> a3 ; (:random-source-make-integers s) -> a4 ; (:random-source-make-reals s) -> a5 ; retrieve the values in the fields of the object s. ; Required: Current Time as an Integer ; ==================================== ; ; At this point in the code, the following procedure is assumed ; to be defined to obtain a value that is likely to be different ; for each invokation of the Scheme system: ; ; (:random-source-current-time) -> x ; an integer that depends on the system clock. It is desired ; that the integer changes as fast as possible. ; Accessing the State ; =================== (define (mrg32k3a-state-ref packed-state) (cons 'lecuyer-mrg32k3a (vector->list (mrg32k3a-unpack-state packed-state)))) (define (mrg32k3a-state-set external-state) (define (check-value x m) (if (and (integer? x) (exact? x) (<= 0 x (- m 1))) #t (error "illegal value" x))) (if (and (list? external-state) (= (length external-state) 7) (eq? (car external-state) 'lecuyer-mrg32k3a)) (let ((s (cdr external-state))) (check-value (list-ref s 0) mrg32k3a-m1) (check-value (list-ref s 1) mrg32k3a-m1) (check-value (list-ref s 2) mrg32k3a-m1) (check-value (list-ref s 3) mrg32k3a-m2) (check-value (list-ref s 4) mrg32k3a-m2) (check-value (list-ref s 5) mrg32k3a-m2) (if (or (zero? (+ (list-ref s 0) (list-ref s 1) (list-ref s 2))) (zero? (+ (list-ref s 3) (list-ref s 4) (list-ref s 5)))) (error "illegal degenerate state" external-state)) (mrg32k3a-pack-state (list->vector s))) (error "malformed state" external-state))) ; Pseudo-Randomization ; ==================== ; ; Reference [1] above shows how to obtain many long streams and ; substream from the backbone generator. ; ; The idea is that the generator is a linear operation on the state. ; Hence, we can express this operation as a 3x3-matrix acting on the ; three most recent states. Raising the matrix to the k-th power, we ; obtain the operation to advance the state by k steps at once. The ; virtual streams and substreams are now simply parts of the entire ; periodic sequence (which has period around 2^191). ; ; For the implementation it is necessary to compute with matrices in ; the ring (Z/(m1*m1)*Z)^(3x3). By the Chinese-Remainder Theorem, this ; is isomorphic to ((Z/m1*Z) x (Z/m2*Z))^(3x3). We represent such a pair ; of matrices ; [ [[x00 x01 x02], ; [x10 x11 x12], ; [x20 x21 x22]], mod m1 ; [[y00 y01 y02], ; [y10 y11 y12], ; [y20 y21 y22]] mod m2] ; as a vector of length 18 of the integers as writen above: ; #(x00 x01 x02 x10 x11 x12 x20 x21 x22 ; y00 y01 y02 y10 y11 y12 y20 y21 y22) ; ; As the implementation should only use the range {-2^53..2^53-1}, the ; fundamental operation (x*y) mod m, where x, y, m are nearly 2^32, ; is computed by breaking up x and y as x = x1*w + x0 and y = y1*w + y0 ; where w = 2^16. In this case, all operations fit the range because ; w^2 mod m is a small number. If proper multiprecision integers are ; available this is not necessary, but pseudo-randomize! is an expected ; to be called only occasionally so we do not provide this implementation. (define mrg32k3a-m1 4294967087) ; modulus of component 1 (define mrg32k3a-m2 4294944443) ; modulus of component 2 (define mrg32k3a-initial-state ; 0 3 6 9 12 15 of A^16, see below '#( 1062452522 2961816100 342112271 2854655037 3321940838 3542344109)) (define mrg32k3a-generators #f) ; computed when needed (define (mrg32k3a-pseudo-randomize-state i j) (define (product A B) ; A*B in ((Z/m1*Z) x (Z/m2*Z))^(3x3) (define w 65536) ; wordsize to split {0..2^32-1} (define w-sqr1 209) ; w^2 mod m1 (define w-sqr2 22853) ; w^2 mod m2 (define (lc i0 i1 i2 j0 j1 j2 m w-sqr) ; linear combination (let ((a0h (quotient (vector-ref A i0) w)) (a0l (modulo (vector-ref A i0) w)) (a1h (quotient (vector-ref A i1) w)) (a1l (modulo (vector-ref A i1) w)) (a2h (quotient (vector-ref A i2) w)) (a2l (modulo (vector-ref A i2) w)) (b0h (quotient (vector-ref B j0) w)) (b0l (modulo (vector-ref B j0) w)) (b1h (quotient (vector-ref B j1) w)) (b1l (modulo (vector-ref B j1) w)) (b2h (quotient (vector-ref B j2) w)) (b2l (modulo (vector-ref B j2) w))) (modulo (+ (* (+ (* a0h b0h) (* a1h b1h) (* a2h b2h)) w-sqr) (* (+ (* a0h b0l) (* a0l b0h) (* a1h b1l) (* a1l b1h) (* a2h b2l) (* a2l b2h)) w) (* a0l b0l) (* a1l b1l) (* a2l b2l)) m))) (vector (lc 0 1 2 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_00 mod m1 (lc 0 1 2 1 4 7 mrg32k3a-m1 w-sqr1) ; (A*B)_01 (lc 0 1 2 2 5 8 mrg32k3a-m1 w-sqr1) (lc 3 4 5 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_10 (lc 3 4 5 1 4 7 mrg32k3a-m1 w-sqr1) (lc 3 4 5 2 5 8 mrg32k3a-m1 w-sqr1) (lc 6 7 8 0 3 6 mrg32k3a-m1 w-sqr1) (lc 6 7 8 1 4 7 mrg32k3a-m1 w-sqr1) (lc 6 7 8 2 5 8 mrg32k3a-m1 w-sqr1) (lc 9 10 11 9 12 15 mrg32k3a-m2 w-sqr2) ; (A*B)_00 mod m2 (lc 9 10 11 10 13 16 mrg32k3a-m2 w-sqr2) (lc 9 10 11 11 14 17 mrg32k3a-m2 w-sqr2) (lc 12 13 14 9 12 15 mrg32k3a-m2 w-sqr2) (lc 12 13 14 10 13 16 mrg32k3a-m2 w-sqr2) (lc 12 13 14 11 14 17 mrg32k3a-m2 w-sqr2) (lc 15 16 17 9 12 15 mrg32k3a-m2 w-sqr2) (lc 15 16 17 10 13 16 mrg32k3a-m2 w-sqr2) (lc 15 16 17 11 14 17 mrg32k3a-m2 w-sqr2))) (define (power A e) ; A^e (cond ((zero? e) '#(1 0 0 0 1 0 0 0 1 1 0 0 0 1 0 0 0 1)) ((= e 1) A) ((even? e) (power (product A A) (quotient e 2))) (else (product (power A (- e 1)) A)))) (define (power-power A b) ; A^(2^b) (if (zero? b) A (power-power (product A A) (- b 1)))) (define A ; the MRG32k3a recursion '#( 0 1403580 4294156359 1 0 0 0 1 0 527612 0 4293573854 1 0 0 0 1 0)) ; check arguments (if (not (and (integer? i) (exact? i) (integer? j) (exact? j))) (error "i j must be exact integer" i j)) ; precompute A^(2^127) and A^(2^76) only once (if (not mrg32k3a-generators) (set! mrg32k3a-generators (list (power-power A 127) (power-power A 76) (power A 16)))) ; compute M = A^(16 + i*2^127 + j*2^76) (let ((M (product (list-ref mrg32k3a-generators 2) (product (power (list-ref mrg32k3a-generators 0) (modulo i (expt 2 28))) (power (list-ref mrg32k3a-generators 1) (modulo j (expt 2 28))))))) (mrg32k3a-pack-state (vector (vector-ref M 0) (vector-ref M 3) (vector-ref M 6) (vector-ref M 9) (vector-ref M 12) (vector-ref M 15))))) ; True Randomization ; ================== ; ; The value obtained from the system time is feed into a very ; simple pseudo random number generator. This in turn is used ; to obtain numbers to randomize the state of the MRG32k3a ; generator, avoiding period degeneration. (define (mrg32k3a-randomize-state state) ;; G. Marsaglia's simple 16-bit generator with carry (let* ((m 65536) (x (modulo (:random-source-current-time) m))) (define (random-m) (let ((y (modulo x m))) (set! x (+ (* 30903 y) (quotient x m))) y)) (define (random n) ; m < n < m^2 (modulo (+ (* (random-m) m) (random-m)) n)) ; modify the state (let ((m1 mrg32k3a-m1) (m2 mrg32k3a-m2) (s (mrg32k3a-unpack-state state))) (mrg32k3a-pack-state (vector (+ 1 (modulo (+ (vector-ref s 0) (random (- m1 1))) (- m1 1))) (modulo (+ (vector-ref s 1) (random m1)) m1) (modulo (+ (vector-ref s 2) (random m1)) m1) (+ 1 (modulo (+ (vector-ref s 3) (random (- m2 1))) (- m2 1))) (modulo (+ (vector-ref s 4) (random m2)) m2) (modulo (+ (vector-ref s 5) (random m2)) m2)))))) ; Large Integers ; ============== ; ; To produce large integer random deviates, for n > m-max, we first ; construct large random numbers in the range {0..m-max^k-1} for some ; k such that m-max^k >= n and then use the rejection method to choose ; uniformly from the range {0..n-1}. (define mrg32k3a-m-max (mrg32k3a-random-range)) (define (mrg32k3a-random-power state k) ; n = m-max^k, k >= 1 (if (= k 1) (mrg32k3a-random-integer state mrg32k3a-m-max) (+ (* (mrg32k3a-random-power state (- k 1)) mrg32k3a-m-max) (mrg32k3a-random-integer state mrg32k3a-m-max)))) (define (mrg32k3a-random-large state n) ; n > m-max (do ((k 2 (+ k 1)) (mk (* mrg32k3a-m-max mrg32k3a-m-max) (* mk mrg32k3a-m-max))) ((>= mk n) (let* ((mk-by-n (quotient mk n)) (a (* mk-by-n n))) (do ((x (mrg32k3a-random-power state k) (mrg32k3a-random-power state k))) ((< x a) (quotient x mk-by-n))))))) ; Multiple Precision Reals ; ======================== ; ; To produce multiple precision reals we produce a large integer value ; and convert it into a real value. This value is then normalized. ; The precision goal is unit <= 1/(m^k + 1), or 1/unit - 1 <= m^k. ; If you know more about the floating point number types of the ; Scheme system, this can be improved. (define (mrg32k3a-random-real-mp state unit) (do ((k 1 (+ k 1)) (u (- (/ 1 unit) 1) (/ u mrg32k3a-m1))) ((<= u 1) (/ (exact->inexact (+ (mrg32k3a-random-power state k) 1)) (exact->inexact (+ (expt mrg32k3a-m-max k) 1)))))) ; Provide the Interface as Specified in the SRFI ; ============================================== ; ; An object of type random-source is a record containing the procedures ; as components. The actual state of the generator is stored in the ; binding-time environment of make-random-source. (define (make-random-source) (let ((state (mrg32k3a-pack-state ; make a new copy (list->vector (vector->list mrg32k3a-initial-state))))) (:random-source-make (lambda () (mrg32k3a-state-ref state)) (lambda (new-state) (set! state (mrg32k3a-state-set new-state))) (lambda () (set! state (mrg32k3a-randomize-state state))) (lambda (i j) (set! state (mrg32k3a-pseudo-randomize-state i j))) (lambda () (lambda (n) (cond ((not (and (integer? n) (exact? n) (positive? n))) (error "range must be exact positive integer" n)) ((<= n mrg32k3a-m-max) (mrg32k3a-random-integer state n)) (else (mrg32k3a-random-large state n))))) (lambda args (cond ((null? args) (lambda () (mrg32k3a-random-real state))) ((null? (cdr args)) (let ((unit (car args))) (cond ((not (and (real? unit) (< 0 unit 1))) (error "unit must be real in (0,1)" unit)) ((<= (- (/ 1 unit) 1) mrg32k3a-m1) (lambda () (mrg32k3a-random-real state))) (else (lambda () (mrg32k3a-random-real-mp state unit)))))) (else (error "illegal arguments" args))))))) (define random-source? :random-source?) (define (random-source-state-ref s) ((:random-source-state-ref s))) (define (random-source-state-set! s state) ((:random-source-state-set! s) state)) (define (random-source-randomize! s) ((:random-source-randomize! s))) (define (random-source-pseudo-randomize! s i j) ((:random-source-pseudo-randomize! s) i j)) ; --- (define (random-source-make-integers s) ((:random-source-make-integers s))) (define (random-source-make-reals s . unit) (apply (:random-source-make-reals s) unit)) ; --- (define default-random-source (make-random-source)) (define random-integer (random-source-make-integers default-random-source)) (define random-real (random-source-make-reals default-random-source)) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a27/random-bits.sls000066400000000000000000000021261375154206600224060ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :27 random-bits) (export random-integer random-real default-random-source make-random-source random-source? random-source-state-ref random-source-state-set! random-source-randomize! random-source-pseudo-randomize! random-source-make-integers random-source-make-reals) (import (rnrs) (rnrs r5rs) (only (srfi :19 time) current-time time-nanosecond) (srfi :23 error tricks) (srfi private include)) (define-record-type (:random-source :random-source-make :random-source?) (fields state-ref state-set! randomize! pseudo-randomize! make-integers make-reals)) (define (:random-source-current-time) (time-nanosecond (current-time))) (SRFI-23-error->R6RS "(library (srfi :27 random-bits))" (include/resolve ("srfi" "%3a27") "mrg32k3a-a.scm") (include/resolve ("srfi" "%3a27") "mrg32k3a.scm")) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a28.sls000066400000000000000000000001161375154206600201650ustar00rootroot00000000000000(library (srfi :28) (export format) (import (srfi :28 basic-format-strings))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a28/000077500000000000000000000000001375154206600174445ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a28/basic-format-strings.sls000066400000000000000000000055561375154206600242400ustar00rootroot00000000000000(library (srfi :28 basic-format-strings) (export format) (import (rnrs) (srfi :6)) ;; reference implementation from srfi :28 documentation ;; Copyright (C) Scott G. Miller (2002). All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the "Software"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. ;; (define format (lambda (format-string . objects) (let ((buffer (open-output-string))) (let loop ((format-list (string->list format-string)) (objects objects)) (cond ((null? format-list) (get-output-string buffer)) ((char=? (car format-list) #\~) (if (null? (cdr format-list)) (error 'format "Incomplete escape sequence") (case (cadr format-list) ((#\a) (if (null? objects) (error 'format "No value for escape sequence") (begin (display (car objects) buffer) (loop (cddr format-list) (cdr objects))))) ((#\s) (if (null? objects) (error 'format "No value for escape sequence") (begin (write (car objects) buffer) (loop (cddr format-list) (cdr objects))))) ((#\%) (newline buffer) (loop (cddr format-list) objects)) ((#\~) (write-char #\~ buffer) (loop (cddr format-list) objects)) (else (error 'format "Unrecognized escape sequence"))))) (else (write-char (car format-list) buffer) (loop (cdr format-list) objects)))))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a29.sls000066400000000000000000000003321375154206600201660ustar00rootroot00000000000000(library (srfi :29) (export current-language current-country current-locale-details declare-bundle! store-bundle store-bundle! load-bundle! localized-template) (import (srfi :29 localization))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a29/000077500000000000000000000000001375154206600174455ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a29/localization.sls000066400000000000000000000212101375154206600226540ustar00rootroot00000000000000(library (srfi :29 localization) (export current-language current-country current-locale-details declare-bundle! store-bundle store-bundle! load-bundle! localized-template) (import (rnrs) (srfi :6)) (define (current-locale-details . args) (error 'current-locale-details "procedure not supplied by reference implementation")) (define-syntax store-bundle (identifier-syntax store-bundle!)) ;; reference implementation taken from srfi :29 documenation ;; Copyright (C) Scott G. Miller (2002). All Rights Reserved. ;; ;; This document and translations of it may be copied and furnished to ;; others, and derivative works that comment on or otherwise explain it or ;; assist in its implementation may be prepared, copied, published and ;; distributed, in whole or in part, without restriction of any kind, ;; provided that the above copyright notice and this paragraph are included ;; on all such copies and derivative works. However, this document itself may ;; not be modified in any way, such as by removing the copyright notice or ;; references to the Scheme Request For Implementation process or editors, ;; except as needed for the purpose of developing SRFIs in which case the ;; procedures for copyrights defined in the SRFI process must be followed, or ;; as required to translate it into languages other than English. ;; ;; The limited permissions granted above are perpetual and will not be ;; revoked by the authors or their successors or assigns. ;; ;; This document and the information contained herein is provided on an "AS ;; IS" basis and THE AUTHOR AND THE SRFI EDITORS DISCLAIM ALL WARRANTIES, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTY THAT THE USE ;; OF THE INFORMATION HEREIN WILL NOT INFRINGE ANY RIGHTS OR ANY IMPLIED ;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. ;; ;; The association list in which bundles will be stored (define *localization-bundles* '()) ;; The current-language and current-country functions provided ;; here must be rewritten for each Scheme system to default to the ;; actual locale of the session (define current-language (let ((current-language-value 'en)) (lambda args (if (null? args) current-language-value (set! current-language-value (car args)))))) (define current-country (let ((current-country-value 'us)) (lambda args (if (null? args) current-country-value (set! current-country-value (car args)))))) ;; The load-bundle! and store-bundle! both return #f in this ;; reference implementation. A compliant implementation need ;; not rewrite these procedures. (define load-bundle! (lambda (bundle-specifier) #f)) (define store-bundle! (lambda (bundle-specifier) #f)) ;; Declare a bundle of templates with a given bundle specifier (define declare-bundle! (letrec ((remove-old-bundle (lambda (specifier bundle) (cond ((null? bundle) '()) ((equal? (caar bundle) specifier) (cdr bundle)) (else (cons (car bundle) (remove-old-bundle specifier (cdr bundle)))))))) (lambda (bundle-specifier bundle-assoc-list) (set! *localization-bundles* (cons (cons bundle-specifier bundle-assoc-list) (remove-old-bundle bundle-specifier *localization-bundles*)))))) ;;Retrieve a localized template given its package name and a template name (define localized-template (letrec ((rdc (lambda (ls) (if (null? (cdr ls)) '() (cons (car ls) (rdc (cdr ls)))))) (find-bundle (lambda (specifier template-name) (cond ((assoc specifier *localization-bundles*) => (lambda (bundle) bundle)) ((null? specifier) #f) (else (find-bundle (rdc specifier) template-name)))))) (lambda (package-name template-name) (let loop ((specifier (cons package-name (list (current-language) (current-country))))) (and (not (null? specifier)) (let ((bundle (find-bundle specifier template-name))) (and bundle (cond ((assq template-name bundle) => cdr) ((null? (cdr specifier)) #f) (else (loop (rdc specifier))))))))))) ;;An SRFI-28 and SRFI-29 compliant version of format. It requires ;;SRFI-23 for error reporting. (define format (lambda (format-string . objects) (let ((buffer (open-output-string))) (let loop ((format-list (string->list format-string)) (objects objects) (object-override #f)) (cond ((null? format-list) (get-output-string buffer)) ((char=? (car format-list) #\~) (cond ((null? (cdr format-list)) (error 'format "Incomplete escape sequence")) ((char-numeric? (cadr format-list)) (let posloop ((fl (cddr format-list)) (pos (string->number (string (cadr format-list))))) (cond ((null? fl) (error 'format "Incomplete escape sequence")) ((and (eq? (car fl) '#\@) (null? (cdr fl))) (error 'format "Incomplete escape sequence")) ((and (eq? (car fl) '#\@) (eq? (cadr fl) '#\*)) (loop (cddr fl) objects (list-ref objects pos))) (else (posloop (cdr fl) (+ (* 10 pos) (string->number (string (car fl))))))))) (else (case (cadr format-list) ((#\a) (cond (object-override (begin (display object-override buffer) (loop (cddr format-list) objects #f))) ((null? objects) (error 'format "No value for escape sequence")) (else (begin (display (car objects) buffer) (loop (cddr format-list) (cdr objects) #f))))) ((#\s) (cond (object-override (begin (display object-override buffer) (loop (cddr format-list) objects #f))) ((null? objects) (error 'format "No value for escape sequence")) (else (begin (write (car objects) buffer) (loop (cddr format-list) (cdr objects) #f))))) ((#\%) (if object-override (error 'format "Escape sequence following positional override does not require a value")) (display #\newline buffer) (loop (cddr format-list) objects #f)) ((#\~) (if object-override (error 'format "Escape sequence following positional override does not require a value")) (display #\~ buffer) (loop (cddr format-list) objects #f)) (else (error 'format "Unrecognized escape sequence")))))) (else (display (car format-list) buffer) (loop (cdr format-list) objects #f))))))) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a31.sls000066400000000000000000000002131375154206600201550ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :31) (export rec) (import (srfi :31 rec)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a31/000077500000000000000000000000001375154206600174365ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a31/rec.sls000066400000000000000000000007351375154206600207370ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :31 rec) (export rec) (import (rnrs)) ;; Taken directly from the SRFI-31 (define-syntax rec (syntax-rules () ((rec (NAME . VARIABLES) . BODY) (letrec ( (NAME (lambda VARIABLES . BODY)) ) NAME)) ((rec NAME EXPRESSION) (letrec ( (NAME EXPRESSION) ) NAME)))) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a34.sls000066400000000000000000000001541375154206600201640ustar00rootroot00000000000000(library (srfi :34) (export with-exception-handler guard raise) (import (srfi :34 exception-handling))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a34/000077500000000000000000000000001375154206600174415ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a34/exception-handling.sls000066400000000000000000000101771375154206600237520ustar00rootroot00000000000000(library (srfi :34 exception-handling) (export with-exception-handler guard raise) (import (except (rnrs) with-exception-handler guard raise error) (srfi :23)) ;; reference implementation from srfi :34 documentation (though it closely matches the existing rnrs facility) ;; Copyright (C) Richard Kelsey, Michael Sperber (2002). All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the "Software"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. (define *current-exception-handlers* (list (lambda (condition) (error "unhandled exception" condition)))) (define (with-exception-handler handler thunk) (with-exception-handlers (cons handler *current-exception-handlers*) thunk)) (define (with-exception-handlers new-handlers thunk) (let ((previous-handlers *current-exception-handlers*)) (dynamic-wind (lambda () (set! *current-exception-handlers* new-handlers)) thunk (lambda () (set! *current-exception-handlers* previous-handlers))))) (define (raise obj) (let ((handlers *current-exception-handlers*)) (with-exception-handlers (cdr handlers) (lambda () ((car handlers) obj) (error "handler returned" (car handlers) obj))))) (define-syntax guard (syntax-rules () ((guard (var clause ...) e1 e2 ...) ((call-with-current-continuation (lambda (guard-k) (with-exception-handler (lambda (condition) ((call-with-current-continuation (lambda (handler-k) (guard-k (lambda () (let ((var condition)) ; clauses may SET! var (guard-aux (handler-k (lambda () (raise condition))) clause ...)))))))) (lambda () (call-with-values (lambda () e1 e2 ...) (lambda args (guard-k (lambda () (apply values args))))))))))))) (define-syntax guard-aux (syntax-rules (else =>) ((guard-aux reraise (else result1 result2 ...)) (begin result1 result2 ...)) ((guard-aux reraise (test => result)) (let ((temp test)) (if temp (result temp) reraise))) ((guard-aux reraise (test => result) clause1 clause2 ...) (let ((temp test)) (if temp (result temp) (guard-aux reraise clause1 clause2 ...)))) ((guard-aux reraise (test)) test) ((guard-aux reraise (test) clause1 clause2 ...) (let ((temp test)) (if temp temp (guard-aux reraise clause1 clause2 ...)))) ((guard-aux reraise (test result1 result2 ...)) (if test (begin result1 result2 ...) reraise)) ((guard-aux reraise (test result1 result2 ...) clause1 clause2 ...) (if test (begin result1 result2 ...) (guard-aux reraise clause1 clause2 ...)))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a35.sls000066400000000000000000000004441375154206600201670ustar00rootroot00000000000000(library (srfi :35) (export make-condition-type condition-type? make-condition condition? condition-has-type? condition-ref make-compound-condition extract-condition define-condition-type condition &condition &serious &error) (import (srfi :35 conditions))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a35/000077500000000000000000000000001375154206600174425ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a35/conditions.sls000066400000000000000000000211621375154206600223400ustar00rootroot00000000000000(library (srfi :35 conditions) (export make-condition-type condition-type? condition-has-type? condition-ref make-compound-condition extract-condition define-condition-type &condition make-condition condition? condition &serious serious-condition? &error error? &message message-condition? condition-message) (import (except (rnrs) define-condition-type condition &condition condition? &serious serious-condition? &error error? &message message-condition? condition-message define-record-type error) (only (srfi :1) lset= lset-intersection lset-difference any) (srfi :9) (srfi :23)) ;; reference implementation from srfi 35: overlaps some of r6rs conditions ;; Copyright (C) Richard Kelsey, Michael Sperber (2002). All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a ;; copy of this software and associated documentation files (the "Software"), ;; to deal in the Software without restriction, including without limitation ;; the rights to use, copy, modify, merge, publish, distribute, sublicense, ;; and/or sell copies of the Software, and to permit persons to whom the ;; Software is furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. (define-record-type :condition-type (really-make-condition-type name supertype fields all-fields) condition-type? (name condition-type-name) (supertype condition-type-supertype) (fields condition-type-fields) (all-fields condition-type-all-fields)) (define (make-condition-type name supertype fields) (if (not (symbol? name)) (error "make-condition-type: name is not a symbol" name)) (if (not (condition-type? supertype)) (error "make-condition-type: supertype is not a condition type" supertype)) (if (not (null? (lset-intersection eq? (condition-type-all-fields supertype) fields))) (error "duplicate field name" )) (really-make-condition-type name supertype fields (append (condition-type-all-fields supertype) fields))) (define-syntax define-condition-type (syntax-rules () ((define-condition-type ?name ?supertype ?predicate (?field1 ?accessor1) ...) (begin (define ?name (make-condition-type '?name ?supertype '(?field1 ...))) (define (?predicate thing) (and (condition? thing) (condition-has-type? thing ?name))) (define (?accessor1 condition) (condition-ref (extract-condition condition ?name) '?field1)) ...)))) (define (condition-subtype? subtype supertype) (let recur ((subtype subtype)) (cond ((not subtype) #f) ((eq? subtype supertype) #t) (else (recur (condition-type-supertype subtype)))))) (define (condition-type-field-supertype condition-type field) (let loop ((condition-type condition-type)) (cond ((not condition-type) #f) ((memq field (condition-type-fields condition-type)) condition-type) (else (loop (condition-type-supertype condition-type)))))) ; The type-field-alist is of the form ; (( ( . ) ...) ...) (define-record-type :condition (really-make-condition type-field-alist) condition? (type-field-alist condition-type-field-alist)) (define (make-condition type . field-plist) (let ((alist (let label ((plist field-plist)) (if (null? plist) '() (cons (cons (car plist) (cadr plist)) (label (cddr plist))))))) (if (not (lset= eq? (condition-type-all-fields type) (map car alist))) (error "condition fields don't match condition type")) (really-make-condition (list (cons type alist))))) (define (condition-has-type? condition type) (any (lambda (has-type) (condition-subtype? has-type type)) (condition-types condition))) (define (condition-ref condition field) (type-field-alist-ref (condition-type-field-alist condition) field)) (define (type-field-alist-ref type-field-alist field) (let loop ((type-field-alist type-field-alist)) (cond ((null? type-field-alist) (error "type-field-alist-ref: field not found" type-field-alist field)) ((assq field (cdr (car type-field-alist))) => cdr) (else (loop (cdr type-field-alist)))))) (define (make-compound-condition condition-1 . conditions) (really-make-condition (apply append (map condition-type-field-alist (cons condition-1 conditions))))) (define (extract-condition condition type) (let ((entry (find (lambda (entry) (condition-subtype? (car entry) type)) (condition-type-field-alist condition)))) (if (not entry) (error "extract-condition: invalid condition type" condition type)) (really-make-condition (list (cons type (map (lambda (field) (assq field (cdr entry))) (condition-type-all-fields type))))))) (define-syntax condition (syntax-rules () ((condition (?type1 (?field1 ?value1) ...) ...) (type-field-alist->condition (list (cons ?type1 (list (cons '?field1 ?value1) ...)) ...))))) (define (type-field-alist->condition type-field-alist) (really-make-condition (map (lambda (entry) (cons (car entry) (map (lambda (field) (or (assq field (cdr entry)) (cons field (type-field-alist-ref type-field-alist field)))) (condition-type-all-fields (car entry))))) type-field-alist))) (define (condition-types condition) (map car (condition-type-field-alist condition))) (define (check-condition-type-field-alist the-type-field-alist) (let loop ((type-field-alist the-type-field-alist)) (if (not (null? type-field-alist)) (let* ((entry (car type-field-alist)) (type (car entry)) (field-alist (cdr entry)) (fields (map car field-alist)) (all-fields (condition-type-all-fields type))) (for-each (lambda (missing-field) (let ((supertype (condition-type-field-supertype type missing-field))) (if (not (any (lambda (entry) (let ((type (car entry))) (condition-subtype? type supertype))) the-type-field-alist)) (error "missing field in condition construction" type missing-field)))) (lset-difference eq? all-fields fields)) (loop (cdr type-field-alist)))))) (define &condition (really-make-condition-type '&condition #f '() '())) (define-condition-type &message &condition message-condition? (message condition-message)) (define-condition-type &serious &condition serious-condition?) (define-condition-type &error &serious error?)) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a37.sls000066400000000000000000000004061375154206600201670ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :37) (export args-fold option option-names option-optional-arg? option-processor option-required-arg? option?) (import (srfi :37 args-fold)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a37/000077500000000000000000000000001375154206600174445ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a37/args-fold.sls000066400000000000000000000023171375154206600220500ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :37 args-fold) (export args-fold (rename (make-option option)) option? option-names option-required-arg? option-optional-arg? option-processor) (import (rnrs) (srfi private include)) (define-record-type option (fields names required-arg? optional-arg? processor) (protocol (lambda (c) (lambda (n ra oa p) (if (and (and (list? n) (positive? (length n)) (for-all (lambda (x) (or (and (string? x) (positive? (string-length x))) (char? x))) n)) (boolean? ra) (boolean? oa) (not (and ra oa)) (procedure? p)) (c n ra oa p) (assertion-violation 'option "invalid arguments" n ra oa p)))))) (define args-fold (let ((option make-option)) (include/resolve ("srfi" "%3a37") "srfi-37-reference.scm") args-fold)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a37/srfi-37-reference.scm000066400000000000000000000236151375154206600233050ustar00rootroot00000000000000;;; args-fold.scm - a program argument processor ;;; ;;; Copyright (c) 2002 Anthony Carrico ;;; ;;; All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; 1. Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; 2. Redistributions in binary form must reproduce the above copyright ;;; notice, this list of conditions and the following disclaimer in the ;;; documentation and/or other materials provided with the distribution. ;;; 3. The name of the authors may not be used to endorse or promote products ;;; derived from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR ;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES ;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. ;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, ;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT ;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; NOTE: This implementation uses the following SRFIs: ;;; "SRFI 9: Defining Record Types" ;;; "SRFI 11: Syntax for receiving multiple values" ;;; ;;; NOTE: The scsh-utils and Chicken implementations use regular ;;; expressions. These might be easier to read and understand. #| (define option #f) (define option-names #f) (define option-required-arg? #f) (define option-optional-arg? #f) (define option-processor #f) (define option? #f) (let () (define-record-type option-type ($option names required-arg? optional-arg? processor) $option? (names $option-names) (required-arg? $option-required-arg?) (optional-arg? $option-optional-arg?) (processor $option-processor)) (set! option $option) (set! option-names $option-names) (set! option-required-arg? $option-required-arg?) (set! option-optional-arg? $option-optional-arg?) (set! option-processor $option-processor) (set! option? $option?)) |# (define args-fold (lambda (args options unrecognized-option-proc operand-proc . seeds) (letrec ((find (lambda (l ?) (cond ((null? l) #f) ((? (car l)) (car l)) (else (find (cdr l) ?))))) (find-option ;; ISSUE: This is a brute force search. Could use a table. (lambda (name) (find options (lambda (option) (find (option-names option) (lambda (test-name) (equal? name test-name))))))) (scan-short-options (lambda (index shorts args seeds) (if (= index (string-length shorts)) (scan-args args seeds) (let* ((name (string-ref shorts index)) (option (or (find-option name) (option (list name) #f #f unrecognized-option-proc)))) (cond ((and (< (+ index 1) (string-length shorts)) (or (option-required-arg? option) (option-optional-arg? option))) (let-values ((seeds (apply (option-processor option) option name (substring shorts (+ index 1) (string-length shorts)) seeds))) (scan-args args seeds))) ((and (option-required-arg? option) (pair? args)) (let-values ((seeds (apply (option-processor option) option name (car args) seeds))) (scan-args (cdr args) seeds))) (else (let-values ((seeds (apply (option-processor option) option name #f seeds))) (scan-short-options (+ index 1) shorts args seeds)))))))) (scan-operands (lambda (operands seeds) (if (null? operands) (apply values seeds) (let-values ((seeds (apply operand-proc (car operands) seeds))) (scan-operands (cdr operands) seeds))))) (scan-args (lambda (args seeds) (if (null? args) (apply values seeds) (let ((arg (car args)) (args (cdr args))) ;; NOTE: This string matching code would be simpler ;; using a regular expression matcher. (cond (;; (rx bos "--" eos) (string=? "--" arg) ;; End option scanning: (scan-operands args seeds)) (;;(rx bos ;; "--" ;; (submatch (+ (~ "="))) ;; "=" ;; (submatch (* any))) (and (> (string-length arg) 4) (char=? #\- (string-ref arg 0)) (char=? #\- (string-ref arg 1)) (not (char=? #\= (string-ref arg 2))) (let loop ((index 3)) (cond ((= index (string-length arg)) #f) ((char=? #\= (string-ref arg index)) index) (else (loop (+ 1 index)))))) ;; Found long option with arg: => (lambda (=-index) (let*-values (((name) (substring arg 2 =-index)) ((option-arg) (substring arg (+ =-index 1) (string-length arg))) ((option) (or (find-option name) (option (list name) #t #f unrecognized-option-proc))) (seeds (apply (option-processor option) option name option-arg seeds))) (scan-args args seeds)))) (;;(rx bos "--" (submatch (+ any))) (and (> (string-length arg) 3) (char=? #\- (string-ref arg 0)) (char=? #\- (string-ref arg 1))) ;; Found long option: (let* ((name (substring arg 2 (string-length arg))) (option (or (find-option name) (option (list name) #f #f unrecognized-option-proc)))) (if (and (option-required-arg? option) (pair? args)) (let-values ((seeds (apply (option-processor option) option name (car args) seeds))) (scan-args (cdr args) seeds)) (let-values ((seeds (apply (option-processor option) option name #f seeds))) (scan-args args seeds))))) (;; (rx bos "-" (submatch (+ any))) (and (> (string-length arg) 1) (char=? #\- (string-ref arg 0))) ;; Found short options (let ((shorts (substring arg 1 (string-length arg)))) (scan-short-options 0 shorts args seeds))) (else (let-values ((seeds (apply operand-proc arg seeds))) (scan-args args seeds))))))))) (scan-args args seeds)))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a38.sls000066400000000000000000000003551375154206600201730ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :38) (export read-with-shared-structure read/ss write-with-shared-structure write/ss) (import (srfi :38 with-shared-structure)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a38/000077500000000000000000000000001375154206600174455ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a38/with-shared-structure.chezscheme.sls000066400000000000000000000026751375154206600265740ustar00rootroot00000000000000;;; Copyright (c) 2012 Aaron W. Hsu ;;; ;;; Permission to use, copy, modify, and distribute this software for ;;; any purpose with or without fee is hereby granted, provided that the ;;; above copyright notice and this permission notice appear in all ;;; copies. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE ;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL ;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA ;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR ;;; PERFORMANCE OF THIS SOFTWARE. (library (srfi :38 with-shared-structure) (export write-with-shared-structure (rename (write-with-shared-structure write/ss)) read-with-shared-structure (rename (read-with-shared-structure read/ss))) (import (chezscheme)) (define write-with-shared-structure (case-lambda [(obj) (write-with-shared-structure obj (current-output-port))] [(obj port) (parameterize ((print-graph #T)) (write obj port))] [(obj port optarg) (assertion-violation 'write-with-shared-structure "this implementation does not support optarg")])) (define read-with-shared-structure read) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a38/with-shared-structure.ikarus.sls000066400000000000000000000015311375154206600257420ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :38 with-shared-structure) (export write-with-shared-structure (rename (write-with-shared-structure write/ss)) read-with-shared-structure (rename (read-with-shared-structure read/ss))) (import (rnrs) (only (ikarus) print-graph parameterize)) (define write-with-shared-structure (case-lambda ((obj) (write-with-shared-structure obj (current-output-port))) ((obj port) (parameterize ((print-graph #T)) (write obj port))) ((obj port optarg) (assertion-violation 'write-with-shared-structure "this implementation does not support optarg")))) (define read-with-shared-structure read) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a38/with-shared-structure.ypsilon.sls000066400000000000000000000007161375154206600261450ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :38 with-shared-structure) (export write-with-shared-structure (rename (write-with-shared-structure write/ss)) read-with-shared-structure (rename (read-with-shared-structure read/ss))) (import (only (core) write-with-shared-structure read-with-shared-structure)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a39.sls000066400000000000000000000002561375154206600201740ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :39) (export make-parameter parameterize) (import (srfi :39 parameters)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a39/000077500000000000000000000000001375154206600174465ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a39/parameters.chezscheme.sls000066400000000000000000000016671375154206600244630ustar00rootroot00000000000000;;; Copyright (c) 2012 Aaron W. Hsu ;;; ;;; Permission to use, copy, modify, and distribute this software for ;;; any purpose with or without fee is hereby granted, provided that the ;;; above copyright notice and this permission notice appear in all ;;; copies. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE ;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL ;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA ;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR ;;; PERFORMANCE OF THIS SOFTWARE. (library (srfi :39 parameters) (export make-parameter parameterize) (import (only (chezscheme) make-parameter parameterize))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a39/parameters.ikarus.sls000066400000000000000000000004541375154206600236340ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :39 parameters) (export make-parameter parameterize) (import (only (ikarus) make-parameter parameterize)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a39/parameters.ironscheme.sls000066400000000000000000000007111375154206600244660ustar00rootroot00000000000000#!r6rs ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an ;; MIT-style license. My license is in the file named LICENSE from the original ;; collection this file is distributed with. If this file is redistributed with ;; some other collection, my license must also be included. (library (srfi :39 parameters) (export make-parameter parameterize) (import (only (ironscheme) make-parameter parameterize)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a39/parameters.mzscheme.sls000066400000000000000000000004611375154206600241470ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :39 parameters) (export make-parameter parameterize) (import (only (scheme base) make-parameter parameterize)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a39/parameters.sls000066400000000000000000000026431375154206600223410ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. ;; Fall-back library in case the host Scheme system does not provide SRFI-39. (library (srfi :39 parameters) (export make-parameter parameterize) (import (rnrs)) (define make-parameter (case-lambda ((val) (make-parameter val values)) ((val guard) (unless (procedure? guard) (assertion-violation 'make-parameter "not a procedure" guard)) (let ((p (case-lambda (() val) ((x) (set! val (guard x)))))) (p val) p)))) (define-syntax parameterize ;; Derived from Ikarus's implementation of parameterize. (lambda (stx) (syntax-case stx () ((_ () b0 b ...) #'(let () b0 b ...)) ((_ ((p e) ...) b0 b ...) (with-syntax (((tp ...) (generate-temporaries #'(p ...))) ((te ...) (generate-temporaries #'(e ...)))) #'(let ((tp p) ... (te e) ...) (let ((swap (lambda () (let ((t (tp))) (tp te) (set! te t)) ...))) (dynamic-wind swap (lambda () b0 b ...) swap)))))))) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a39/parameters.ypsilon.sls000066400000000000000000000004451375154206600240330ustar00rootroot00000000000000#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :39 parameters) (export make-parameter parameterize) (import (only (core) make-parameter parameterize)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a4.sls000066400000000000000000000046061375154206600201070ustar00rootroot00000000000000;; SRFI-4 r6rs library entry ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to ;; deal in the Software without restriction, including without limitation the ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or ;; sell copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. (library (srfi :4) (export s8vector? make-s8vector s8vector s8vector-length s8vector-ref s8vector-set! s8vector->list list->s8vector s16vector? make-s16vector s16vector s16vector-length s16vector-ref s16vector-set! s16vector->list list->s16vector s32vector? make-s32vector s32vector s32vector-length s32vector-ref s32vector-set! s32vector->list list->s32vector s64vector? make-s64vector s64vector s64vector-length s64vector-ref s64vector-set! s64vector->list list->s64vector u8vector? make-u8vector u8vector u8vector-length u8vector-ref u8vector-set! u8vector->list list->u8vector u16vector? make-u16vector u16vector u16vector-length u16vector-ref u16vector-set! u16vector->list list->u16vector u32vector? make-u32vector u32vector u32vector-length u32vector-ref u32vector-set! u32vector->list list->u32vector u64vector? make-u64vector u64vector u64vector-length u64vector-ref u64vector-set! u64vector->list list->u64vector f32vector? make-f32vector f32vector f32vector-length f32vector-ref f32vector-set! f32vector->list list->f32vector f64vector? make-f64vector f64vector f64vector-length f64vector-ref f64vector-set! f64vector->list list->f64vector) (import (srfi :4 numeric-vectors))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a4/000077500000000000000000000000001375154206600173565ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a4/numeric-vectors.sls000066400000000000000000000257261375154206600232420ustar00rootroot00000000000000;; SRFI-4 implementation ;; ;; Wraps a bytevector with a scheme record so that the wrapping vector ;; predicates can uniquely recognize it. This approach is based on the one ;; suggested in the SRFI-4 write-up, with macros as helpers to generate the ;; implementation. ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep (library (srfi :4 numeric-vectors) (export s8vector? make-s8vector s8vector s8vector-length s8vector-ref s8vector-set! s8vector->list list->s8vector s16vector? make-s16vector s16vector s16vector-length s16vector-ref s16vector-set! s16vector->list list->s16vector s32vector? make-s32vector s32vector s32vector-length s32vector-ref s32vector-set! s32vector->list list->s32vector s64vector? make-s64vector s64vector s64vector-length s64vector-ref s64vector-set! s64vector->list list->s64vector u8vector? make-u8vector u8vector u8vector-length u8vector-ref u8vector-set! u8vector->list list->u8vector u16vector? make-u16vector u16vector u16vector-length u16vector-ref u16vector-set! u16vector->list list->u16vector u32vector? make-u32vector u32vector u32vector-length u32vector-ref u32vector-set! u32vector->list list->u32vector u64vector? make-u64vector u64vector u64vector-length u64vector-ref u64vector-set! u64vector->list list->u64vector f32vector? make-f32vector f32vector f32vector-length f32vector-ref f32vector-set! f32vector->list list->f32vector f64vector? make-f64vector f64vector f64vector-length f64vector-ref f64vector-set! f64vector->list list->f64vector) (import (rnrs) (srfi :28)) (define-syntax define-integer-vector (lambda (x) (define format-id (lambda (tid fmt . args) (datum->syntax tid (string->symbol (apply format fmt args))))) (syntax-case x () [(k signed? bit-size) (and (boolean? (syntax->datum #'signed?)) (let ([bit-size (syntax->datum #'bit-size)]) (and (integer? bit-size) (exact? bit-size)))) (let ([signed? (syntax->datum #'signed?)] [bit-size (syntax->datum #'bit-size)]) (let ([base-name (format "~a~svector" (if signed? #\s #\u) bit-size)]) (with-syntax ([name (format-id #'k "$~a" base-name)] [bv-accessor (format-id #'k "$~a-bv" base-name)] [maker (format-id #'k "make-~a" base-name)] [pred (format-id #'k "~a?" base-name)] [litmaker (format-id #'k "~a" base-name)] [len (format-id #'k "~a-length" base-name)] [ref (format-id #'k "~a-ref" base-name)] [set (format-id #'k "~a-set!" base-name)] [->list (format-id #'k "~a->list" base-name)] [list-> (format-id #'k "list->~a" base-name)] [bytes (fxdiv bit-size 8)] [min (if signed? (- (expt 2 (- bit-size 1))) 0)] [max (if signed? (- (expt 2 (- bit-size 1)) 1) (- (expt 2 bit-size) 1))] [(bytevector-ref bytevector-set!) (let ([signed-char (if signed? #\s #\u)]) (if (fx=? bit-size 8) (list (format-id #'k "bytevector-~a~s-ref" signed-char bit-size) (format-id #'k "bytevector-~a~s-set!" signed-char bit-size)) (list (format-id #'k "bytevector-~a~s-native-ref" signed-char bit-size) (format-id #'k "bytevector-~a~s-native-set!" signed-char bit-size))))]) #'(begin (define check-val (lambda (who value) (unless (and (and (integer? value) (exact? value)) (<= min value max)) (error who (format "expected integer value in range ~s to ~s, but got ~s" min max value))))) (define-record-type (name maker pred) (nongenerative) (sealed #t) (opaque #t) (fields (immutable bv bv-accessor)) (protocol (lambda (new) (case-lambda [(size) (new (make-bytevector (fx* size bytes)))] [(size value) (check-val 'maker value) (let ([bv-size (fx* size bytes)]) (let ([bv (make-bytevector bv-size)]) (do ([i 0 (fx+ i bytes)]) ((fx=? i bv-size) (new bv)) (bytevector-set! bv i value))))])))) (define len (lambda (v) (fxdiv (bytevector-length (bv-accessor v)) bytes))) (define ref (lambda (v i) (bytevector-ref (bv-accessor v) (fx* i bytes)))) (define set (lambda (v i value) (check-val 'set! value) (bytevector-set! (bv-accessor v) (fx* i bytes) value))) (define ->list (lambda (v) (let ([bv (bv-accessor v)]) (let loop ([n (bytevector-length bv)] [ls '()]) (if (fx=? n 0) ls (let ([n (fx- n bytes)]) (loop n (cons (bytevector-ref bv n) ls)))))))) (define $list-> (lambda (who ls) (let f ([ls ls] [bv-bytes 0]) (if (null? ls) (maker (fxdiv bv-bytes bytes)) (let ([v (f (cdr ls) (fx+ bv-bytes bytes))] [val (car ls)]) (check-val who val) (bytevector-set! (bv-accessor v) bv-bytes val) v))))) (define list-> (lambda (ls) ($list-> 'list-> ls))) (define litmaker (lambda args ($list-> 'litmaker args)))))))]))) (define-integer-vector #t 8) (define-integer-vector #t 16) (define-integer-vector #t 32) (define-integer-vector #t 64) (define-integer-vector #f 8) (define-integer-vector #f 16) (define-integer-vector #f 32) (define-integer-vector #f 64) (define-syntax define-float-vector (lambda (x) (define format-id (lambda (tid fmt . args) (datum->syntax tid (string->symbol (apply format fmt args))))) (syntax-case x () [(k bit-size) (let ([bit-size (syntax->datum #'bit-size)]) (and (integer? bit-size) (exact? bit-size))) (let ([bit-size (syntax->datum #'bit-size)]) (let ([base-name (format "f~svector" bit-size)]) (with-syntax ([name (format-id #'k "$~a" base-name)] [bv-accessor (format-id #'k "$~a-bv" base-name)] [maker (format-id #'k "make-~a" base-name)] [pred (format-id #'k "~a?" base-name)] [litmaker (format-id #'k "~a" base-name)] [len (format-id #'k "~a-length" base-name)] [ref (format-id #'k "~a-ref" base-name)] [set (format-id #'k "~a-set!" base-name)] [->list (format-id #'k "~a->list" base-name)] [list-> (format-id #'k "list->~a" base-name)] [bytes (fxdiv bit-size 8)] [(bytevector-ref bytevector-set!) (case bit-size [(32) (list #'bytevector-ieee-single-native-ref #'bytevector-ieee-single-native-set!)] [(64) (list #'bytevector-ieee-double-native-ref #'bytevector-ieee-double-native-set!)])]) #'(begin (define check-val (lambda (who value) (unless (flonum? value) (error who (format "expected floating point value, but got ~s" value))))) (define-record-type (name maker pred) (nongenerative) (sealed #t) (opaque #t) (fields (immutable bv bv-accessor)) (protocol (lambda (new) (case-lambda [(size) (new (make-bytevector (fx* size bytes)))] [(size value) (check-val 'maker value) (let ([bv-size (fx* size bytes)]) (let ([bv (make-bytevector bv-size)]) (do ([i 0 (fx+ i bytes)]) ((fx=? i bv-size) (new bv)) (bytevector-set! bv i value))))])))) (define len (lambda (v) (fxdiv (bytevector-length (bv-accessor v)) bytes))) (define ref (lambda (v i) (bytevector-ref (bv-accessor v) (fx* i bytes)))) (define set (lambda (v i value) (check-val 'set! value) (bytevector-set! (bv-accessor v) (fx* i bytes) value))) (define ->list (lambda (v) (let ([bv (bv-accessor v)]) (let loop ([n (bytevector-length bv)] [ls '()]) (if (fx=? n 0) ls (let ([n (fx- n bytes)]) (loop n (cons (bytevector-ref bv n) ls)))))))) (define $list-> (lambda (who ls) (let f ([ls ls] [bv-bytes 0]) (if (null? ls) (maker (fxdiv bv-bytes bytes)) (let ([v (f (cdr ls) (fx+ bv-bytes bytes))] [val (car ls)]) (check-val who val) (bytevector-set! (bv-accessor v) bv-bytes val) v))))) (define list-> (lambda (ls) ($list-> 'list-> ls))) (define litmaker (lambda args ($list-> 'litmaker args)))))))]))) (define-float-vector 32) (define-float-vector 64)) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a41.sls000066400000000000000000000013701375154206600201630ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :41) (export define-stream list->stream port->stream stream stream->list stream-append stream-car stream-cdr stream-concat stream-cons stream-constant stream-drop stream-drop-while stream-filter stream-fold stream-for-each stream-from stream-iterate stream-lambda stream-length stream-let stream-map stream-match stream-null stream-null? stream-of stream-pair? stream-range stream-ref stream-reverse stream-scan stream-take stream-take-while stream-unfold stream-unfolds stream-zip stream?) (import (srfi :41 streams)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a41/000077500000000000000000000000001375154206600174375ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a41/streams.sls000066400000000000000000000034431375154206600216440ustar00rootroot00000000000000#!r6rs ;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation files ;;; (the "Software"), to deal in the Software without restriction, ;;; including without limitation the rights to use, copy, modify, merge, ;;; publish, distribute, sublicense, and/or sell copies of the Software, ;;; and to permit persons to whom the Software is furnished to do so, ;;; subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;;; SOFTWARE. (library (srfi :41 streams) (export stream-null stream-cons stream? stream-null? stream-pair? stream-car stream-cdr stream-lambda define-stream list->stream port->stream stream stream->list stream-append stream-concat stream-constant stream-drop stream-drop-while stream-filter stream-fold stream-for-each stream-from stream-iterate stream-length stream-let stream-map stream-match stream-of stream-range stream-ref stream-reverse stream-scan stream-take stream-take-while stream-unfold stream-unfolds stream-zip) (import (srfi :41 streams primitive) (srfi :41 streams derived))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a41/streams/000077500000000000000000000000001375154206600211155ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a41/streams/derived.sls000066400000000000000000000413161375154206600232670ustar00rootroot00000000000000#!r6rs ;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation files ;;; (the "Software"), to deal in the Software without restriction, ;;; including without limitation the rights to use, copy, modify, merge, ;;; publish, distribute, sublicense, and/or sell copies of the Software, ;;; and to permit persons to whom the Software is furnished to do so, ;;; subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;;; SOFTWARE. (library (srfi :41 streams derived) (export stream-null stream-cons stream? stream-null? stream-pair? stream-car stream-cdr stream-lambda define-stream list->stream port->stream stream stream->list stream-append stream-concat stream-constant stream-drop stream-drop-while stream-filter stream-fold stream-for-each stream-from stream-iterate stream-length stream-let stream-map stream-match stream-of stream-range stream-ref stream-reverse stream-scan stream-take stream-take-while stream-unfold stream-unfolds stream-zip) (import (rnrs) (srfi :41 streams primitive)) (define-syntax define-stream (syntax-rules () ((define-stream (name . formal) body0 body1 ...) (define name (stream-lambda formal body0 body1 ...))))) (define (list->stream objs) (define list->stream (stream-lambda (objs) (if (null? objs) stream-null (stream-cons (car objs) (list->stream (cdr objs)))))) (if (not (list? objs)) (error 'list->stream "non-list argument") (list->stream objs))) (define (port->stream . port) (define port->stream (stream-lambda (p) (let ((c (read-char p))) (if (eof-object? c) stream-null (stream-cons c (port->stream p)))))) (let ((p (if (null? port) (current-input-port) (car port)))) (if (not (input-port? p)) (error 'port->stream "non-input-port argument") (port->stream p)))) (define-syntax stream (syntax-rules () ((stream) stream-null) ((stream x y ...) (stream-cons x (stream y ...))))) (define (stream->list . args) (let ((n (if (= 1 (length args)) #f (car args))) (strm (if (= 1 (length args)) (car args) (cadr args)))) (cond ((not (stream? strm)) (error 'stream->list "non-stream argument")) ((and n (not (integer? n))) (error 'stream->list "non-integer count")) ((and n (negative? n)) (error 'stream->list "negative count")) (else (let loop ((n (if n n -1)) (strm strm)) (if (or (zero? n) (stream-null? strm)) '() (cons (stream-car strm) (loop (- n 1) (stream-cdr strm))))))))) (define (stream-append . strms) (define stream-append (stream-lambda (strms) (cond ((null? (cdr strms)) (car strms)) ((stream-null? (car strms)) (stream-append (cdr strms))) (else (stream-cons (stream-car (car strms)) (stream-append (cons (stream-cdr (car strms)) (cdr strms)))))))) (cond ((null? strms) stream-null) ((exists (lambda (x) (not (stream? x))) strms) (error 'stream-append "non-stream argument")) (else (stream-append strms)))) (define (stream-concat strms) (define stream-concat (stream-lambda (strms) (cond ((stream-null? strms) stream-null) ((not (stream? (stream-car strms))) (error 'stream-concat "non-stream object in input stream")) ((stream-null? (stream-car strms)) (stream-concat (stream-cdr strms))) (else (stream-cons (stream-car (stream-car strms)) (stream-concat (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms)))))))) (if (not (stream? strms)) (error 'stream-concat "non-stream argument") (stream-concat strms))) (define stream-constant (stream-lambda objs (cond ((null? objs) stream-null) ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs)))) (else (stream-cons (car objs) (apply stream-constant (append (cdr objs) (list (car objs))))))))) (define (stream-drop n strm) (define stream-drop (stream-lambda (n strm) (if (or (zero? n) (stream-null? strm)) strm (stream-drop (- n 1) (stream-cdr strm))))) (cond ((not (integer? n)) (error 'stream-drop "non-integer argument")) ((negative? n) (error 'stream-drop "negative argument")) ((not (stream? strm)) (error 'stream-drop "non-stream argument")) (else (stream-drop n strm)))) (define (stream-drop-while pred? strm) (define stream-drop-while (stream-lambda (strm) (if (and (stream-pair? strm) (pred? (stream-car strm))) (stream-drop-while (stream-cdr strm)) strm))) (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument")) ((not (stream? strm)) (error 'stream-drop-while "non-stream argument")) (else (stream-drop-while strm)))) (define (stream-filter pred? strm) (define stream-filter (stream-lambda (strm) (cond ((stream-null? strm) stream-null) ((pred? (stream-car strm)) (stream-cons (stream-car strm) (stream-filter (stream-cdr strm)))) (else (stream-filter (stream-cdr strm)))))) (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument")) ((not (stream? strm)) (error 'stream-filter "non-stream argument")) (else (stream-filter strm)))) (define (stream-fold proc base strm) (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument")) ((not (stream? strm)) (error 'stream-fold "non-stream argument")) (else (let loop ((base base) (strm strm)) (if (stream-null? strm) base (loop (proc base (stream-car strm)) (stream-cdr strm))))))) (define (stream-for-each proc . strms) (define (stream-for-each strms) (if (not (exists stream-null? strms)) (begin (apply proc (map stream-car strms)) (stream-for-each (map stream-cdr strms))))) (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument")) ((null? strms) (error 'stream-for-each "no stream arguments")) ((exists (lambda (x) (not (stream? x))) strms) (error 'stream-for-each "non-stream argument")) (else (stream-for-each strms)))) (define (stream-from first . step) (define stream-from (stream-lambda (first delta) (stream-cons first (stream-from (+ first delta) delta)))) (let ((delta (if (null? step) 1 (car step)))) (cond ((not (number? first)) (error 'stream-from "non-numeric starting number")) ((not (number? delta)) (error 'stream-from "non-numeric step size")) (else (stream-from first delta))))) (define (stream-iterate proc base) (define stream-iterate (stream-lambda (base) (stream-cons base (stream-iterate (proc base))))) (if (not (procedure? proc)) (error 'stream-iterate "non-procedural argument") (stream-iterate base))) (define (stream-length strm) (if (not (stream? strm)) (error 'stream-length "non-stream argument") (let loop ((len 0) (strm strm)) (if (stream-null? strm) len (loop (+ len 1) (stream-cdr strm)))))) (define-syntax stream-let (syntax-rules () ((stream-let tag ((name val) ...) body1 body2 ...) ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...)))) (define (stream-map proc . strms) (define stream-map (stream-lambda (strms) (if (exists stream-null? strms) stream-null (stream-cons (apply proc (map stream-car strms)) (stream-map (map stream-cdr strms)))))) (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument")) ((null? strms) (error 'stream-map "no stream arguments")) ((exists (lambda (x) (not (stream? x))) strms) (error 'stream-map "non-stream argument")) (else (stream-map strms)))) (define-syntax stream-match (syntax-rules () ((stream-match strm-expr clause ...) (let ((strm strm-expr)) (cond ((not (stream? strm)) (error 'stream-match "non-stream argument")) ((stream-match-test strm clause) => car) ... (else (error 'stream-match "pattern failure"))))))) (define-syntax stream-match-test (syntax-rules () ((stream-match-test strm (pattern fender expr)) (stream-match-pattern strm pattern () (and fender (list expr)))) ((stream-match-test strm (pattern expr)) (stream-match-pattern strm pattern () (list expr))))) (define-syntax stream-match-pattern (lambda (x) (define (wildcard? x) (and (identifier? x) (free-identifier=? x (syntax _)))) (syntax-case x () ((stream-match-pattern strm () (binding ...) body) (syntax (and (stream-null? strm) (let (binding ...) body)))) ((stream-match-pattern strm (w? . rest) (binding ...) body) (wildcard? #'w?) (syntax (and (stream-pair? strm) (let ((strm (stream-cdr strm))) (stream-match-pattern strm rest (binding ...) body))))) ((stream-match-pattern strm (var . rest) (binding ...) body) (syntax (and (stream-pair? strm) (let ((temp (stream-car strm)) (strm (stream-cdr strm))) (stream-match-pattern strm rest ((var temp) binding ...) body))))) ((stream-match-pattern strm w? (binding ...) body) (wildcard? #'w?) (syntax (let (binding ...) body))) ((stream-match-pattern strm var (binding ...) body) (syntax (let ((var strm) binding ...) body)))))) (define-syntax stream-of (syntax-rules () ((_ expr rest ...) (stream-of-aux expr stream-null rest ...)))) (define-syntax stream-of-aux (syntax-rules (in is) ((stream-of-aux expr base) (stream-cons expr base)) ((stream-of-aux expr base (var in stream) rest ...) (stream-let loop ((strm stream)) (if (stream-null? strm) base (let ((var (stream-car strm))) (stream-of-aux expr (loop (stream-cdr strm)) rest ...))))) ((stream-of-aux expr base (var is exp) rest ...) (let ((var exp)) (stream-of-aux expr base rest ...))) ((stream-of-aux expr base pred? rest ...) (if pred? (stream-of-aux expr base rest ...) base)))) (define (stream-range first past . step) (define stream-range (stream-lambda (first past delta lt?) (if (lt? first past) (stream-cons first (stream-range (+ first delta) past delta lt?)) stream-null))) (cond ((not (number? first)) (error 'stream-range "non-numeric starting number")) ((not (number? past)) (error 'stream-range "non-numeric ending number")) (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1)))) (if (not (number? delta)) (error 'stream-range "non-numeric step size") (let ((lt? (if (< 0 delta) < >))) (stream-range first past delta lt?))))))) (define (stream-ref strm n) (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument")) ((not (integer? n)) (error 'stream-ref "non-integer argument")) ((negative? n) (error 'stream-ref "negative argument")) (else (let loop ((strm strm) (n n)) (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream")) ((zero? n) (stream-car strm)) (else (loop (stream-cdr strm) (- n 1)))))))) (define (stream-reverse strm) (define stream-reverse (stream-lambda (strm rev) (if (stream-null? strm) rev (stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev))))) (if (not (stream? strm)) (error 'stream-reverse "non-stream argument") (stream-reverse strm stream-null))) (define (stream-scan proc base strm) (define stream-scan (stream-lambda (base strm) (if (stream-null? strm) (stream base) (stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm)))))) (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument")) ((not (stream? strm)) (error 'stream-scan "non-stream argument")) (else (stream-scan base strm)))) (define (stream-take n strm) (define stream-take (stream-lambda (n strm) (if (or (stream-null? strm) (zero? n)) stream-null (stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm)))))) (cond ((not (stream? strm)) (error 'stream-take "non-stream argument")) ((not (integer? n)) (error 'stream-take "non-integer argument")) ((negative? n) (error 'stream-take "negative argument")) (else (stream-take n strm)))) (define (stream-take-while pred? strm) (define stream-take-while (stream-lambda (strm) (cond ((stream-null? strm) stream-null) ((pred? (stream-car strm)) (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm)))) (else stream-null)))) (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument")) ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument")) (else (stream-take-while strm)))) (define (stream-unfold mapper pred? generator base) (define stream-unfold (stream-lambda (base) (if (pred? base) (stream-cons (mapper base) (stream-unfold (generator base))) stream-null))) (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper")) ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?")) ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator")) (else (stream-unfold base)))) (define (stream-unfolds gen seed) (define (len-values gen seed) (call-with-values (lambda () (gen seed)) (lambda vs (- (length vs) 1)))) (define unfold-result-stream (stream-lambda (gen seed) (call-with-values (lambda () (gen seed)) (lambda (next . results) (stream-cons results (unfold-result-stream gen next)))))) (define result-stream->output-stream (stream-lambda (result-stream i) (let ((result (list-ref (stream-car result-stream) (- i 1)))) (cond ((pair? result) (stream-cons (car result) (result-stream->output-stream (stream-cdr result-stream) i))) ((not result) (result-stream->output-stream (stream-cdr result-stream) i)) ((null? result) stream-null) (else (error 'stream-unfolds "can't happen")))))) (define (result-stream->output-streams result-stream) (let loop ((i (len-values gen seed)) (outputs '())) (if (zero? i) (apply values outputs) (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs))))) (if (not (procedure? gen)) (error 'stream-unfolds "non-procedural argument") (result-stream->output-streams (unfold-result-stream gen seed)))) (define (stream-zip . strms) (define stream-zip (stream-lambda (strms) (if (exists stream-null? strms) stream-null (stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms)))))) (cond ((null? strms) (error 'stream-zip "no stream arguments")) ((exists (lambda (x) (not (stream? x))) strms) (error 'stream-zip "non-stream argument")) (else (stream-zip strms))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a41/streams/primitive.sls000066400000000000000000000070101375154206600236460ustar00rootroot00000000000000#!r6rs ;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation files ;;; (the "Software"), to deal in the Software without restriction, ;;; including without limitation the rights to use, copy, modify, merge, ;;; publish, distribute, sublicense, and/or sell copies of the Software, ;;; and to permit persons to whom the Software is furnished to do so, ;;; subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;;; SOFTWARE. (library (srfi :41 streams primitive) (export stream-null stream-cons stream? stream-null? stream-pair? stream-car stream-cdr stream-lambda) (import (rnrs) (rnrs mutable-pairs)) (define-record-type (stream-type make-stream stream?) (fields (mutable box stream-promise stream-promise!))) (define-syntax stream-lazy (syntax-rules () ((lazy expr) (make-stream (cons 'lazy (lambda () expr)))))) (define (stream-eager expr) (make-stream (cons 'eager expr))) (define-syntax stream-delay (syntax-rules () ((stream-delay expr) (stream-lazy (stream-eager expr))))) (define (stream-force promise) (let ((content (stream-promise promise))) (case (car content) ((eager) (cdr content)) ((lazy) (let* ((promise* ((cdr content))) (content (stream-promise promise))) (if (not (eqv? (car content) 'eager)) (begin (set-car! content (car (stream-promise promise*))) (set-cdr! content (cdr (stream-promise promise*))) (stream-promise! promise* content))) (stream-force promise)))))) (define stream-null (stream-delay (cons 'stream 'null))) (define-record-type (stream-pare-type make-stream-pare stream-pare?) (fields (immutable kar stream-kar) (immutable kdr stream-kdr))) (define (stream-pair? obj) (and (stream? obj) (stream-pare? (stream-force obj)))) (define (stream-null? obj) (and (stream? obj) (eqv? (stream-force obj) (stream-force stream-null)))) (define-syntax stream-cons (syntax-rules () ((stream-cons obj strm) (stream-delay (make-stream-pare (stream-delay obj) (stream-lazy strm)))))) (define (stream-car strm) (cond ((not (stream? strm)) (error 'stream-car "non-stream")) ((stream-null? strm) (error 'stream-car "null stream")) (else (stream-force (stream-kar (stream-force strm)))))) (define (stream-cdr strm) (cond ((not (stream? strm)) (error 'stream-cdr "non-stream")) ((stream-null? strm) (error 'stream-cdr "null stream")) (else (stream-kdr (stream-force strm))))) (define-syntax stream-lambda (syntax-rules () ((stream-lambda formals body0 body1 ...) (lambda formals (stream-lazy (let () body0 body1 ...))))))) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a42.sls000066400000000000000000000012271375154206600201650ustar00rootroot00000000000000#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :42) (export : :-dispatch-ref :-dispatch-set! :char-range :dispatched :do :generator-proc :integers :let :list :parallel :port :range :real-range :string :until :vector :while any?-ec append-ec dispatch-union do-ec every?-ec first-ec fold-ec fold3-ec last-ec list-ec make-initial-:-dispatch max-ec min-ec product-ec string-append-ec string-ec sum-ec vector-ec vector-of-length-ec) (import (srfi :42 eager-comprehensions)) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a42/000077500000000000000000000000001375154206600174405ustar00rootroot00000000000000chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a42/eager-comprehensions.sls000066400000000000000000000020751375154206600243040ustar00rootroot00000000000000#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :42 eager-comprehensions) (export do-ec list-ec append-ec string-ec string-append-ec vector-ec vector-of-length-ec sum-ec product-ec min-ec max-ec any?-ec every?-ec first-ec last-ec fold-ec fold3-ec : :list :string :vector :integers :range :real-range :char-range :port :dispatched :do :let :parallel :while :until :-dispatch-ref :-dispatch-set! make-initial-:-dispatch dispatch-union :generator-proc) (import (except (rnrs) error) (rnrs r5rs) (srfi :39 parameters) (srfi :23 error) (for (srfi private vanish) expand) (srfi private include)) (define-syntax :-dispatch (identifier-syntax (_ (:-dispatch-param)) ((set! _ expr) (:-dispatch-param expr)))) (let-syntax ((define (vanish-define define (:-dispatch)))) (include/resolve ("srfi" "%3a42") "ec.scm")) (define :-dispatch-param (make-parameter (make-initial-:-dispatch))) ) chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a42/ec.scm000066400000000000000000001035261375154206600205420ustar00rootroot00000000000000; ; Eager Comprehensions in [outer..inner|expr]-Convention ; ====================================================== ; ; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007 ; Scheme R5RS (incl. macros), SRFI-23 (error). ; ; Loading the implementation into Scheme48 0.57: ; ,open srfi-23 ; ,load ec.scm ; ; Loading the implementation into PLT/DrScheme 317: ; ; File > Open ... "ec.scm", click Execute ; ; Loading the implementation into SCM 5d7: ; (require 'macro) (require 'record) ; (load "ec.scm") ; ; Implementation comments: ; * All local (not exported) identifiers are named ec-<something>. ; * This implementation focuses on portability, performance, ; readability, and simplicity roughly in this order. Design ; decisions related to performance are taken for Scheme48. ; * Alternative implementations, Comments and Warnings are ; mentioned after the definition with a heading. ; ========================================================================== ; The fundamental comprehension do-ec ; ========================================================================== ; ; All eager comprehensions are reduced into do-ec and ; all generators are reduced to :do. ; ; We use the following short names for syntactic variables ; q - qualifier ; cc - current continuation, thing to call at the end; ; the CPS is (m (cc ...) arg ...) -> (cc ... expr ...) ; cmd - an expression being evaluated for its side-effects ; expr - an expression ; gen - a generator of an eager comprehension ; ob - outer binding ; oc - outer command ; lb - loop binding ; ne1? - not-end1? (before the payload) ; ib - inner binding ; ic - inner command ; ne2? - not-end2? (after the payload) ; ls - loop step ; etc - more arguments of mixed type ; (do-ec q ... cmd) ; handles nested, if/not/and/or, begin, :let, and calls generator ; macros in CPS to transform them into fully decorated :do. ; The code generation for a :do is delegated to do-ec:do. (define-syntax do-ec (syntax-rules (nested if not and or begin :do let) ; explicit nesting -> implicit nesting ((do-ec (nested q ...) etc ...) (do-ec q ... etc ...) ) ; implicit nesting -> fold do-ec ((do-ec q1 q2 etc1 etc ...) (do-ec q1 (do-ec q2 etc1 etc ...)) ) ; no qualifiers at all -> evaluate cmd once ((do-ec cmd) (begin cmd (if #f #f)) ) ; now (do-ec q cmd) remains ; filter -> make conditional ((do-ec (if test) cmd) (if test (do-ec cmd)) ) ((do-ec (not test) cmd) (if (not test) (do-ec cmd)) ) ((do-ec (and test ...) cmd) (if (and test ...) (do-ec cmd)) ) ((do-ec (or test ...) cmd) (if (or test ...) (do-ec cmd)) ) ; begin -> make a sequence ((do-ec (begin etc ...) cmd) (begin etc ... (do-ec cmd)) ) ; fully decorated :do-generator -> delegate to do-ec:do ((do-ec (:do olet lbs ne1? ilet ne2? lss) cmd) (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) ) ; anything else -> call generator-macro in CPS; reentry at (*) ((do-ec (g arg1 arg ...) cmd) (g (do-ec:do cmd) arg1 arg ...) ))) ; (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) ; generates code for a single fully decorated :do-generator ; with cmd as payload, taking care of special cases. (define-syntax do-ec:do (syntax-rules (:do let) ; reentry point (*) -> generate code ((do-ec:do cmd (:do (let obs oc ...) lbs ne1? (let ibs ic ...) ne2? (ls ...) )) (ec-simplify (let obs oc ... (let loop lbs (ec-simplify (if ne1? (ec-simplify (let ibs ic ... cmd (ec-simplify (if ne2? (loop ls ...) )))))))))) )) ; (ec-simplify <expression>) ; generates potentially more efficient code for <expression>. ; The macro handles if, (begin <command>*), and (let () <command>*) ; and takes care of special cases. (define-syntax ec-simplify (syntax-rules (if not let begin) ; one- and two-sided if ; literal <test> ((ec-simplify (if #t consequent)) consequent ) ((ec-simplify (if #f consequent)) (if #f #f) ) ((ec-simplify (if #t consequent alternate)) consequent ) ((ec-simplify (if #f consequent alternate)) alternate ) ; (not (not <test>)) ((ec-simplify (if (not (not test)) consequent)) (ec-simplify (if test consequent)) ) ((ec-simplify (if (not (not test)) consequent alternate)) (ec-simplify (if test consequent alternate)) ) ; (let () <command>*) ; empty <binding spec>* ((ec-simplify (let () command ...)) (ec-simplify (begin command ...)) ) ; begin ; flatten use helper (ec-simplify 1 done to-do) ((ec-simplify (begin command ...)) (ec-simplify 1 () (command ...)) ) ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...)) (ec-simplify 1 done (to-do1 ... to-do2 ...)) ) ((ec-simplify 1 (done ...) (to-do1 to-do ...)) (ec-simplify 1 (done ... to-do1) (to-do ...)) ) ; exit helper ((ec-simplify 1 () ()) (if #f #f) ) ((ec-simplify 1 (command) ()) command ) ((ec-simplify 1 (command1 command ...) ()) (begin command1 command ...) ) ; anything else ((ec-simplify expression) expression ))) ; ========================================================================== ; The special generators :do, :let, :parallel, :while, and :until ; ========================================================================== (define-syntax :do (syntax-rules () ; full decorated -> continue with cc, reentry at (*) ((:do (cc ...) olet lbs ne1? ilet ne2? lss) (cc ... (:do olet lbs ne1? ilet ne2? lss)) ) ; short form -> fill in default values ((:do cc lbs ne1? lss) (:do cc (let ()) lbs ne1? (let ()) #t lss) ))) (define-syntax :let (syntax-rules (index) ((:let cc var (index i) expression) (:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) ) ((:let cc var expression) (:do cc (let ((var expression))) () #t (let ()) #f ()) ))) (define-syntax :parallel (syntax-rules (:do) ((:parallel cc) cc ) ((:parallel cc (g arg1 arg ...) gen ...) (g (:parallel-1 cc (gen ...)) arg1 arg ...) ))) ; (:parallel-1 cc (to-do ...) result [ next ] ) ; iterates over to-do by converting the first generator into ; the :do-generator next and merging next into result. (define-syntax :parallel-1 ; used as (syntax-rules (:do let) ; process next element of to-do, reentry at (**) ((:parallel-1 cc ((g arg1 arg ...) gen ...) result) (g (:parallel-1 cc (gen ...) result) arg1 arg ...) ) ; reentry point (**) -> merge next into result ((:parallel-1 cc gens (:do (let (ob1 ...) oc1 ...) (lb1 ...) ne1?1 (let (ib1 ...) ic1 ...) ne2?1 (ls1 ...) ) (:do (let (ob2 ...) oc2 ...) (lb2 ...) ne1?2 (let (ib2 ...) ic2 ...) ne2?2 (ls2 ...) )) (:parallel-1 cc gens (:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...) (lb1 ... lb2 ...) (and ne1?1 ne1?2) (let (ib1 ... ib2 ...) ic1 ... ic2 ...) (and ne2?1 ne2?2) (ls1 ... ls2 ...) ))) ; no more gens -> continue with cc, reentry at (*) ((:parallel-1 (cc ...) () result) (cc ... result) ))) (define-syntax :while (syntax-rules () ((:while cc (g arg1 arg ...) test) (g (:while-1 cc test) arg1 arg ...) ))) ; (:while-1 cc test (:do ...)) ; modifies the fully decorated :do-generator such that it ; runs while test is a true value. ; The original implementation just replaced ne1? by ; (and ne1? test) as follows: ; ; (define-syntax :while-1 ; (syntax-rules (:do) ; ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss)) ; (:do cc olet lbs (and ne1? test) ilet ne2? lss) ))) ; ; Bug #1: ; Unfortunately, this code is wrong because ne1? may depend ; in the inner bindings introduced in ilet, but ne1? is evaluated ; outside of the inner bindings. (Refer to the specification of ; :do to see the structure.) ; The problem manifests itself (as sunnan@handgranat.org ; observed, 25-Apr-2005) when the :list-generator is modified: ; ; (do-ec (:while (:list x '(1 2)) (= x 1)) (display x)). ; ; In order to generate proper code, we introduce temporary ; variables saving the values of the inner bindings. The inner ; bindings are executed in a new ne1?, which also evaluates ne1? ; outside the scope of the inner bindings, then the inner commands ; are executed (possibly changing the variables), and then the ; values of the inner bindings are saved and (and ne1? test) is ; returned. In the new ilet, the inner variables are bound and ; initialized and their values are restored. So we construct: ; ; (let (ob .. (ib-tmp #f) ...) ; oc ... ; (let loop (lb ...) ; (if (let (ne1?-value ne1?) ; (let ((ib-var ib-rhs) ...) ; ic ... ; (set! ib-tmp ib-var) ...) ; (and ne1?-value test)) ; (let ((ib-var ib-tmp) ...) ; /payload/ ; (if ne2? ; (loop ls ...) ))))) ; ; Bug #2: ; Unfortunately, the above expansion is still incorrect (as Jens-Axel ; Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even ; if ne1?-value is #f, indicating that the loop has ended. ; The problem manifests itself in the following example: ; ; (do-ec (:while (:list x '(1)) #t) (display x)) ; ; Which iterates :list beyond exhausting the list '(1). ; ; For the fix, we follow Jens-Axel's approach of guarding the evaluation ; of ib-rhs with a check on ne1?-value. (define-syntax :while-1 (syntax-rules (:do let) ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss)) (:while-2 cc test () () () (:do olet lbs ne1? ilet ne2? lss))))) (define-syntax :while-2 (syntax-rules (:do let) ((:while-2 cc test (ib-let ...) (ib-save ...) (ib-restore ...) (:do olet lbs ne1? (let ((ib-var ib-rhs) ib ...) ic ...) ne2? lss)) (:while-2 cc test (ib-let ... (ib-tmp #f)) (ib-save ... (ib-var ib-rhs)) (ib-restore ... (ib-var ib-tmp)) (:do olet lbs ne1? (let (ib ...) ic ... (set! ib-tmp ib-var)) ne2? lss))) ((:while-2 cc test (ib-let ...) (ib-save ...) (ib-restore ...) (:do (let (ob ...) oc ...) lbs ne1? (let () ic ...) ne2? lss)) (:do cc (let (ob ... ib-let ...) oc ...) lbs (let ((ne1?-value ne1?)) (and ne1?-value (let (ib-save ...) ic ... test))) (let (ib-restore ...)) ne2? lss)))) (define-syntax :until (syntax-rules () ((:until cc (g arg1 arg ...) test) (g (:until-1 cc test) arg1 arg ...) ))) (define-syntax :until-1 (syntax-rules (:do) ((:until-1 cc test (:do olet lbs ne1? ilet ne2? lss)) (:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) ))) ; ========================================================================== ; The typed generators :list :string :vector etc. ; ========================================================================== (define-syntax :list (syntax-rules (index) ((:list cc var (index i) arg ...) (:parallel cc (:list var arg ...) (:integers i)) ) ((:list cc var arg1 arg2 arg ...) (:list cc var (append arg1 arg2 arg ...)) ) ((:list cc var arg) (:do cc (let ()) ((t arg)) (not (null? t)) (let ((var (car t)))) #t ((cdr t)) )))) (define-syntax :string (syntax-rules (index) ((:string cc var (index i) arg) (:do cc (let ((str arg) (len 0)) (set! len (string-length str))) ((i 0)) (< i len) (let ((var (string-ref str i)))) #t ((+ i 1)) )) ((:string cc var (index i) arg1 arg2 arg ...) (:string cc var (index i) (string-append arg1 arg2 arg ...)) ) ((:string cc var arg1 arg ...) (:string cc var (index i) arg1 arg ...) ))) ; Alternative: An implementation in the style of :vector can also ; be used for :string. However, it is less interesting as the ; overhead of string-append is much less than for 'vector-append'. (define-syntax :vector (syntax-rules (index) ((:vector cc var arg) (:vector cc var (index i) arg) ) ((:vector cc var (index i) arg) (:do cc (let ((vec arg) (len 0)) (set! len (vector-length vec))) ((i 0)) (< i len) (let ((var (vector-ref vec i)))) #t ((+ i 1)) )) ((:vector cc var (index i) arg1 arg2 arg ...) (:parallel cc (:vector cc var arg1 arg2 arg ...) (:integers i)) ) ((:vector cc var arg1 arg2 arg ...) (:do cc (let ((vec #f) (len 0) (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) )) ((k 0)) (if (< k len) #t (if (null? vecs) #f (begin (set! vec (car vecs)) (set! vecs (cdr vecs)) (set! len (vector-length vec)) (set! k 0) #t ))) (let ((var (vector-ref vec k)))) #t ((+ k 1)) )))) (define (ec-:vector-filter vecs) (if (null? vecs) '() (if (zero? (vector-length (car vecs))) (ec-:vector-filter (cdr vecs)) (cons (car vecs) (ec-:vector-filter (cdr vecs))) ))) ; Alternative: A simpler implementation for :vector uses vector->list ; append and :list in the multi-argument case. Please refer to the ; 'design.scm' for more details. (define-syntax :integers (syntax-rules (index) ((:integers cc var (index i)) (:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) ) ((:integers cc var) (:do cc ((var 0)) #t ((+ var 1))) ))) (define-syntax :range (syntax-rules (index) ; handle index variable and add optional args ((:range cc var (index i) arg1 arg ...) (:parallel cc (:range var arg1 arg ...) (:integers i)) ) ((:range cc var arg1) (:range cc var 0 arg1 1) ) ((:range cc var arg1 arg2) (:range cc var arg1 arg2 1) ) ; special cases (partially evaluated by hand from general case) ((:range cc var 0 arg2 1) (:do cc (let ((b arg2)) (if (not (and (integer? b) (exact? b))) (error "arguments of :range are not exact integer " "(use :real-range?)" 0 b 1 ))) ((var 0)) (< var b) (let ()) #t ((+ var 1)) )) ((:range cc var 0 arg2 -1) (:do cc (let ((b arg2)) (if (not (and (integer? b) (exact? b))) (error "arguments of :range are not exact integer " "(use :real-range?)" 0 b 1 ))) ((var 0)) (> var b) (let ()) #t ((- var 1)) )) ((:range cc var arg1 arg2 1) (:do cc (let ((a arg1) (b arg2)) (if (not (and (integer? a) (exact? a) (integer? b) (exact? b) )) (error "arguments of :range are not exact integer " "(use :real-range?)" a b 1 )) ) ((var a)) (< var b) (let ()) #t ((+ var 1)) )) ((:range cc var arg1 arg2 -1) (:do cc (let ((a arg1) (b arg2) (s -1) (stop 0)) (if (not (and (integer? a) (exact? a) (integer? b) (exact? b) )) (error "arguments of :range are not exact integer " "(use :real-range?)" a b -1 )) ) ((var a)) (> var b) (let ()) #t ((- var 1)) )) ; the general case ((:range cc var arg1 arg2 arg3) (:do cc (let ((a arg1) (b arg2) (s arg3) (stop 0)) (if (not (and (integer? a) (exact? a) (integer? b) (exact? b) (integer? s) (exact? s) )) (error "arguments of :range are not exact integer " "(use :real-range?)" a b s )) (if (zero? s) (error "step size must not be zero in :range") ) (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) ) ((var a)) (not (= var stop)) (let ()) #t ((+ var s)) )))) ; Comment: The macro :range inserts some code to make sure the values ; are exact integers. This overhead has proven very helpful for ; saving users from themselves. (define-syntax :real-range (syntax-rules (index) ; add optional args and index variable ((:real-range cc var arg1) (:real-range cc var (index i) 0 arg1 1) ) ((:real-range cc var (index i) arg1) (:real-range cc var (index i) 0 arg1 1) ) ((:real-range cc var arg1 arg2) (:real-range cc var (index i) arg1 arg2 1) ) ((:real-range cc var (index i) arg1 arg2) (:real-range cc var (index i) arg1 arg2 1) ) ((:real-range cc var arg1 arg2 arg3) (:real-range cc var (index i) arg1 arg2 arg3) ) ; the fully qualified case ((:real-range cc var (index i) arg1 arg2 arg3) (:do cc (let ((a arg1) (b arg2) (s arg3) (istop 0)) (if (not (and (real? a) (real? b) (real? s))) (error "arguments of :real-range are not real" a b s) ) (if (and (exact? a) (or (not (exact? b)) (not (exact? s)))) (set! a (exact->inexact a)) ) (set! istop (/ (- b a) s)) ) ((i 0)) (< i istop) (let ((var (+ a (* s i))))) #t ((+ i 1)) )))) ; Comment: The macro :real-range adapts the exactness of the start ; value in case any of the other values is inexact. This is a ; precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0). (define-syntax :char-range (syntax-rules (index) ((:char-range cc var (index i) arg1 arg2) (:parallel cc (:char-range var arg1 arg2) (:integers i)) ) ((:char-range cc var arg1 arg2) (:do cc (let ((imax (char->integer arg2)))) ((i (char->integer arg1))) (<= i imax) (let ((var (integer->char i)))) #t ((+ i 1)) )))) ; Warning: There is no R5RS-way to implement the :char-range generator ; because the integers obtained by char->integer are not necessarily ; consecutive. We simply assume this anyhow for illustration. (define-syntax :port (syntax-rules (index) ((:port cc var (index i) arg1 arg ...) (:parallel cc (:port var arg1 arg ...) (:integers i)) ) ((:port cc var arg) (:port cc var arg read) ) ((:port cc var arg1 arg2) (:do cc (let ((port arg1) (read-proc arg2))) ((var (read-proc port))) (not (eof-object? var)) (let ()) #t ((read-proc port)) )))) ; ========================================================================== ; The typed generator :dispatched and utilities for constructing dispatchers ; ========================================================================== (define-syntax :dispatched (syntax-rules (index) ((:dispatched cc var (index i) dispatch arg1 arg ...) (:parallel cc (:integers i) (:dispatched var dispatch arg1 arg ...) )) ((:dispatched cc var dispatch arg1 arg ...) (:do cc (let ((d dispatch) (args (list arg1 arg ...)) (g #f) (empty (list #f)) ) (set! g (d args)) (if (not (procedure? g)) (error "unrecognized arguments in dispatching" args (d '()) ))) ((var (g empty))) (not (eq? var empty)) (let ()) #t ((g empty)) )))) ; Comment: The unique object empty is created as a newly allocated ; non-empty list. It is compared using eq? which distinguishes ; the object from any other object, according to R5RS 6.1. (define-syntax :generator-proc (syntax-rules (:do let) ; call g with a variable, reentry at (**) ((:generator-proc (g arg ...)) (g (:generator-proc var) var arg ...) ) ; reentry point (**) -> make the code from a single :do ((:generator-proc var (:do (let obs oc ...) ((lv li) ...) ne1? (let ((i v) ...) ic ...) ne2? (ls ...)) ) (ec-simplify (let obs oc ... (let ((lv li) ... (ne2 #t)) (ec-simplify (let ((i #f) ...) ; v not yet valid (lambda (empty) (if (and ne1? ne2) (ec-simplify (begin (set! i v) ... ic ... (let ((value var)) (ec-simplify (if ne2? (ec-simplify (begin (set! lv ls) ...) ) (set! ne2 #f) )) value ))) empty )))))))) ; silence warnings of some macro expanders ((:generator-proc var) (error "illegal macro call") ))) (define (dispatch-union d1 d2) (lambda (args) (let ((g1 (d1 args)) (g2 (d2 args))) (if g1 (if g2 (if (null? args) (append (if (list? g1) g1 (list g1)) (if (list? g2) g2 (list g2)) ) (error "dispatching conflict" args (d1 '()) (d2 '())) ) g1 ) (if g2 g2 #f) )))) ; ========================================================================== ; The dispatching generator : ; ========================================================================== (define (make-initial-:-dispatch) (lambda (args) (case (length args) ((0) 'SRFI42) ((1) (let ((a1 (car args))) (cond ((list? a1) (:generator-proc (:list a1)) ) ((string? a1) (:generator-proc (:string a1)) ) ((vector? a1) (:generator-proc (:vector a1)) ) ((and (integer? a1) (exact? a1)) (:generator-proc (:range a1)) ) ((real? a1) (:generator-proc (:real-range a1)) ) ((input-port? a1) (:generator-proc (:port a1)) ) (else #f )))) ((2) (let ((a1 (car args)) (a2 (cadr args))) (cond ((and (list? a1) (list? a2)) (:generator-proc (:list a1 a2)) ) ((and (string? a1) (string? a2)) (:generator-proc (:string a1 a2)) ) ((and (vector? a1) (vector? a2)) (:generator-proc (:vector a1 a2)) ) ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2)) (:generator-proc (:range a1 a2)) ) ((and (real? a1) (real? a2)) (:generator-proc (:real-range a1 a2)) ) ((and (char? a1) (char? a2)) (:generator-proc (:char-range a1 a2)) ) ((and (input-port? a1) (procedure? a2)) (:generator-proc (:port a1 a2)) ) (else #f )))) ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args))) (cond ((and (list? a1) (list? a2) (list? a3)) (:generator-proc (:list a1 a2 a3)) ) ((and (string? a1) (string? a2) (string? a3)) (:generator-proc (:string a1 a2 a3)) ) ((and (vector? a1) (vector? a2) (vector? a3)) (:generator-proc (:vector a1 a2 a3)) ) ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2) (integer? a3) (exact? a3)) (:generator-proc (:range a1 a2 a3)) ) ((and (real? a1) (real? a2) (real? a3)) (:generator-proc (:real-range a1 a2 a3)) ) (else #f )))) (else (letrec ((every? (lambda (pred args) (if (null? args) #t (and (pred (car args)) (every? pred (cdr args)) ))))) (cond ((every? list? args) (:generator-proc (:list (apply append args))) ) ((every? string? args) (:generator-proc (:string (apply string-append args))) ) ((every? vector? args) (:generator-proc (:list (apply append (map vector->list args)))) ) (else #f ))))))) (define :-dispatch (make-initial-:-dispatch) ) (define (:-dispatch-ref) :-dispatch ) (define (:-dispatch-set! dispatch) (if (not (procedure? dispatch)) (error "not a procedure" dispatch) ) (set! :-dispatch dispatch) ) (define-syntax : (syntax-rules (index) ((: cc var (index i) arg1 arg ...) (:dispatched cc var (index i) :-dispatch arg1 arg ...) ) ((: cc var arg1 arg ...) (:dispatched cc var :-dispatch arg1 arg ...) ))) ; ========================================================================== ; The utility comprehensions fold-ec, fold3-ec ; ========================================================================== (define-syntax fold3-ec (syntax-rules (nested) ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...) (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) ) ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...) (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) ) ((fold3-ec x0 expression f1 f2) (fold3-ec x0 (nested) expression f1 f2) ) ((fold3-ec x0 qualifier expression f1 f2) (let ((result #f) (empty #t)) (do-ec qualifier (let ((value expression)) ; don't duplicate (if empty (begin (set! result (f1 value)) (set! empty #f) ) (set! result (f2 value result)) ))) (if empty x0 result) )))) (define-syntax fold-ec (syntax-rules (nested) ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...) (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) ) ((fold-ec x0 q1 q2 etc1 etc2 etc ...) (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) ) ((fold-ec x0 expression f2) (fold-ec x0 (nested) expression f2) ) ((fold-ec x0 qualifier expression f2) (let ((result x0)) (do-ec qualifier (set! result (f2 expression result))) result )))) ; ========================================================================== ; The comprehensions list-ec string-ec vector-ec etc. ; ========================================================================== (define-syntax list-ec (syntax-rules () ((list-ec etc1 etc ...) (reverse (fold-ec '() etc1 etc ... cons)) ))) ; Alternative: Reverse can safely be replaced by reverse! if you have it. ; ; Alternative: It is possible to construct the result in the correct order ; using set-cdr! to add at the tail. This removes the overhead of copying ; at the end, at the cost of more book-keeping. (define-syntax append-ec (syntax-rules () ((append-ec etc1 etc ...) (apply append (list-ec etc1 etc ...)) ))) (define-syntax string-ec (syntax-rules () ((string-ec etc1 etc ...) (list->string (list-ec etc1 etc ...)) ))) ; Alternative: For very long strings, the intermediate list may be a ; problem. A more space-aware implementation collect the characters ; in an intermediate list and when this list becomes too large it is ; converted into an intermediate string. At the end, the intermediate ; strings are concatenated with string-append. (define-syntax string-append-ec (syntax-rules () ((string-append-ec etc1 etc ...) (apply string-append (list-ec etc1 etc ...)) ))) (define-syntax vector-ec (syntax-rules () ((vector-ec etc1 etc ...) (list->vector (list-ec etc1 etc ...)) ))) ; Comment: A similar approach as for string-ec can be used for vector-ec. ; However, the space overhead for the intermediate list is much lower ; than for string-ec and as there is no vector-append, the intermediate ; vectors must be copied explicitly. (define-syntax vector-of-length-ec (syntax-rules (nested) ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...) (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) ) ((vector-of-length-ec k q1 q2 etc1 etc ...) (vector-of-length-ec k (nested q1 q2) etc1 etc ...) ) ((vector-of-length-ec k expression) (vector-of-length-ec k (nested) expression) ) ((vector-of-length-ec k qualifier expression) (let ((len k)) (let ((vec (make-vector len)) (i 0) ) (do-ec qualifier (if (< i len) (begin (vector-set! vec i expression) (set! i (+ i 1)) ) (error "vector is too short for the comprehension") )) (if (= i len) vec (error "vector is too long for the comprehension") )))))) (define-syntax sum-ec (syntax-rules () ((sum-ec etc1 etc ...) (fold-ec (+) etc1 etc ... +) ))) (define-syntax product-ec (syntax-rules () ((product-ec etc1 etc ...) (fold-ec (*) etc1 etc ... *) ))) (define-syntax min-ec (syntax-rules () ((min-ec etc1 etc ...) (fold3-ec (min) etc1 etc ... min min) ))) (define-syntax max-ec (syntax-rules () ((max-ec etc1 etc ...) (fold3-ec (max) etc1 etc ... max max) ))) (define-syntax last-ec (syntax-rules (nested) ((last-ec default (nested q1 ...) q etc1 etc ...) (last-ec default (nested q1 ... q) etc1 etc ...) ) ((last-ec default q1 q2 etc1 etc ...) (last-ec default (nested q1 q2) etc1 etc ...) ) ((last-ec default expression) (last-ec default (nested) expression) ) ((last-ec default qualifier expression) (let ((result default)) (do-ec qualifier (set! result expression)) result )))) ; ========================================================================== ; The fundamental early-stopping comprehension first-ec ; ========================================================================== (define-syntax first-ec (syntax-rules (nested) ((first-ec default (nested q1 ...) q etc1 etc ...) (first-ec default (nested q1 ... q) etc1 etc ...) ) ((first-ec default q1 q2 etc1 etc ...) (first-ec default (nested q1 q2) etc1 etc ...) ) ((first-ec default expression) (first-ec default (nested) expression) ) ((first-ec default qualifier expression) (let ((result default) (stop #f)) (ec-guarded-do-ec stop (nested qualifier) (begin (set! result expression) (set! stop #t) )) result )))) ; (ec-guarded-do-ec stop (nested q ...) cmd) ; constructs (do-ec q ... cmd) where the generators gen in q ... are ; replaced by (:until gen stop). (define-syntax ec-guarded-do-ec (syntax-rules (nested if not and or begin) ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd) (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) ) ((ec-guarded-do-ec stop (nested (if test) q ...) cmd) (if test (ec-guarded-do-ec stop (nested q ...) cmd)) ) ((ec-guarded-do-ec stop (nested (not test) q ...) cmd) (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) ) ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd) (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) ) ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd) (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) ) ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd) (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) ) ((ec-guarded-do-ec stop (nested gen q ...) cmd) (do-ec (:until gen stop) (ec-guarded-do-ec stop (nested q ...) cmd) )) ((ec-guarded-do-ec stop (nested) cmd) (do-ec cmd) ))) ; Alternative: Instead of modifying the generator with :until, it is ; possible to use call-with-current-continuation: ; ; (define-synatx first-ec ; ...same as above... ; ((first-ec default qualifier expression) ; (call-with-current-continuation ; (lambda (cc) ; (do-ec qualifier (cc expression)) ; default ))) )) ; ; This is much simpler but not necessarily as efficient. ; ========================================================================== ; The early-stopping comprehensions any?-ec every?-ec ; ========================================================================== (define-syntax any?-ec (syntax-rules (nested) ((any?-ec (nested q1 ...) q etc1 etc ...) (any?-ec (nested q1 ... q) etc1 etc ...) ) ((any?-ec q1 q2 etc1 etc ...) (any?-ec (nested q1 q2) etc1 etc ...) ) ((any?-ec expression) (any?-ec (nested) expression) ) ((any?-ec qualifier expression) (first-ec #f qualifier (if expression) #t) ))) (define-syntax every?-ec (syntax-rules (nested) ((every?-ec (nested q1 ...) q etc1 etc ...) (every?-ec (nested q1 ... q) etc1 etc ...) ) ((every?-ec q1 q2 etc1 etc ...) (every?-ec (nested q1 q2) etc1 etc ...) ) ((every?-ec expression) (every?-ec (nested) expression) ) ((every?-ec qualifier expression) (first-ec #t qualifier (if (not expression)) #f) ))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a42/examples.scm�������������������������������������������0000664�0000000�0000000�00000046646�13751542066�0022002�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������; <PLAINTEXT> ; Examples for Eager Comprehensions in [outer..inner|expr]-Convention ; =================================================================== ; ; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007. ; Scheme R5RS (incl. macros), SRFI-23 (error). ; ; Running the examples in Scheme48 (version 1.1): ; ,open srfi-23 ; ,load ec.scm ; (define my-open-output-file open-output-file) ; (define my-call-with-input-file call-with-input-file) ; ,load examples.scm ; ; Running the examples in PLT/DrScheme (version 317): ; (load "ec.scm") ; (define (my-open-output-file filename) ; (open-output-file filename 'replace 'text) ) ; (define (my-call-with-input-file filename thunk) ; (call-with-input-file filename thunk 'text) ) ; (load "examples.scm") ; ; Running the examples in SCM (version 5d7): ; (require 'macro) (require 'record) ; (load "ec.scm") ; (define my-open-output-file open-output-file) ; (define my-call-with-input-file call-with-input-file) ; (load "examples.scm") ; Tools for checking results ; ========================== (define (my-equal? x y) (cond ((or (boolean? x) (null? x) (symbol? x) (char? x) (input-port? x) (output-port? x) ) (eqv? x y) ) ((string? x) (and (string? y) (string=? x y)) ) ((vector? x) (and (vector? y) (my-equal? (vector->list x) (vector->list y)) )) ((pair? x) (and (pair? y) (my-equal? (car x) (car y)) (my-equal? (cdr x) (cdr y)) )) ((real? x) (and (real? y) (eqv? (exact? x) (exact? y)) (if (exact? x) (= x y) (< (abs (- x y)) (/ 1 (expt 10 6))) ))) ; will do here (else (error "unrecognized type" x) ))) (define my-check-correct 0) (define my-check-wrong 0) (define-syntax my-check (syntax-rules (=>) ((my-check ec => desired-result) (begin (newline) (write (quote ec)) (newline) (let ((actual-result ec)) (display " => ") (write actual-result) (if (my-equal? actual-result desired-result) (begin (display " ; correct") (set! my-check-correct (+ my-check-correct 1)) ) (begin (display " ; *** wrong ***, desired result:") (newline) (display " => ") (write desired-result) (set! my-check-wrong (+ my-check-wrong 1)) )) (newline) ))))) ; ========================================================================== ; do-ec ; ========================================================================== (my-check (let ((x 0)) (do-ec (set! x (+ x 1))) x) => 1) (my-check (let ((x 0)) (do-ec (:range i 10) (set! x (+ x 1))) x) => 10) (my-check (let ((x 0)) (do-ec (:range n 10) (:range k n) (set! x (+ x 1))) x) => 45) ; ========================================================================== ; list-ec and basic qualifiers ; ========================================================================== (my-check (list-ec 1) => '(1)) (my-check (list-ec (:range i 4) i) => '(0 1 2 3)) (my-check (list-ec (:range n 3) (:range k (+ n 1)) (list n k)) => '((0 0) (1 0) (1 1) (2 0) (2 1) (2 2)) ) (my-check (list-ec (:range n 5) (if (even? n)) (:range k (+ n 1)) (list n k)) => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) ) (my-check (list-ec (:range n 5) (not (even? n)) (:range k (+ n 1)) (list n k)) => '((1 0) (1 1) (3 0) (3 1) (3 2) (3 3)) ) (my-check (list-ec (:range n 5) (and (even? n) (> n 2)) (:range k (+ n 1)) (list n k) ) => '((4 0) (4 1) (4 2) (4 3) (4 4)) ) (my-check (list-ec (:range n 5) (or (even? n) (> n 3)) (:range k (+ n 1)) (list n k) ) => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) ) (my-check (let ((x 0)) (list-ec (:range n 10) (begin (set! x (+ x 1))) n) x) => 10 ) (my-check (list-ec (nested (:range n 3) (:range k n)) k) => '(0 0 1) ) ; ========================================================================== ; Other comprehensions ; ========================================================================== (my-check (append-ec '(a b)) => '(a b)) (my-check (append-ec (:range i 0) '(a b)) => '()) (my-check (append-ec (:range i 1) '(a b)) => '(a b)) (my-check (append-ec (:range i 2) '(a b)) => '(a b a b)) (my-check (string-ec #\a) => (string #\a)) (my-check (string-ec (:range i 0) #\a) => "") (my-check (string-ec (:range i 1) #\a) => "a") (my-check (string-ec (:range i 2) #\a) => "aa") (my-check (string-append-ec "ab") => "ab") (my-check (string-append-ec (:range i 0) "ab") => "") (my-check (string-append-ec (:range i 1) "ab") => "ab") (my-check (string-append-ec (:range i 2) "ab") => "abab") (my-check (vector-ec 1) => (vector 1)) (my-check (vector-ec (:range i 0) i) => (vector)) (my-check (vector-ec (:range i 1) i) => (vector 0)) (my-check (vector-ec (:range i 2) i) => (vector 0 1)) (my-check (vector-of-length-ec 1 1) => (vector 1)) (my-check (vector-of-length-ec 0 (:range i 0) i) => (vector)) (my-check (vector-of-length-ec 1 (:range i 1) i) => (vector 0)) (my-check (vector-of-length-ec 2 (:range i 2) i) => (vector 0 1)) (my-check (sum-ec 1) => 1) (my-check (sum-ec (:range i 0) i) => 0) (my-check (sum-ec (:range i 1) i) => 0) (my-check (sum-ec (:range i 2) i) => 1) (my-check (sum-ec (:range i 3) i) => 3) (my-check (product-ec 1) => 1) (my-check (product-ec (:range i 1 0) i) => 1) (my-check (product-ec (:range i 1 1) i) => 1) (my-check (product-ec (:range i 1 2) i) => 1) (my-check (product-ec (:range i 1 3) i) => 2) (my-check (product-ec (:range i 1 4) i) => 6) (my-check (min-ec 1) => 1) (my-check (min-ec (:range i 1) i) => 0) (my-check (min-ec (:range i 2) i) => 0) (my-check (max-ec 1) => 1) (my-check (max-ec (:range i 1) i) => 0) (my-check (max-ec (:range i 2) i) => 1) (my-check (first-ec #f 1) => 1) (my-check (first-ec #f (:range i 0) i) => #f) (my-check (first-ec #f (:range i 1) i) => 0) (my-check (first-ec #f (:range i 2) i) => 0) (my-check (let ((last-i -1)) (first-ec #f (:range i 10) (begin (set! last-i i)) i) last-i ) => 0 ) (my-check (last-ec #f 1) => 1) (my-check (last-ec #f (:range i 0) i) => #f) (my-check (last-ec #f (:range i 1) i) => 0) (my-check (last-ec #f (:range i 2) i) => 1) (my-check (any?-ec #f) => #f) (my-check (any?-ec #t) => #t) (my-check (any?-ec (:range i 2 2) (even? i)) => #f) (my-check (any?-ec (:range i 2 3) (even? i)) => #t) (my-check (every?-ec #f) => #f) (my-check (every?-ec #t) => #t) (my-check (every?-ec (:range i 2 2) (even? i)) => #t) (my-check (every?-ec (:range i 2 3) (even? i)) => #t) (my-check (every?-ec (:range i 2 4) (even? i)) => #f) (my-check (let ((sum-sqr (lambda (x result) (+ result (* x x))))) (fold-ec 0 (:range i 10) i sum-sqr) ) => 285 ) (my-check (let ((minus-1 (lambda (x) (- x 1))) (sum-sqr (lambda (x result) (+ result (* x x))))) (fold3-ec (error "wrong") (:range i 10) i minus-1 sum-sqr) ) => 284 ) (my-check (fold3-ec 'infinity (:range i 0) i min min) => 'infinity ) ; ========================================================================== ; Typed generators ; ========================================================================== (my-check (list-ec (:list x '()) x) => '()) (my-check (list-ec (:list x '(1)) x) => '(1)) (my-check (list-ec (:list x '(1 2 3)) x) => '(1 2 3)) (my-check (list-ec (:list x '(1) '(2)) x) => '(1 2)) (my-check (list-ec (:list x '(1) '(2) '(3)) x) => '(1 2 3)) (my-check (list-ec (:string c "") c) => '()) (my-check (list-ec (:string c "1") c) => '(#\1)) (my-check (list-ec (:string c "123") c) => '(#\1 #\2 #\3)) (my-check (list-ec (:string c "1" "2") c) => '(#\1 #\2)) (my-check (list-ec (:string c "1" "2" "3") c) => '(#\1 #\2 #\3)) (my-check (list-ec (:vector x (vector)) x) => '()) (my-check (list-ec (:vector x (vector 1)) x) => '(1)) (my-check (list-ec (:vector x (vector 1 2 3)) x) => '(1 2 3)) (my-check (list-ec (:vector x (vector 1) (vector 2)) x) => '(1 2)) (my-check (list-ec (:vector x (vector 1) (vector 2) (vector 3)) x) => '(1 2 3)) (my-check (list-ec (:range x -2) x) => '()) (my-check (list-ec (:range x -1) x) => '()) (my-check (list-ec (:range x 0) x) => '()) (my-check (list-ec (:range x 1) x) => '(0)) (my-check (list-ec (:range x 2) x) => '(0 1)) (my-check (list-ec (:range x 0 3) x) => '(0 1 2)) (my-check (list-ec (:range x 1 3) x) => '(1 2)) (my-check (list-ec (:range x -2 -1) x) => '(-2)) (my-check (list-ec (:range x -2 -2) x) => '()) (my-check (list-ec (:range x 1 5 2) x) => '(1 3)) (my-check (list-ec (:range x 1 6 2) x) => '(1 3 5)) (my-check (list-ec (:range x 5 1 -2) x) => '(5 3)) (my-check (list-ec (:range x 6 1 -2) x) => '(6 4 2)) (my-check (list-ec (:real-range x 0.0 3.0) x) => '(0. 1. 2.)) (my-check (list-ec (:real-range x 0 3.0) x) => '(0. 1. 2.)) (my-check (list-ec (:real-range x 0 3 1.0) x) => '(0. 1. 2.)) (my-check (string-ec (:char-range c #\a #\z) c) => "abcdefghijklmnopqrstuvwxyz" ) (my-check (begin (let ((f (my-open-output-file "tmp1"))) (do-ec (:range n 10) (begin (write n f) (newline f))) (close-output-port f)) (my-call-with-input-file "tmp1" (lambda (port) (list-ec (:port x port read) x)) )) => (list-ec (:range n 10) n) ) (my-check (begin (let ((f (my-open-output-file "tmp1"))) (do-ec (:range n 10) (begin (write n f) (newline f))) (close-output-port f)) (my-call-with-input-file "tmp1" (lambda (port) (list-ec (:port x port) x)) )) => (list-ec (:range n 10) n) ) ; ========================================================================== ; The special generators :do :let :parallel :while :until ; ========================================================================== (my-check (list-ec (:do ((i 0)) (< i 4) ((+ i 1))) i) => '(0 1 2 3)) (my-check (list-ec (:do (let ((x 'x))) ((i 0)) (< i 4) (let ((j (- 10 i)))) #t ((+ i 1)) ) j ) => '(10 9 8 7) ) (my-check (list-ec (:let x 1) x) => '(1)) (my-check (list-ec (:let x 1) (:let y (+ x 1)) y) => '(2)) (my-check (list-ec (:let x 1) (:let x (+ x 1)) x) => '(2)) (my-check (list-ec (:parallel (:range i 1 10) (:list x '(a b c))) (list i x)) => '((1 a) (2 b) (3 c)) ) (my-check (list-ec (:while (:range i 1 10) (< i 5)) i) => '(1 2 3 4) ) (my-check (list-ec (:until (:range i 1 10) (>= i 5)) i) => '(1 2 3 4 5) ) ; with generator that might use inner bindings (my-check (list-ec (:while (:list i '(1 2 3 4 5 6 7 8 9)) (< i 5)) i) => '(1 2 3 4) ) ; Was broken in original reference implementation as pointed ; out by sunnan@handgranat.org on 24-Apr-2005 comp.lang.scheme. ; Refer to http://groups-beta.google.com/group/comp.lang.scheme/ ; browse_thread/thread/f5333220eaeeed66/75926634cf31c038#75926634cf31c038 (my-check (list-ec (:until (:list i '(1 2 3 4 5 6 7 8 9)) (>= i 5)) i) => '(1 2 3 4 5) ) (my-check (list-ec (:while (:vector x (index i) '#(1 2 3 4 5)) (< x 10)) x) => '(1 2 3 4 5)) ; Was broken in reference implementation, even after fix for the ; bug reported by Sunnan, as reported by Jens-Axel Soegaard on ; 4-Jun-2007. ; combine :while/:until and :parallel (my-check (list-ec (:while (:parallel (:range i 1 10) (:list j '(1 2 3 4 5 6 7 8 9))) (< i 5)) (list i j)) => '((1 1) (2 2) (3 3) (4 4))) (my-check (list-ec (:until (:parallel (:range i 1 10) (:list j '(1 2 3 4 5 6 7 8 9))) (>= i 5)) (list i j)) => '((1 1) (2 2) (3 3) (4 4) (5 5))) ; check that :while/:until really stop the generator (my-check (let ((n 0)) (do-ec (:while (:range i 1 10) (begin (set! n (+ n 1)) (< i 5))) (if #f #f)) n) => 5) (my-check (let ((n 0)) (do-ec (:until (:range i 1 10) (begin (set! n (+ n 1)) (>= i 5))) (if #f #f)) n) => 5) (my-check (let ((n 0)) (do-ec (:while (:parallel (:range i 1 10) (:do () (begin (set! n (+ n 1)) #t) ())) (< i 5)) (if #f #f)) n) => 5) (my-check (let ((n 0)) (do-ec (:until (:parallel (:range i 1 10) (:do () (begin (set! n (+ n 1)) #t) ())) (>= i 5)) (if #f #f)) n) => 5) ; ========================================================================== ; The dispatching generator ; ========================================================================== (my-check (list-ec (: c '(a b)) c) => '(a b)) (my-check (list-ec (: c '(a b) '(c d)) c) => '(a b c d)) (my-check (list-ec (: c "ab") c) => '(#\a #\b)) (my-check (list-ec (: c "ab" "cd") c) => '(#\a #\b #\c #\d)) (my-check (list-ec (: c (vector 'a 'b)) c) => '(a b)) (my-check (list-ec (: c (vector 'a 'b) (vector 'c)) c) => '(a b c)) (my-check (list-ec (: i 0) i) => '()) (my-check (list-ec (: i 1) i) => '(0)) (my-check (list-ec (: i 10) i) => '(0 1 2 3 4 5 6 7 8 9)) (my-check (list-ec (: i 1 2) i) => '(1)) (my-check (list-ec (: i 1 2 3) i) => '(1)) (my-check (list-ec (: i 1 9 3) i) => '(1 4 7)) (my-check (list-ec (: i 0.0 1.0 0.2) i) => '(0. 0.2 0.4 0.6 0.8)) (my-check (list-ec (: c #\a #\c) c) => '(#\a #\b #\c)) (my-check (begin (let ((f (my-open-output-file "tmp1"))) (do-ec (:range n 10) (begin (write n f) (newline f))) (close-output-port f)) (my-call-with-input-file "tmp1" (lambda (port) (list-ec (: x port read) x)) )) => (list-ec (:range n 10) n) ) (my-check (begin (let ((f (my-open-output-file "tmp1"))) (do-ec (:range n 10) (begin (write n f) (newline f))) (close-output-port f)) (my-call-with-input-file "tmp1" (lambda (port) (list-ec (: x port) x)) )) => (list-ec (:range n 10) n) ) ; ========================================================================== ; With index variable ; ========================================================================== (my-check (list-ec (:list c (index i) '(a b)) (list c i)) => '((a 0) (b 1))) (my-check (list-ec (:string c (index i) "a") (list c i)) => '((#\a 0))) (my-check (list-ec (:vector c (index i) (vector 'a)) (list c i)) => '((a 0))) (my-check (list-ec (:range i (index j) 0 -3 -1) (list i j)) => '((0 0) (-1 1) (-2 2)) ) (my-check (list-ec (:real-range i (index j) 0 1 0.2) (list i j)) => '((0. 0) (0.2 1) (0.4 2) (0.6 3) (0.8 4)) ) (my-check (list-ec (:char-range c (index i) #\a #\c) (list c i)) => '((#\a 0) (#\b 1) (#\c 2)) ) (my-check (list-ec (: x (index i) '(a b c d)) (list x i)) => '((a 0) (b 1) (c 2) (d 3)) ) (my-check (begin (let ((f (my-open-output-file "tmp1"))) (do-ec (:range n 10) (begin (write n f) (newline f))) (close-output-port f)) (my-call-with-input-file "tmp1" (lambda (port) (list-ec (: x (index i) port) (list x i))) )) => '((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9)) ) ; ========================================================================== ; The examples from the SRFI document ; ========================================================================== ; from Abstract (my-check (list-ec (: i 5) (* i i)) => '(0 1 4 9 16)) (my-check (list-ec (: n 1 4) (: i n) (list n i)) => '((1 0) (2 0) (2 1) (3 0) (3 1) (3 2)) ) ; from Generators (my-check (list-ec (: x (index i) "abc") (list x i)) => '((#\a 0) (#\b 1) (#\c 2)) ) (my-check (list-ec (:string c (index i) "a" "b") (cons c i)) => '((#\a . 0) (#\b . 1)) ) ; ========================================================================== ; Little Shop of Horrors ; ========================================================================== (my-check (list-ec (:range x 5) (:range x x) x) => '(0 0 1 0 1 2 0 1 2 3)) (my-check (list-ec (:list x '(2 "23" (4))) (: y x) y) => '(0 1 #\2 #\3 4)) (my-check (list-ec (:parallel (:integers x) (:do ((i 10)) (< x i) ((- i 1)))) (list x i)) => '((0 10) (1 9) (2 8) (3 7) (4 6)) ) ; ========================================================================== ; Less artificial examples ; ========================================================================== (define (factorial n) ; n * (n-1) * .. * 1 for n >= 0 (product-ec (:range k 2 (+ n 1)) k) ) (my-check (factorial 0) => 1) (my-check (factorial 1) => 1) (my-check (factorial 3) => 6) (my-check (factorial 5) => 120) (define (eratosthenes n) ; primes in {2..n-1} for n >= 1 (let ((p? (make-string n #\1))) (do-ec (:range k 2 n) (if (char=? (string-ref p? k) #\1)) (:range i (* 2 k) n k) (string-set! p? i #\0) ) (list-ec (:range k 2 n) (if (char=? (string-ref p? k) #\1)) k) )) (my-check (eratosthenes 50) => '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47) ) (my-check (length (eratosthenes 100000)) => 9592 ) ; we expect 10^5/ln(10^5) (define (pythagoras n) ; a, b, c s.t. 1 <= a <= b <= c <= n, a^2 + b^2 = c^2 (list-ec (:let sqr-n (* n n)) (:range a 1 (+ n 1)) ; (begin (display a) (display " ")) (:let sqr-a (* a a)) (:range b a (+ n 1)) (:let sqr-c (+ sqr-a (* b b))) (if (<= sqr-c sqr-n)) (:range c b (+ n 1)) (if (= (* c c) sqr-c)) (list a b c) )) (my-check (pythagoras 15) => '((3 4 5) (5 12 13) (6 8 10) (9 12 15)) ) (my-check (length (pythagoras 200)) => 127 ) (define (qsort xs) ; stable (if (null? xs) '() (let ((pivot (car xs)) (xrest (cdr xs))) (append (qsort (list-ec (:list x xrest) (if (< x pivot)) x)) (list pivot) (qsort (list-ec (:list x xrest) (if (>= x pivot)) x)) )))) (my-check (qsort '(1 5 4 2 4 5 3 2 1 3)) => '(1 1 2 2 3 3 4 4 5 5) ) (define (pi-BBP m) ; approx. of pi within 16^-m (Bailey-Borwein-Plouffe) (sum-ec (:range n 0 (+ m 1)) (:let n8 (* 8 n)) (* (- (/ 4 (+ n8 1)) (+ (/ 2 (+ n8 4)) (/ 1 (+ n8 5)) (/ 1 (+ n8 6)))) (/ 1 (expt 16 n)) ))) (my-check (pi-BBP 5) => (/ 40413742330349316707 12864093722915635200) ) (define (read-line port) ; next line (incl. #\newline) of port (let ((line (string-ec (:until (:port c port read-char) (char=? c #\newline) ) c ))) (if (string=? line "") (read-char port) ; eof-object line ))) (define (read-lines filename) ; list of all lines (my-call-with-input-file filename (lambda (port) (list-ec (:port line port read-line) line) ))) (my-check (begin (let ((f (my-open-output-file "tmp1"))) (do-ec (:range n 10) (begin (write n f) (newline f))) (close-output-port f)) (read-lines "tmp1") ) => (list-ec (:char-range c #\0 #\9) (string c #\newline)) ) ; ========================================================================== ; Summary ; ========================================================================== (begin (newline) (newline) (display "correct examples : ") (display my-check-correct) (newline) (display "wrong examples : ") (display my-check-wrong) (newline) (newline) ) ������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a43.sls����������������������������������������������������0000664�0000000�0000000�00000001435�13751542066�0020167�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :43) (export list->vector make-vector reverse-list->vector reverse-vector->list vector vector->list vector-any vector-append vector-binary-search vector-concatenate vector-copy vector-copy! vector-count vector-empty? vector-every vector-fill! vector-fold vector-fold-right vector-for-each vector-index vector-index-right vector-length vector-map vector-map! vector-ref vector-reverse! vector-reverse-copy vector-reverse-copy! vector-set! vector-skip vector-skip-right vector-swap! vector-unfold vector-unfold-right vector= vector?) (import (srfi :43 vectors)) ) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a43/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017441�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a43/vector-lib.scm�����������������������������������������0000664�0000000�0000000�00000160132�13751542066�0022216�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;;;;; SRFI 43: Vector library -*- Scheme -*- ;;; ;;; $Id: vector-lib.scm,v 1.7 2009/03/29 09:46:03 sperber Exp $ ;;; ;;; Taylor Campbell wrote this code; he places it in the public domain. ;;; Will Clinger [wdc] made some corrections, also in the public domain. ;;; -------------------- ;;; Exported procedure index ;;; ;;; * Constructors ;;; make-vector vector ;;; vector-unfold vector-unfold-right ;;; vector-copy vector-reverse-copy ;;; vector-append vector-concatenate ;;; ;;; * Predicates ;;; vector? ;;; vector-empty? ;;; vector= ;;; ;;; * Selectors ;;; vector-ref ;;; vector-length ;;; ;;; * Iteration ;;; vector-fold vector-fold-right ;;; vector-map vector-map! ;;; vector-for-each ;;; vector-count ;;; ;;; * Searching ;;; vector-index vector-skip ;;; vector-index-right vector-skip-right ;;; vector-binary-search ;;; vector-any vector-every ;;; ;;; * Mutators ;;; vector-set! ;;; vector-swap! ;;; vector-fill! ;;; vector-reverse! ;;; vector-copy! vector-reverse-copy! ;;; vector-reverse! ;;; ;;; * Conversion ;;; vector->list reverse-vector->list ;;; list->vector reverse-list->vector ;;; -------------------- ;;; Commentary on efficiency of the code ;;; This code is somewhat tuned for efficiency. There are several ;;; internal routines that can be optimized greatly to greatly improve ;;; the performance of much of the library. These internal procedures ;;; are already carefully tuned for performance, and lambda-lifted by ;;; hand. Some other routines are lambda-lifted by hand, but only the ;;; loops are lambda-lifted, and only if some routine has two possible ;;; loops -- a fast path and an n-ary case --, whereas _all_ of the ;;; internal routines' loops are lambda-lifted so as to never cons a ;;; closure in their body (VECTOR-PARSE-START+END doesn't have a loop), ;;; even in Scheme systems that perform no loop optimization (which is ;;; most of them, unfortunately). ;;; ;;; Fast paths are provided for common cases in most of the loops in ;;; this library. ;;; ;;; All calls to primitive vector operations are protected by a prior ;;; type check; they can be safely converted to use unsafe equivalents ;;; of the operations, if available. Ideally, the compiler should be ;;; able to determine this, but the state of Scheme compilers today is ;;; not a happy one. ;;; ;;; Efficiency of the actual algorithms is a rather mundane point to ;;; mention; vector operations are rarely beyond being straightforward. ;;; -------------------- ;;; Utilities ;;; SRFI 8, too trivial to put in the dependencies list. (define-syntax receive (syntax-rules () ((receive ?formals ?producer ?body1 ?body2 ...) (call-with-values (lambda () ?producer) (lambda ?formals ?body1 ?body2 ...))))) ;;; Not the best LET*-OPTIONALS, but not the worst, either. Use Olin's ;;; if it's available to you. (define-syntax let*-optionals (syntax-rules () ((let*-optionals (?x ...) ((?var ?default) ...) ?body1 ?body2 ...) (let ((args (?x ...))) (let*-optionals args ((?var ?default) ...) ?body1 ?body2 ...))) ((let*-optionals ?args ((?var ?default) ...) ?body1 ?body2 ...) (let*-optionals:aux ?args ?args ((?var ?default) ...) ?body1 ?body2 ...)))) (define-syntax let*-optionals:aux (syntax-rules () ((aux ?orig-args-var ?args-var () ?body1 ?body2 ...) (if (null? ?args-var) (let () ?body1 ?body2 ...) (error "too many arguments" (length ?orig-args-var) ?orig-args-var))) ((aux ?orig-args-var ?args-var ((?var ?default) ?more ...) ?body1 ?body2 ...) (if (null? ?args-var) (let* ((?var ?default) ?more ...) ?body1 ?body2 ...) (let ((?var (car ?args-var)) (new-args (cdr ?args-var))) (let*-optionals:aux ?orig-args-var new-args (?more ...) ?body1 ?body2 ...)))))) (define (nonneg-int? x) (and (integer? x) (not (negative? x)))) (define (between? x y z) (and (< x y) (<= y z))) (define (unspecified-value) (if #f #f)) ;++ This should be implemented more efficiently. It shouldn't cons a ;++ closure, and the cons cells used in the loops when using this could ;++ be reused. (define (vectors-ref vectors i) (map (lambda (v) (vector-ref v i)) vectors)) ;;; -------------------- ;;; Error checking ;;; Error signalling (not checking) is done in a way that tries to be ;;; as helpful to the person who gets the debugging prompt as possible. ;;; That said, error _checking_ tries to be as unredundant as possible. ;;; I don't use any sort of general condition mechanism; I use simply ;;; SRFI 23's ERROR, even in cases where it might be better to use such ;;; a general condition mechanism. Fix that when porting this to a ;;; Scheme implementation that has its own condition system. ;;; In argument checks, upon receiving an invalid argument, the checker ;;; procedure recursively calls itself, but in one of the arguments to ;;; itself is a call to ERROR; this mechanism is used in the hopes that ;;; the user may be thrown into a debugger prompt, proceed with another ;;; value, and let it be checked again. ;;; Type checking is pretty basic, but easily factored out and replaced ;;; with whatever your implementation's preferred type checking method ;;; is. I doubt there will be many other methods of index checking, ;;; though the index checkers might be better implemented natively. ;;; (CHECK-TYPE <type-predicate?> <value> <callee>) -> value ;;; Ensure that VALUE satisfies TYPE-PREDICATE?; if not, signal an ;;; error stating that VALUE did not satisfy TYPE-PREDICATE?, showing ;;; that this happened while calling CALLEE. Return VALUE if no ;;; error was signalled. (define (check-type pred? value callee) (if (pred? value) value ;; Recur: when (or if) the user gets a debugger prompt, he can ;; proceed where the call to ERROR was with the correct value. (check-type pred? (error "erroneous value" (list pred? value) `(while calling ,callee)) callee))) ;;; (CHECK-INDEX <vector> <index> <callee>) -> index ;;; Ensure that INDEX is a valid index into VECTOR; if not, signal an ;;; error stating that it is not and that this happened in a call to ;;; CALLEE. Return INDEX when it is valid. (Note that this does NOT ;;; check that VECTOR is indeed a vector.) (define (check-index vec index callee) (let ((index (check-type integer? index callee))) (cond ((< index 0) (check-index vec (error "vector index too low" index `(into vector ,vec) `(while calling ,callee)) callee)) ((>= index (vector-length vec)) (check-index vec (error "vector index too high" index `(into vector ,vec) `(while calling ,callee)) callee)) (else index)))) ;;; (CHECK-INDICES <vector> ;;; <start> <start-name> ;;; <end> <end-name> ;;; <caller>) -> [start end] ;;; Ensure that START and END are valid bounds of a range within ;;; VECTOR; if not, signal an error stating that they are not, with ;;; the message being informative about what the argument names were ;;; called -- by using START-NAME & END-NAME --, and that it occurred ;;; while calling CALLEE. Also ensure that VEC is in fact a vector. ;;; Returns no useful value. (define (check-indices vec start start-name end end-name callee) (let ((lose (lambda things (apply error "vector range out of bounds" (append things `(vector was ,vec) `(,start-name was ,start) `(,end-name was ,end) `(while calling ,callee))))) (start (check-type integer? start callee)) (end (check-type integer? end callee))) (cond ((> start end) ;; I'm not sure how well this will work. The intent is that ;; the programmer tells the debugger to proceed with both a ;; new START & a new END by returning multiple values ;; somewhere. (receive (new-start new-end) (lose `(,end-name < ,start-name)) (check-indices vec new-start start-name new-end end-name callee))) ((< start 0) (check-indices vec (lose `(,start-name < 0)) start-name end end-name callee)) ((>= start (vector-length vec)) (check-indices vec (lose `(,start-name > len) `(len was ,(vector-length vec))) start-name end end-name callee)) ((> end (vector-length vec)) (check-indices vec start start-name (lose `(,end-name > len) `(len was ,(vector-length vec))) end-name callee)) (else (values start end))))) ;;; -------------------- ;;; Internal routines ;;; These should all be integrated, native, or otherwise optimized -- ;;; they're used a _lot_ --. All of the loops and LETs inside loops ;;; are lambda-lifted by hand, just so as not to cons closures in the ;;; loops. (If your compiler can do better than that if they're not ;;; lambda-lifted, then lambda-drop (?) them.) ;;; (VECTOR-PARSE-START+END <vector> <arguments> ;;; <start-name> <end-name> ;;; <callee>) ;;; -> [start end] ;;; Return two values, composing a valid range within VECTOR, as ;;; extracted from ARGUMENTS or defaulted from VECTOR -- 0 for START ;;; and the length of VECTOR for END --; START-NAME and END-NAME are ;;; purely for error checking. (define (vector-parse-start+end vec args start-name end-name callee) (let ((len (vector-length vec))) (cond ((null? args) (values 0 len)) ((null? (cdr args)) (check-indices vec (car args) start-name len end-name callee)) ((null? (cddr args)) (check-indices vec (car args) start-name (cadr args) end-name callee)) (else (error "too many arguments" `(extra args were ,(cddr args)) `(while calling ,callee)))))) (define-syntax let-vector-start+end (syntax-rules () ((let-vector-start+end ?callee ?vec ?args (?start ?end) ?body1 ?body2 ...) (let ((?vec (check-type vector? ?vec ?callee))) (receive (?start ?end) (vector-parse-start+end ?vec ?args '?start '?end ?callee) ?body1 ?body2 ...))))) ;;; (%SMALLEST-LENGTH <vector-list> <default-length> <callee>) ;;; -> exact, nonnegative integer ;;; Compute the smallest length of VECTOR-LIST. DEFAULT-LENGTH is ;;; the length that is returned if VECTOR-LIST is empty. Common use ;;; of this is in n-ary vector routines: ;;; (define (f vec . vectors) ;;; (let ((vec (check-type vector? vec f))) ;;; ...(%smallest-length vectors (vector-length vec) f)...)) ;;; %SMALLEST-LENGTH takes care of the type checking -- which is what ;;; the CALLEE argument is for --; thus, the design is tuned for ;;; avoiding redundant type checks. (define %smallest-length (letrec ((loop (lambda (vector-list length callee) (if (null? vector-list) length (loop (cdr vector-list) (min (vector-length (check-type vector? (car vector-list) callee)) length) callee))))) loop)) ;;; (%VECTOR-COPY! <target> <tstart> <source> <sstart> <send>) ;;; Copy elements at locations SSTART to SEND from SOURCE to TARGET, ;;; starting at TSTART in TARGET. ;;; ;;; Optimize this! Probably with some combination of: ;;; - Force it to be integrated. ;;; - Let it use unsafe vector element dereferencing routines: bounds ;;; checking already happens outside of it. (Or use a compiler ;;; that figures this out, but Olin Shivers' PhD thesis seems to ;;; have been largely ignored in actual implementations...) ;;; - Implement it natively as a VM primitive: the VM can undoubtedly ;;; perform much faster than it can make Scheme perform, even with ;;; bounds checking. ;;; - Implement it in assembly: you _want_ the fine control that ;;; assembly can give you for this. ;;; I already lambda-lift it by hand, but you should be able to make it ;;; even better than that. (define %vector-copy! (letrec ((loop/l->r (lambda (target source send i j) (cond ((< i send) (vector-set! target j (vector-ref source i)) (loop/l->r target source send (+ i 1) (+ j 1)))))) (loop/r->l (lambda (target source sstart i j) (cond ((>= i sstart) (vector-set! target j (vector-ref source i)) (loop/r->l target source sstart (- i 1) (- j 1))))))) (lambda (target tstart source sstart send) (if (> sstart tstart) ; Make sure we don't copy over ; ourselves. (loop/l->r target source send sstart tstart) (loop/r->l target source sstart (- send 1) (+ -1 tstart send (- sstart))))))) ;;; (%VECTOR-REVERSE-COPY! <target> <tstart> <source> <sstart> <send>) ;;; Copy elements from SSTART to SEND from SOURCE to TARGET, in the ;;; reverse order. (define %vector-reverse-copy! (letrec ((loop (lambda (target source sstart i j) (cond ((>= i sstart) (vector-set! target j (vector-ref source i)) (loop target source sstart (- i 1) (+ j 1))))))) (lambda (target tstart source sstart send) (loop target source sstart (- send 1) tstart)))) ;;; (%VECTOR-REVERSE! <vector>) (define %vector-reverse! (letrec ((loop (lambda (vec i j) (cond ((<= i j) (let ((v (vector-ref vec i))) (vector-set! vec i (vector-ref vec j)) (vector-set! vec j v) (loop vec (+ i 1) (- j 1)))))))) (lambda (vec start end) (loop vec start (- end 1))))) ;;; (%VECTOR-FOLD1 <kons> <knil> <vector>) -> knil' ;;; (KONS <index> <knil> <elt>) -> knil' (define %vector-fold1 (letrec ((loop (lambda (kons knil len vec i) (if (= i len) knil (loop kons (kons i knil (vector-ref vec i)) len vec (+ i 1)))))) (lambda (kons knil len vec) (loop kons knil len vec 0)))) ;;; (%VECTOR-FOLD2+ <kons> <knil> <vector> ...) -> knil' ;;; (KONS <index> <knil> <elt> ...) -> knil' (define %vector-fold2+ (letrec ((loop (lambda (kons knil len vectors i) (if (= i len) knil (loop kons (apply kons i knil (vectors-ref vectors i)) len vectors (+ i 1)))))) (lambda (kons knil len vectors) (loop kons knil len vectors 0)))) ;;; (%VECTOR-MAP! <f> <target> <length> <vector>) -> target ;;; (F <index> <elt>) -> elt' (define %vector-map1! (letrec ((loop (lambda (f target vec i) (if (zero? i) target (let ((j (- i 1))) (vector-set! target j (f j (vector-ref vec j))) (loop f target vec j)))))) (lambda (f target vec len) (loop f target vec len)))) ;;; (%VECTOR-MAP2+! <f> <target> <vectors> <len>) -> target ;;; (F <index> <elt> ...) -> elt' (define %vector-map2+! (letrec ((loop (lambda (f target vectors i) (if (zero? i) target (let ((j (- i 1))) (vector-set! target j (apply f j (vectors-ref vectors j))) (loop f target vectors j)))))) (lambda (f target vectors len) (loop f target vectors len)))) ;;;;;;;;;;;;;;;;;;;;;;;; ***** vector-lib ***** ;;;;;;;;;;;;;;;;;;;;;;; ;;; -------------------- ;;; Constructors ;;; (MAKE-VECTOR <size> [<fill>]) -> vector ;;; [R5RS] Create a vector of length LENGTH. If FILL is present, ;;; initialize each slot in the vector with it; if not, the vector's ;;; initial contents are unspecified. (define make-vector make-vector) ;;; (VECTOR <elt> ...) -> vector ;;; [R5RS] Create a vector containing ELEMENT ..., in order. (define vector vector) ;;; This ought to be able to be implemented much more efficiently -- if ;;; we have the number of arguments available to us, we can create the ;;; vector without using LENGTH to determine the number of elements it ;;; should have. ;(define (vector . elements) (list->vector elements)) ;;; (VECTOR-UNFOLD <f> <length> <initial-seed> ...) -> vector ;;; (F <index> <seed> ...) -> [elt seed' ...] ;;; The fundamental vector constructor. Creates a vector whose ;;; length is LENGTH and iterates across each index K between 0 and ;;; LENGTH, applying F at each iteration to the current index and the ;;; current seeds to receive N+1 values: first, the element to put in ;;; the Kth slot and then N new seeds for the next iteration. (define vector-unfold (letrec ((tabulate! ; Special zero-seed case. (lambda (f vec i len) (cond ((< i len) (vector-set! vec i (f i)) (tabulate! f vec (+ i 1) len))))) (unfold1! ; Fast path for one seed. (lambda (f vec i len seed) (if (< i len) (receive (elt new-seed) (f i seed) (vector-set! vec i elt) (unfold1! f vec (+ i 1) len new-seed))))) (unfold2+! ; Slower variant for N seeds. (lambda (f vec i len seeds) (if (< i len) (receive (elt . new-seeds) (apply f i seeds) (vector-set! vec i elt) (unfold2+! f vec (+ i 1) len new-seeds)))))) (lambda (f len . initial-seeds) (let ((f (check-type procedure? f vector-unfold)) (len (check-type nonneg-int? len vector-unfold))) (let ((vec (make-vector len))) (cond ((null? initial-seeds) (tabulate! f vec 0 len)) ((null? (cdr initial-seeds)) (unfold1! f vec 0 len (car initial-seeds))) (else (unfold2+! f vec 0 len initial-seeds))) vec))))) ;;; (VECTOR-UNFOLD-RIGHT <f> <length> <initial-seed> ...) -> vector ;;; (F <seed> ...) -> [seed' ...] ;;; Like VECTOR-UNFOLD, but it generates elements from LENGTH to 0 ;;; (still exclusive with LENGTH and inclusive with 0), not 0 to ;;; LENGTH as with VECTOR-UNFOLD. (define vector-unfold-right (letrec ((tabulate! (lambda (f vec i) (cond ((>= i 0) (vector-set! vec i (f i)) (tabulate! f vec (- i 1)))))) (unfold1! (lambda (f vec i seed) (if (>= i 0) (receive (elt new-seed) (f i seed) (vector-set! vec i elt) (unfold1! f vec (- i 1) new-seed))))) (unfold2+! (lambda (f vec i seeds) (if (>= i 0) (receive (elt . new-seeds) (apply f i seeds) (vector-set! vec i elt) (unfold2+! f vec (- i 1) new-seeds)))))) (lambda (f len . initial-seeds) (let ((f (check-type procedure? f vector-unfold-right)) (len (check-type nonneg-int? len vector-unfold-right))) (let ((vec (make-vector len)) (i (- len 1))) (cond ((null? initial-seeds) (tabulate! f vec i)) ((null? (cdr initial-seeds)) (unfold1! f vec i (car initial-seeds))) (else (unfold2+! f vec i initial-seeds))) vec))))) ;;; (VECTOR-COPY <vector> [<start> <end> <fill>]) -> vector ;;; Create a newly allocated vector containing the elements from the ;;; range [START,END) in VECTOR. START defaults to 0; END defaults ;;; to the length of VECTOR. END may be greater than the length of ;;; VECTOR, in which case the vector is enlarged; if FILL is passed, ;;; the new locations from which there is no respective element in ;;; VECTOR are filled with FILL. (define (vector-copy vec . args) (let ((vec (check-type vector? vec vector-copy))) ;; We can't use LET-VECTOR-START+END, because we have one more ;; argument, and we want finer control, too. ;; ;; Olin's implementation of LET*-OPTIONALS would prove useful here: ;; the built-in argument-checks-as-you-go-along produces almost ;; _exactly_ the same code as VECTOR-COPY:PARSE-ARGS. (receive (start end fill) (vector-copy:parse-args vec args) (let ((new-vector (make-vector (- end start) fill))) (%vector-copy! new-vector 0 vec start (if (> end (vector-length vec)) (vector-length vec) end)) new-vector)))) ;;; Auxiliary for VECTOR-COPY. ;;; [wdc] Corrected to allow 0 <= start <= (vector-length vec). (define (vector-copy:parse-args vec args) (define (parse-args start end n fill) (let ((start (check-type nonneg-int? start vector-copy)) (end (check-type nonneg-int? end vector-copy))) (cond ((and (<= 0 start end) (<= start n)) (values start end fill)) (else (error "illegal arguments" `(while calling ,vector-copy) `(start was ,start) `(end was ,end) `(vector was ,vec)))))) (let ((n (vector-length vec))) (cond ((null? args) (parse-args 0 n n (unspecified-value))) ((null? (cdr args)) (parse-args (car args) n n (unspecified-value))) ((null? (cddr args)) (parse-args (car args) (cadr args) n (unspecified-value))) ((null? (cdddr args)) (parse-args (car args) (cadr args) n (caddr args))) (else (error "too many arguments" vector-copy (cdddr args)))))) ;;; (VECTOR-REVERSE-COPY <vector> [<start> <end>]) -> vector ;;; Create a newly allocated vector whose elements are the reversed ;;; sequence of elements between START and END in VECTOR. START's ;;; default is 0; END's default is the length of VECTOR. (define (vector-reverse-copy vec . maybe-start+end) (let-vector-start+end vector-reverse-copy vec maybe-start+end (start end) (let ((new (make-vector (- end start)))) (%vector-reverse-copy! new 0 vec start end) new))) ;;; (VECTOR-APPEND <vector> ...) -> vector ;;; Append VECTOR ... into a newly allocated vector and return that ;;; new vector. (define (vector-append . vectors) (vector-concatenate:aux vectors vector-append)) ;;; (VECTOR-CONCATENATE <vector-list>) -> vector ;;; Concatenate the vectors in VECTOR-LIST. This is equivalent to ;;; (apply vector-append VECTOR-LIST) ;;; but VECTOR-APPEND tends to be implemented in terms of ;;; VECTOR-CONCATENATE, and some Schemes bork when the list to apply ;;; a function to is too long. ;;; ;;; Actually, they're both implemented in terms of an internal routine. (define (vector-concatenate vector-list) (vector-concatenate:aux vector-list vector-concatenate)) ;;; Auxiliary for VECTOR-APPEND and VECTOR-CONCATENATE (define vector-concatenate:aux (letrec ((compute-length (lambda (vectors len callee) (if (null? vectors) len (let ((vec (check-type vector? (car vectors) callee))) (compute-length (cdr vectors) (+ (vector-length vec) len) callee))))) (concatenate! (lambda (vectors target to) (if (null? vectors) target (let* ((vec1 (car vectors)) (len (vector-length vec1))) (%vector-copy! target to vec1 0 len) (concatenate! (cdr vectors) target (+ to len))))))) (lambda (vectors callee) (cond ((null? vectors) ;+++ (make-vector 0)) ((null? (cdr vectors)) ;+++ ;; Blech, we still have to allocate a new one. (let* ((vec (check-type vector? (car vectors) callee)) (len (vector-length vec)) (new (make-vector len))) (%vector-copy! new 0 vec 0 len) new)) (else (let ((new-vector (make-vector (compute-length vectors 0 callee)))) (concatenate! vectors new-vector 0) new-vector)))))) ;;; -------------------- ;;; Predicates ;;; (VECTOR? <value>) -> boolean ;;; [R5RS] Return #T if VALUE is a vector and #F if not. (define vector? vector?) ;;; (VECTOR-EMPTY? <vector>) -> boolean ;;; Return #T if VECTOR has zero elements in it, i.e. VECTOR's length ;;; is 0, and #F if not. (define (vector-empty? vec) (let ((vec (check-type vector? vec vector-empty?))) (zero? (vector-length vec)))) ;;; (VECTOR= <elt=?> <vector> ...) -> boolean ;;; (ELT=? <value> <value>) -> boolean ;;; Determine vector equality generalized across element comparators. ;;; Vectors A and B are equal iff their lengths are the same and for ;;; each respective elements E_a and E_b (element=? E_a E_b) returns ;;; a true value. ELT=? is always applied to two arguments. Element ;;; comparison must be consistent wtih EQ?; that is, if (eq? E_a E_b) ;;; results in a true value, then (ELEMENT=? E_a E_b) must result in a ;;; true value. This may be exploited to avoid multiple unnecessary ;;; element comparisons. (This implementation does, but does not deal ;;; with the situation that ELEMENT=? is EQ? to avoid more unnecessary ;;; comparisons, but I believe this optimization is probably fairly ;;; insignificant.) ;;; ;;; If the number of vector arguments is zero or one, then #T is ;;; automatically returned. If there are N vector arguments, ;;; VECTOR_1 VECTOR_2 ... VECTOR_N, then VECTOR_1 & VECTOR_2 are ;;; compared; if they are equal, the vectors VECTOR_2 ... VECTOR_N ;;; are compared. The precise order in which ELT=? is applied is not ;;; specified. (define (vector= elt=? . vectors) (let ((elt=? (check-type procedure? elt=? vector=))) (cond ((null? vectors) #t) ((null? (cdr vectors)) (check-type vector? (car vectors) vector=) #t) (else (let loop ((vecs vectors)) (let ((vec1 (check-type vector? (car vecs) vector=)) (vec2+ (cdr vecs))) (or (null? vec2+) (and (binary-vector= elt=? vec1 (car vec2+)) (loop vec2+))))))))) (define (binary-vector= elt=? vector-a vector-b) (or (eq? vector-a vector-b) ;+++ (let ((length-a (vector-length vector-a)) (length-b (vector-length vector-b))) (letrec ((loop (lambda (i) (or (= i length-a) (and (< i length-b) (test (vector-ref vector-a i) (vector-ref vector-b i) i))))) (test (lambda (elt-a elt-b i) (and (or (eq? elt-a elt-b) ;+++ (elt=? elt-a elt-b)) (loop (+ i 1)))))) (and (= length-a length-b) (loop 0)))))) ;;; -------------------- ;;; Selectors ;;; (VECTOR-REF <vector> <index>) -> value ;;; [R5RS] Return the value that the location in VECTOR at INDEX is ;;; mapped to in the store. (define vector-ref vector-ref) ;;; (VECTOR-LENGTH <vector>) -> exact, nonnegative integer ;;; [R5RS] Return the length of VECTOR. (define vector-length vector-length) ;;; -------------------- ;;; Iteration ;;; (VECTOR-FOLD <kons> <initial-knil> <vector> ...) -> knil ;;; (KONS <knil> <elt> ...) -> knil' ; N vectors -> N+1 args ;;; The fundamental vector iterator. KONS is iterated over each ;;; index in all of the vectors in parallel, stopping at the end of ;;; the shortest; KONS is applied to an argument list of (list I ;;; STATE (vector-ref VEC I) ...), where STATE is the current state ;;; value -- the state value begins with KNIL and becomes whatever ;;; KONS returned at the respective iteration --, and I is the ;;; current index in the iteration. The iteration is strictly left- ;;; to-right. ;;; (vector-fold KONS KNIL (vector E_1 E_2 ... E_N)) ;;; <=> ;;; (KONS (... (KONS (KONS KNIL E_1) E_2) ... E_N-1) E_N) (define (vector-fold kons knil vec . vectors) (let ((kons (check-type procedure? kons vector-fold)) (vec (check-type vector? vec vector-fold))) (if (null? vectors) (%vector-fold1 kons knil (vector-length vec) vec) (%vector-fold2+ kons knil (%smallest-length vectors (vector-length vec) vector-fold) (cons vec vectors))))) ;;; (VECTOR-FOLD-RIGHT <kons> <initial-knil> <vector> ...) -> knil ;;; (KONS <knil> <elt> ...) -> knil' ; N vectors => N+1 args ;;; The fundamental vector recursor. Iterates in parallel across ;;; VECTOR ... right to left, applying KONS to the elements and the ;;; current state value; the state value becomes what KONS returns ;;; at each next iteration. KNIL is the initial state value. ;;; (vector-fold-right KONS KNIL (vector E_1 E_2 ... E_N)) ;;; <=> ;;; (KONS (... (KONS (KONS KNIL E_N) E_N-1) ... E_2) E_1) ;;; ;;; Not implemented in terms of a more primitive operations that might ;;; called %VECTOR-FOLD-RIGHT due to the fact that it wouldn't be very ;;; useful elsewhere. (define vector-fold-right (letrec ((loop1 (lambda (kons knil vec i) (if (negative? i) knil (loop1 kons (kons i knil (vector-ref vec i)) vec (- i 1))))) (loop2+ (lambda (kons knil vectors i) (if (negative? i) knil (loop2+ kons (apply kons i knil (vectors-ref vectors i)) vectors (- i 1)))))) (lambda (kons knil vec . vectors) (let ((kons (check-type procedure? kons vector-fold-right)) (vec (check-type vector? vec vector-fold-right))) (if (null? vectors) (loop1 kons knil vec (- (vector-length vec) 1)) (loop2+ kons knil (cons vec vectors) (- (%smallest-length vectors (vector-length vec) vector-fold-right) 1))))))) ;;; (VECTOR-MAP <f> <vector> ...) -> vector ;;; (F <elt> ...) -> value ; N vectors -> N args ;;; Constructs a new vector of the shortest length of the vector ;;; arguments. Each element at index I of the new vector is mapped ;;; from the old vectors by (F I (vector-ref VECTOR I) ...). The ;;; dynamic order of application of F is unspecified. (define (vector-map f vec . vectors) (let ((f (check-type procedure? f vector-map)) (vec (check-type vector? vec vector-map))) (if (null? vectors) (let ((len (vector-length vec))) (%vector-map1! f (make-vector len) vec len)) (let ((len (%smallest-length vectors (vector-length vec) vector-map))) (%vector-map2+! f (make-vector len) (cons vec vectors) len))))) ;;; (VECTOR-MAP! <f> <vector> ...) -> unspecified ;;; (F <elt> ...) -> element' ; N vectors -> N args ;;; Similar to VECTOR-MAP, but rather than mapping the new elements ;;; into a new vector, the new mapped elements are destructively ;;; inserted into the first vector. Again, the dynamic order of ;;; application of F is unspecified, so it is dangerous for F to ;;; manipulate the first VECTOR. (define (vector-map! f vec . vectors) (let ((f (check-type procedure? f vector-map!)) (vec (check-type vector? vec vector-map!))) (if (null? vectors) (%vector-map1! f vec vec (vector-length vec)) (%vector-map2+! f vec (cons vec vectors) (%smallest-length vectors (vector-length vec) vector-map!))) (unspecified-value))) ;;; (VECTOR-FOR-EACH <f> <vector> ...) -> unspecified ;;; (F <elt> ...) ; N vectors -> N args ;;; Simple vector iterator: applies F to each index in the range [0, ;;; LENGTH), where LENGTH is the length of the smallest vector ;;; argument passed, and the respective element at that index. In ;;; contrast with VECTOR-MAP, F is reliably applied to each ;;; subsequent elements, starting at index 0 from left to right, in ;;; the vectors. (define vector-for-each (letrec ((for-each1 (lambda (f vec i len) (cond ((< i len) (f i (vector-ref vec i)) (for-each1 f vec (+ i 1) len))))) (for-each2+ (lambda (f vecs i len) (cond ((< i len) (apply f i (vectors-ref vecs i)) (for-each2+ f vecs (+ i 1) len)))))) (lambda (f vec . vectors) (let ((f (check-type procedure? f vector-for-each)) (vec (check-type vector? vec vector-for-each))) (if (null? vectors) (for-each1 f vec 0 (vector-length vec)) (for-each2+ f (cons vec vectors) 0 (%smallest-length vectors (vector-length vec) vector-for-each))))))) ;;; (VECTOR-COUNT <predicate?> <vector> ...) ;;; -> exact, nonnegative integer ;;; (PREDICATE? <index> <value> ...) ; N vectors -> N+1 args ;;; PREDICATE? is applied element-wise to the elements of VECTOR ..., ;;; and a count is tallied of the number of elements for which a ;;; true value is produced by PREDICATE?. This count is returned. (define (vector-count pred? vec . vectors) (let ((pred? (check-type procedure? pred? vector-count)) (vec (check-type vector? vec vector-count))) (if (null? vectors) (%vector-fold1 (lambda (index count elt) (if (pred? index elt) (+ count 1) count)) 0 (vector-length vec) vec) (%vector-fold2+ (lambda (index count . elts) (if (apply pred? index elts) (+ count 1) count)) 0 (%smallest-length vectors (vector-length vec) vector-count) (cons vec vectors))))) ;;; -------------------- ;;; Searching ;;; (VECTOR-INDEX <predicate?> <vector> ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args ;;; Search left-to-right across VECTOR ... in parallel, returning the ;;; index of the first set of values VALUE ... such that (PREDICATE? ;;; VALUE ...) returns a true value; if no such set of elements is ;;; reached, return #F. (define (vector-index pred? vec . vectors) (vector-index/skip pred? vec vectors vector-index)) ;;; (VECTOR-SKIP <predicate?> <vector> ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args ;;; (vector-index (lambda elts (not (apply PREDICATE? elts))) ;;; VECTOR ...) ;;; Like VECTOR-INDEX, but find the index of the first set of values ;;; that do _not_ satisfy PREDICATE?. (define (vector-skip pred? vec . vectors) (vector-index/skip (lambda elts (not (apply pred? elts))) vec vectors vector-skip)) ;;; Auxiliary for VECTOR-INDEX & VECTOR-SKIP (define vector-index/skip (letrec ((loop1 (lambda (pred? vec len i) (cond ((= i len) #f) ((pred? (vector-ref vec i)) i) (else (loop1 pred? vec len (+ i 1)))))) (loop2+ (lambda (pred? vectors len i) (cond ((= i len) #f) ((apply pred? (vectors-ref vectors i)) i) (else (loop2+ pred? vectors len (+ i 1))))))) (lambda (pred? vec vectors callee) (let ((pred? (check-type procedure? pred? callee)) (vec (check-type vector? vec callee))) (if (null? vectors) (loop1 pred? vec (vector-length vec) 0) (loop2+ pred? (cons vec vectors) (%smallest-length vectors (vector-length vec) callee) 0)))))) ;;; (VECTOR-INDEX-RIGHT <predicate?> <vector> ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args ;;; Right-to-left variant of VECTOR-INDEX. (define (vector-index-right pred? vec . vectors) (vector-index/skip-right pred? vec vectors vector-index-right)) ;;; (VECTOR-SKIP-RIGHT <predicate?> <vector> ...) ;;; -> exact, nonnegative integer or #F ;;; (PREDICATE? <elt> ...) -> boolean ; N vectors -> N args ;;; Right-to-left variant of VECTOR-SKIP. (define (vector-skip-right pred? vec . vectors) (vector-index/skip-right (lambda elts (not (apply pred? elts))) vec vectors vector-index-right)) (define vector-index/skip-right (letrec ((loop1 (lambda (pred? vec i) (cond ((negative? i) #f) ((pred? (vector-ref vec i)) i) (else (loop1 pred? vec (- i 1)))))) (loop2+ (lambda (pred? vectors i) (cond ((negative? i) #f) ((apply pred? (vectors-ref vectors i)) i) (else (loop2+ pred? vectors (- i 1))))))) (lambda (pred? vec vectors callee) (let ((pred? (check-type procedure? pred? callee)) (vec (check-type vector? vec callee))) (if (null? vectors) (loop1 pred? vec (- (vector-length vec) 1)) (loop2+ pred? (cons vec vectors) (- (%smallest-length vectors (vector-length vec) callee) 1))))))) ;;; (VECTOR-BINARY-SEARCH <vector> <value> <cmp> [<start> <end>]) ;;; -> exact, nonnegative integer or #F ;;; (CMP <value1> <value2>) -> integer ;;; positive -> VALUE1 > VALUE2 ;;; zero -> VALUE1 = VALUE2 ;;; negative -> VALUE1 < VALUE2 ;;; Perform a binary search through VECTOR for VALUE, comparing each ;;; element to VALUE with CMP. (define (vector-binary-search vec value cmp . maybe-start+end) (let ((cmp (check-type procedure? cmp vector-binary-search))) (let-vector-start+end vector-binary-search vec maybe-start+end (start end) (let loop ((start start) (end end) (j #f)) (let ((i (quotient (+ start end) 2))) (if (or (= start end) (and j (= i j))) #f (let ((comparison (check-type integer? (cmp (vector-ref vec i) value) `(,cmp for ,vector-binary-search)))) (cond ((zero? comparison) i) ((positive? comparison) (loop start i i)) (else (loop i end i)))))))))) ;;; (VECTOR-ANY <pred?> <vector> ...) -> value ;;; Apply PRED? to each parallel element in each VECTOR ...; if PRED? ;;; should ever return a true value, immediately stop and return that ;;; value; otherwise, when the shortest vector runs out, return #F. ;;; The iteration and order of application of PRED? across elements ;;; is of the vectors is strictly left-to-right. (define vector-any (letrec ((loop1 (lambda (pred? vec i len len-1) (and (not (= i len)) (if (= i len-1) (pred? (vector-ref vec i)) (or (pred? (vector-ref vec i)) (loop1 pred? vec (+ i 1) len len-1)))))) (loop2+ (lambda (pred? vectors i len len-1) (and (not (= i len)) (if (= i len-1) (apply pred? (vectors-ref vectors i)) (or (apply pred? (vectors-ref vectors i)) (loop2+ pred? vectors (+ i 1) len len-1))))))) (lambda (pred? vec . vectors) (let ((pred? (check-type procedure? pred? vector-any)) (vec (check-type vector? vec vector-any))) (if (null? vectors) (let ((len (vector-length vec))) (loop1 pred? vec 0 len (- len 1))) (let ((len (%smallest-length vectors (vector-length vec) vector-any))) (loop2+ pred? (cons vec vectors) 0 len (- len 1)))))))) ;;; (VECTOR-EVERY <pred?> <vector> ...) -> value ;;; Apply PRED? to each parallel value in each VECTOR ...; if PRED? ;;; should ever return #F, immediately stop and return #F; otherwise, ;;; if PRED? should return a true value for each element, stopping at ;;; the end of the shortest vector, return the last value that PRED? ;;; returned. In the case that there is an empty vector, return #T. ;;; The iteration and order of application of PRED? across elements ;;; is of the vectors is strictly left-to-right. (define vector-every (letrec ((loop1 (lambda (pred? vec i len len-1) (or (= i len) (if (= i len-1) (pred? (vector-ref vec i)) (and (pred? (vector-ref vec i)) (loop1 pred? vec (+ i 1) len len-1)))))) (loop2+ (lambda (pred? vectors i len len-1) (or (= i len) (if (= i len-1) (apply pred? (vectors-ref vectors i)) (and (apply pred? (vectors-ref vectors i)) (loop2+ pred? vectors (+ i 1) len len-1))))))) (lambda (pred? vec . vectors) (let ((pred? (check-type procedure? pred? vector-every)) (vec (check-type vector? vec vector-every))) (if (null? vectors) (let ((len (vector-length vec))) (loop1 pred? vec 0 len (- len 1))) (let ((len (%smallest-length vectors (vector-length vec) vector-every))) (loop2+ pred? (cons vec vectors) 0 len (- len 1)))))))) ;;; -------------------- ;;; Mutators ;;; (VECTOR-SET! <vector> <index> <value>) -> unspecified ;;; [R5RS] Assign the location at INDEX in VECTOR to VALUE. (define vector-set! vector-set!) ;;; (VECTOR-SWAP! <vector> <index1> <index2>) -> unspecified ;;; Swap the values in the locations at INDEX1 and INDEX2. (define (vector-swap! vec i j) (let ((vec (check-type vector? vec vector-swap!))) (let ((i (check-index vec i vector-swap!)) (j (check-index vec j vector-swap!))) (let ((x (vector-ref vec i))) (vector-set! vec i (vector-ref vec j)) (vector-set! vec j x))))) ;;; (VECTOR-FILL! <vector> <value> [<start> <end>]) -> unspecified ;;; [R5RS+] Fill the locations in VECTOR between START, whose default ;;; is 0, and END, whose default is the length of VECTOR, with VALUE. ;;; ;;; This one can probably be made really fast natively. (define vector-fill! (let ((%vector-fill! vector-fill!)) ; Take the native one, under ; the assumption that it's ; faster, so we can use it if ; there are no optional ; arguments. (lambda (vec value . maybe-start+end) (if (null? maybe-start+end) (%vector-fill! vec value) ;+++ (let-vector-start+end vector-fill! vec maybe-start+end (start end) (do ((i start (+ i 1))) ((= i end)) (vector-set! vec i value))))))) ;;; (VECTOR-COPY! <target> <tstart> <source> [<sstart> <send>]) ;;; -> unspecified ;;; Copy the values in the locations in [SSTART,SEND) from SOURCE to ;;; to TARGET, starting at TSTART in TARGET. ;;; [wdc] Corrected to allow 0 <= sstart <= send <= (vector-length source). (define (vector-copy! target tstart source . maybe-sstart+send) (define (doit! sstart send source-length) (let ((tstart (check-type nonneg-int? tstart vector-copy!)) (sstart (check-type nonneg-int? sstart vector-copy!)) (send (check-type nonneg-int? send vector-copy!))) (cond ((and (<= 0 sstart send source-length) (<= (+ tstart (- send sstart)) (vector-length target))) (%vector-copy! target tstart source sstart send)) (else (error "illegal arguments" `(while calling ,vector-copy!) `(target was ,target) `(target-length was ,(vector-length target)) `(tstart was ,tstart) `(source was ,source) `(source-length was ,source-length) `(sstart was ,sstart) `(send was ,send)))))) (let ((n (vector-length source))) (cond ((null? maybe-sstart+send) (doit! 0 n n)) ((null? (cdr maybe-sstart+send)) (doit! (car maybe-sstart+send) n n)) ((null? (cddr maybe-sstart+send)) (doit! (car maybe-sstart+send) (cadr maybe-sstart+send) n)) (else (error "too many arguments" vector-copy! (cddr maybe-sstart+send)))))) ;;; (VECTOR-REVERSE-COPY! <target> <tstart> <source> [<sstart> <send>]) ;;; [wdc] Corrected to allow 0 <= sstart <= send <= (vector-length source). (define (vector-reverse-copy! target tstart source . maybe-sstart+send) (define (doit! sstart send source-length) (let ((tstart (check-type nonneg-int? tstart vector-reverse-copy!)) (sstart (check-type nonneg-int? sstart vector-reverse-copy!)) (send (check-type nonneg-int? send vector-reverse-copy!))) (cond ((and (eq? target source) (or (between? sstart tstart send) (between? tstart sstart (+ tstart (- send sstart))))) (error "vector range for self-copying overlaps" vector-reverse-copy! `(vector was ,target) `(tstart was ,tstart) `(sstart was ,sstart) `(send was ,send))) ((and (<= 0 sstart send source-length) (<= (+ tstart (- send sstart)) (vector-length target))) (%vector-reverse-copy! target tstart source sstart send)) (else (error "illegal arguments" `(while calling ,vector-reverse-copy!) `(target was ,target) `(target-length was ,(vector-length target)) `(tstart was ,tstart) `(source was ,source) `(source-length was ,source-length) `(sstart was ,sstart) `(send was ,send)))))) (let ((n (vector-length source))) (cond ((null? maybe-sstart+send) (doit! 0 n n)) ((null? (cdr maybe-sstart+send)) (doit! (car maybe-sstart+send) n n)) ((null? (cddr maybe-sstart+send)) (doit! (car maybe-sstart+send) (cadr maybe-sstart+send) n)) (else (error "too many arguments" vector-reverse-copy! (cddr maybe-sstart+send)))))) ;;; (VECTOR-REVERSE! <vector> [<start> <end>]) -> unspecified ;;; Destructively reverse the contents of the sequence of locations ;;; in VECTOR between START, whose default is 0, and END, whose ;;; default is the length of VECTOR. (define (vector-reverse! vec . start+end) (let-vector-start+end vector-reverse! vec start+end (start end) (%vector-reverse! vec start end))) ;;; -------------------- ;;; Conversion ;;; (VECTOR->LIST <vector> [<start> <end>]) -> list ;;; [R5RS+] Produce a list containing the elements in the locations ;;; between START, whose default is 0, and END, whose default is the ;;; length of VECTOR, from VECTOR. (define vector->list (let ((%vector->list vector->list)) (lambda (vec . maybe-start+end) (if (null? maybe-start+end) ; Oughta use CASE-LAMBDA. (%vector->list vec) ;+++ (let-vector-start+end vector->list vec maybe-start+end (start end) ;(unfold (lambda (i) ; No SRFI 1. ; (< i start)) ; (lambda (i) (vector-ref vec i)) ; (lambda (i) (- i 1)) ; (- end 1)) (do ((i (- end 1) (- i 1)) (result '() (cons (vector-ref vec i) result))) ((< i start) result))))))) ;;; (REVERSE-VECTOR->LIST <vector> [<start> <end>]) -> list ;;; Produce a list containing the elements in the locations between ;;; START, whose default is 0, and END, whose default is the length ;;; of VECTOR, from VECTOR, in reverse order. (define (reverse-vector->list vec . maybe-start+end) (let-vector-start+end reverse-vector->list vec maybe-start+end (start end) ;(unfold (lambda (i) (= i end)) ; No SRFI 1. ; (lambda (i) (vector-ref vec i)) ; (lambda (i) (+ i 1)) ; start) (do ((i start (+ i 1)) (result '() (cons (vector-ref vec i) result))) ((= i end) result)))) ;;; (LIST->VECTOR <list> [<start> <end>]) -> vector ;;; [R5RS+] Produce a vector containing the elements in LIST, which ;;; must be a proper list, between START, whose default is 0, & END, ;;; whose default is the length of LIST. It is suggested that if the ;;; length of LIST is known in advance, the START and END arguments ;;; be passed, so that LIST->VECTOR need not call LENGTH to determine ;;; the the length. ;;; ;;; This implementation diverges on circular lists, unless LENGTH fails ;;; and causes - to fail as well. Given a LENGTH* that computes the ;;; length of a list's cycle, this wouldn't diverge, and would work ;;; great for circular lists. (define list->vector (let ((%list->vector list->vector)) (lambda (lst . maybe-start+end) ;; Checking the type of a proper list is expensive, so we do it ;; amortizedly, or let %LIST->VECTOR or LIST-TAIL do it. (if (null? maybe-start+end) ; Oughta use CASE-LAMBDA. (%list->vector lst) ;+++ ;; We can't use LET-VECTOR-START+END, because we're using the ;; bounds of a _list_, not a vector. (let*-optionals maybe-start+end ((start 0) (end (length lst))) ; Ugh -- LENGTH (let ((start (check-type nonneg-int? start list->vector)) (end (check-type nonneg-int? end list->vector))) ((lambda (f) (vector-unfold f (- end start) (list-tail lst start))) (lambda (index l) (cond ((null? l) (error "list was too short" `(list was ,lst) `(attempted end was ,end) `(while calling ,list->vector))) ((pair? l) (values (car l) (cdr l))) (else ;; Make this look as much like what CHECK-TYPE ;; would report as possible. (error "erroneous value" ;; We want SRFI 1's PROPER-LIST?, but it ;; would be a waste to link all of SRFI ;; 1 to this module for only the single ;; function PROPER-LIST?. (list list? lst) `(while calling ,list->vector)))))))))))) ;;; (REVERSE-LIST->VECTOR <list> [<start> <end>]) -> vector ;;; Produce a vector containing the elements in LIST, which must be a ;;; proper list, between START, whose default is 0, and END, whose ;;; default is the length of LIST, in reverse order. It is suggested ;;; that if the length of LIST is known in advance, the START and END ;;; arguments be passed, so that REVERSE-LIST->VECTOR need not call ;;; LENGTH to determine the the length. ;;; ;;; This also diverges on circular lists unless, again, LENGTH returns ;;; something that makes - bork. (define (reverse-list->vector lst . maybe-start+end) (let*-optionals maybe-start+end ((start 0) (end (length lst))) ; Ugh -- LENGTH (let ((start (check-type nonneg-int? start reverse-list->vector)) (end (check-type nonneg-int? end reverse-list->vector))) ((lambda (f) (vector-unfold-right f (- end start) (list-tail lst start))) (lambda (index l) (cond ((null? l) (error "list too short" `(list was ,lst) `(attempted end was ,end) `(while calling ,reverse-list->vector))) ((pair? l) (values (car l) (cdr l))) (else (error "erroneous value" (list list? lst) `(while calling ,reverse-list->vector))))))))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a43/vectors.sls��������������������������������������������0000664�0000000�0000000�00000004471�13751542066�0021657�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :43 vectors) (export ;;; * Constructors make-vector vector vector-unfold vector-unfold-right vector-copy vector-reverse-copy vector-append vector-concatenate ;;; * Predicates vector? vector-empty? vector= ;;; * Selectors vector-ref vector-length ;;; * Iteration vector-fold vector-fold-right vector-map vector-map! vector-for-each vector-count ;;; * Searching vector-index vector-skip vector-index-right vector-skip-right vector-binary-search vector-any vector-every ;;; * Mutators vector-set! vector-swap! (rename (my:vector-fill! vector-fill!)) vector-reverse! vector-copy! vector-reverse-copy! ;;; * Conversion (rename (my:vector->list vector->list)) reverse-vector->list (rename (my:list->vector list->vector)) reverse-list->vector ) (import (except (rnrs) vector-map vector-for-each) (rnrs r5rs) (srfi :23 error tricks) (srfi :8 receive) (for (srfi private vanish) expand) (srfi private include)) ;; I do these let-syntax tricks so the original vector-lib.scm file does ;; not have to be modified at all. (let-syntax ((define (let ((vd (vanish-define define (make-vector vector vector? vector-ref vector-set! vector-length)))) (lambda (stx) (define (rename? id) (memp (lambda (x) (free-identifier=? id x)) (list #'vector-fill! #'vector->list #'list->vector))) (define (rename id) (datum->syntax id (string->symbol (string-append "my:" (symbol->string (syntax->datum id)))))) (syntax-case stx () ((_ name . r) (and (identifier? #'name) (rename? #'name)) #`(define #,(rename #'name) . r)) (_ (vd stx)))))) (define-syntax (vanish-define define-syntax (receive)))) (SRFI-23-error->R6RS "(library (srfi :43 vectors))" (include/resolve ("srfi" "%3a43") "vector-lib.scm"))) ) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a45.sls����������������������������������������������������0000664�0000000�0000000�00000000253�13751542066�0020166�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :45) (export delay eager force lazy) (import (srfi :45 lazy)) ) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a45/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017443�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a45/lazy.sls�����������������������������������������������0000664�0000000�0000000�00000005213�13751542066�0021146�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright André van Tonder. All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the "Software"), to deal in the Software without ;; restriction, including without limitation the rights to use, copy, ;; modify, merge, publish, distribute, sublicense, and/or sell copies ;; of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. ;; Modified by Andreas Rottmann to use records instead of mutable pairs. (library (srfi :45 lazy) (export delay lazy force eager) (import (rnrs base) (rnrs records syntactic)) (define-record-type promise (fields (mutable val))) (define-record-type value (fields (mutable tag) (mutable proc))) (define-syntax lazy (syntax-rules () ((lazy exp) (make-promise (make-value 'lazy (lambda () exp)))))) (define (eager x) (make-promise (make-value 'eager x))) (define-syntax delay (syntax-rules () ((delay exp) (lazy (eager exp))))) (define (force promise) (let ((content (promise-val promise))) (case (value-tag content) ((eager) (value-proc content)) ((lazy) (let* ((promise* ((value-proc content))) (content (promise-val promise))) ; * (if (not (eqv? (value-tag content) 'eager)) ; * (begin (value-tag-set! content (value-tag (promise-val promise*))) (value-proc-set! content (value-proc (promise-val promise*))) (promise-val-set! promise* content))) (force promise)))))) ;; (*) These two lines re-fetch and check the original promise in case ;; the first line of the let* caused it to be forced. For an example ;; where this happens, see reentrancy test 3 below. ) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a48.sls����������������������������������������������������0000664�0000000�0000000�00000000246�13751542066�0020173�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :48) (export format) (import (srfi :48 intermediate-format-strings)) ) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a48/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017446�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a48/intermediate-format-strings.sls������������������������0000664�0000000�0000000�00000050623�13751542066�0025626�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;;; FILE "intermediate-format-strings.sls" ;;; IMPLEMENTS SRFI-48: Intermediary format strings ;;; http://srfi.schemers.org/srfi-48/srfi-48.html ;;; AUTHOR Ken Dickey ;;; UPDATED Syntax updated for R6RS February 2008 by Ken Dickey ;;; LANGUAGE R6RS ;; Small changes by Derick Eddington to the beginning of `format'. ;;;Copyright (C) Kenneth A Dickey (2003). All Rights Reserved. ;;; ;;;Permission is hereby granted, free of charge, to any person ;;;obtaining a copy of this software and associated documentation ;;;files (the "Software"), to deal in the Software without ;;;restriction, including without limitation the rights to use, ;;;copy, modify, merge, publish, distribute, sublicense, and/or ;;;sell copies of the Software, and to permit persons to whom ;;;the Software is furnished to do so, subject to the following ;;;conditions: ;;; ;;;The above copyright notice and this permission notice shall ;;;be included in all copies or substantial portions of the Software. ;;; ;;;THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;;EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES ;;;OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;;;NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT ;;;HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, ;;;WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;;;FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR ;;;OTHER DEALINGS IN THE SOFTWARE. ; The implementation below requires SRFI-6 (Basic string ports), ; and SRFI-38 (External Representation for Data With Shared Structure). (library (srfi :48 intermediate-format-strings) (export format) (import (rnrs) (srfi :48 intermediate-format-strings compat) (srfi :6 basic-string-ports) (srfi :38 with-shared-structure)) (define ascii-tab #\tab) (define (format arg0 . arg*) (define (problem msg . irts) (apply assertion-violation 'format msg irts)) (define (_format port format-string args return-value) (define (string-index str c) (let ( [len (string-length str)] ) (let loop ( [i 0] ) (cond ((= i len) #f) ((eqv? c (string-ref str i)) i) (else (loop (+ i 1))))))) (define (string-grow str len char) (let ( [off (- len (string-length str))] ) (if (positive? off) (string-append (make-string off char) str) str))) (define (compose-with-digits digits pre-str frac-str exp-str) (let ( [frac-len (string-length frac-str)] ) ;;@@DEBUG ;;(format #t "~%@@(compose-with-digits digits=~s pre-str=~s frac-str=~s exp-str=~s ) ~%" digits pre-str frac-str exp-str) (cond [(< frac-len digits) ;; grow frac part, pad with zeros (string-append pre-str "." frac-str (make-string (- digits frac-len) #\0) exp-str) ] [(= frac-len digits) ;; frac-part is exactly the right size (string-append pre-str "." frac-str exp-str) ] [else ;; must round to shrink frac-part (let* ( [first-part (substring frac-str 0 digits)] [last-part (substring frac-str digits frac-len)] ;; NB: Scheme uses "Round to Even Rule" for .5 [rounded-frac ;; NB: exact is r6; r5 is inexact->exact (exact (round (string->number (string-append first-part "." last-part)))) ] [rounded-frac-str (number->string rounded-frac)] [rounded-frac-len (string-length rounded-frac-str)] [carry? (and (not (zero? rounded-frac)) (> rounded-frac-len digits)) ] [new-frac (let ( (pre-frac (if carry? ;; trim leading "1" (substring rounded-frac-str 1 (min rounded-frac-len digits)) (substring rounded-frac-str 0 (min rounded-frac-len digits))) ;; may be zero length ) ) (if (< (string-length pre-frac) digits) (string-grow pre-frac digits #\0) pre-frac)) ] ) ;;@@DEBUG ;;(format #t "@@ first-part=~s last-part=~s rounded-frac=~s carry?=~s ~%" first-part last-part rounded-frac carry?) (string-append (if carry? (number->string (+ 1 (string->number pre-str))) pre-str) "." new-frac exp-str))] ) ) ) (define (format-fixed number-or-string width digits) ; returns a string ;;@@DEBUG ;;(format #t "~%(format-fixed number-or-string=~s width=~s digits=~s)~%" number-or-string width digits) (cond [(string? number-or-string) (string-grow number-or-string width #\space) ] [(number? number-or-string) (let* ( [num (real-part number-or-string)] [real (if digits (+ 0.0 num) num)] [imag (imag-part number-or-string)] ) (cond [(not (zero? imag)) (string-grow (string-append (format-fixed real 0 digits) (if (negative? imag) "" "+") (format-fixed imag 0 digits) "i") width #\space) ] [digits (let* ( [num-str (number->string (if (rational? real) (+ 0.0 real) real))] [dot-index (string-index num-str #\.)] [exp-index (string-index num-str #\e)] [length (string-length num-str)] [pre-string (cond ((and exp-index (not dot-index)) (substring num-str 0 exp-index) ) (dot-index (substring num-str 0 dot-index) ) (else num-str)) ] [exp-string (if exp-index (substring num-str exp-index length) "") ] [frac-string (let ( (dot-idx (if dot-index dot-index -1)) ) (if exp-index (substring num-str (+ dot-idx 1) exp-index) (substring num-str (+ dot-idx 1) length))) ] ) (string-grow (if dot-index (compose-with-digits digits pre-string frac-string exp-string) (string-append pre-string exp-string)) width #\space) )] [else ;; no digits (string-grow (number->string real) width #\space)]) )] [else (error 'format "~F requires a number or a string" number-or-string)]) ) (define documentation-string "(format [<port>] <format-string> [<arg>...]) -- <port> is #t, #f or an output-port OPTION [MNEMONIC] DESCRIPTION -- Implementation Assumes ASCII Text Encoding ~H [Help] output this text ~A [Any] (display arg) for humans ~S [Slashified] (write arg) for parsers ~W [WriteCircular] like ~s but outputs circular and recursive data structures ~~ [tilde] output a tilde ~T [Tab] output a tab character ~% [Newline] output a newline character ~& [Freshline] output a newline character if the previous output was not a newline ~D [Decimal] the arg is a number which is output in decimal radix ~X [heXadecimal] the arg is a number which is output in hexdecimal radix ~O [Octal] the arg is a number which is output in octal radix ~B [Binary] the arg is a number which is output in binary radix ~w,dF [Fixed] the arg is a string or number which has width w and d digits after the decimal ~C [Character] charater arg is output by write-char ~_ [Space] a single space character is output ~Y [Yuppify] the list arg is pretty-printed to the output ~? [Indirection] recursive format: next 2 args are format-string and list of arguments ~K [Indirection] same as ~? " ) (define (require-an-arg args) (when (null? args) (problem "too few arguments")) ) (define (format-help p format-strg arglist) (letrec ( [length-of-format-string (string-length format-strg)] [anychar-dispatch (lambda (pos arglist last-was-newline) (if (>= pos length-of-format-string) arglist ; return unused args (let ( [char (string-ref format-strg pos)] ) (cond [(eqv? char #\~) (tilde-dispatch (+ pos 1) arglist last-was-newline)] [else (write-char char p) (anychar-dispatch (+ pos 1) arglist #f) ]) ))) ] ; end anychar-dispatch [has-newline? (lambda (whatever last-was-newline) (or (eqv? whatever #\newline) (and (string? whatever) (let ( [len (string-length whatever)] ) (if (zero? len) last-was-newline (eqv? #\newline (string-ref whatever (- len 1))))))) )] ; end has-newline? [tilde-dispatch (lambda (pos arglist last-was-newline) (cond ((>= pos length-of-format-string) (write-char #\~ p) ; tilde at end of string is just output arglist ; return unused args ) (else (case (char-upcase (string-ref format-strg pos)) ((#\A) ; Any -- for humans (require-an-arg arglist) (let ( [whatever (car arglist)] ) (display whatever p) (anychar-dispatch (+ pos 1) (cdr arglist) (has-newline? whatever last-was-newline)) )) ((#\S) ; Slashified -- for parsers (require-an-arg arglist) (let ( [whatever (car arglist)] ) (write whatever p) (anychar-dispatch (+ pos 1) (cdr arglist) (has-newline? whatever last-was-newline)) )) ((#\W) (require-an-arg arglist) (let ( [whatever (car arglist)] ) (write-with-shared-structure whatever p) ;; srfi-38 (anychar-dispatch (+ pos 1) (cdr arglist) (has-newline? whatever last-was-newline)) )) ((#\D) ; Decimal (require-an-arg arglist) (display (number->string (car arglist) 10) p) (anychar-dispatch (+ pos 1) (cdr arglist) #f) ) ((#\X) ; HeXadecimal (require-an-arg arglist) (display (number->string (car arglist) 16) p) (anychar-dispatch (+ pos 1) (cdr arglist) #f) ) ((#\O) ; Octal (require-an-arg arglist) (display (number->string (car arglist) 8) p) (anychar-dispatch (+ pos 1) (cdr arglist) #f) ) ((#\B) ; Binary (require-an-arg arglist) (display (number->string (car arglist) 2) p) (anychar-dispatch (+ pos 1) (cdr arglist) #f) ) ((#\C) ; Character (require-an-arg arglist) (write-char (car arglist) p) (anychar-dispatch (+ pos 1) (cdr arglist) (eqv? (car arglist) #\newline)) ) ((#\~) ; Tilde (write-char #\~ p) (anychar-dispatch (+ pos 1) arglist #f) ) ((#\%) ; Newline (newline p) (anychar-dispatch (+ pos 1) arglist #t) ) ((#\&) ; Freshline (if (not last-was-newline) ;; (unless last-was-newline .. (newline p)) (anychar-dispatch (+ pos 1) arglist #t) ) ((#\_) ; Space (write-char #\space p) (anychar-dispatch (+ pos 1) arglist #f) ) ((#\T) ; Tab -- IMPLEMENTATION DEPENDENT ENCODING (write-char ascii-tab p) (anychar-dispatch (+ pos 1) arglist #f) ) ((#\Y) ; Pretty-print (pretty-print (car arglist) p) (anychar-dispatch (+ pos 1) (cdr arglist) #f) ) ((#\F) (require-an-arg arglist) (display (format-fixed (car arglist) 0 #f) p) (anychar-dispatch (+ pos 1) (cdr arglist) #f) ) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) ;; gather "~w[,d]F" w and d digits (let loop ( [index (+ pos 1)] [w-digits (list (string-ref format-strg pos))] [d-digits '()] [in-width? #t] ) (if (>= index length-of-format-string) (problem "improper numeric format directive" format-strg) (let ( [next-char (string-ref format-strg index)] ) (cond [(char-numeric? next-char) (if in-width? (loop (+ index 1) (cons next-char w-digits) d-digits in-width?) (loop (+ index 1) w-digits (cons next-char d-digits) in-width?)) ] [(char=? (char-upcase next-char) #\F) (let ( [width (string->number (list->string (reverse w-digits))) ] [digits (if (zero? (length d-digits)) #f (string->number (list->string (reverse d-digits))))] ) (display (format-fixed (car arglist) width digits) p) (anychar-dispatch (+ index 1) (cdr arglist) #f)) ] [(char=? next-char #\,) (if in-width? (loop (+ index 1) w-digits d-digits #f) (problem "too many commas in directive" format-strg)) ] [else (problem "~w,dF directive ill-formed" format-strg)]))) )) ((#\? #\K) ; indirection -- take next arg as format string (cond ; and following arg as list of format args ((< (length arglist) 2) (problem "less arguments than specified for ~?" arglist) ) ((not (string? (car arglist))) (problem "~? requires a string" (car arglist)) ) (else (format-help p (car arglist) (cadr arglist)) (anychar-dispatch (+ pos 1) (cddr arglist) #f) ))) ((#\H) ; Help (display documentation-string p) (anychar-dispatch (+ pos 1) arglist #t) ) (else (problem "unknown tilde escape" (string-ref format-strg pos))) ))) )] ; end tilde-dispatch ) ; end letrec ; format-help body (anychar-dispatch 0 arglist #f) )) ; end format-help ; _format body (let ( [unused-args (format-help port format-string args)] ) (if (not (null? unused-args)) (problem "unused arguments" unused-args) (return-value port)))) ; format body (if (string? arg0) (_format (open-output-string) arg0 arg* get-output-string) (if (null? arg*) (problem "too few arguments" (list arg0)) (let ([port (cond [(eq? arg0 #f) (open-output-string)] [(eq? arg0 #t) (current-output-port)] [(output-port? arg0) arg0] [else (problem "bad output-port argument" arg0)])] [arg1 (car arg*)]) (if (string? arg1) (_format port arg1 (cdr arg*) (if arg0 (lambda (ignore) (values)) get-output-string)) (problem "not a string" arg1)))))) ) �������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a48/intermediate-format-strings/���������������������������0000775�0000000�0000000�00000000000�13751542066�0025075�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a48/intermediate-format-strings/compat.chezscheme.sls������0000664�0000000�0000000�00000001646�13751542066�0031227�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;; Copyright (c) 2012 Aaron W. Hsu <arcfide@sacrideo.us> ;;; ;;; Permission to use, copy, modify, and distribute this software for ;;; any purpose with or without fee is hereby granted, provided that the ;;; above copyright notice and this permission notice appear in all ;;; copies. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE ;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL ;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA ;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR ;;; PERFORMANCE OF THIS SOFTWARE. (library (srfi :48 intermediate-format-strings compat) (export pretty-print) (import (only (chezscheme) pretty-print))) ������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a48/intermediate-format-strings/compat.guile.sls�����������0000664�0000000�0000000�00000000154�13751542066�0030207�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi srfi-48 compat) (export pretty-print) (import (only (ice-9 pretty-print) pretty-print))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a48/intermediate-format-strings/compat.ikarus.sls����������0000664�0000000�0000000�00000000437�13751542066�0030404�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :48 intermediate-format-strings compat) (export pretty-print) (import (only (ikarus) pretty-print)) ) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a48/intermediate-format-strings/compat.ironscheme.sls������0000664�0000000�0000000�00000000674�13751542066�0031245�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an ;; MIT-style license. My license is in the file named LICENSE from the original ;; collection this file is distributed with. If this file is redistributed with ;; some other collection, my license must also be included. (library (srfi :48 intermediate-format-strings compat) (export pretty-print) (import (only (ironscheme) pretty-print)) ) ��������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a48/intermediate-format-strings/compat.larceny.sls���������0000664�0000000�0000000�00000000434�13751542066�0030540�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :48 intermediate-format-strings compat) (export pretty-print) (import (primitives pretty-print)) ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a48/intermediate-format-strings/compat.mzscheme.sls��������0000664�0000000�0000000�00000000446�13751542066�0030721�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :48 intermediate-format-strings compat) (export pretty-print) (import (only (scheme pretty) pretty-print)) ) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a48/intermediate-format-strings/compat.ypsilon.sls���������0000664�0000000�0000000�00000000435�13751542066�0030601�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :48 intermediate-format-strings compat) (export pretty-print) (import (only (core) pretty-print)) ) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a5.sls�����������������������������������������������������0000664�0000000�0000000�00000000070�13751542066�0020077�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi :5) (export let) (import (srfi :5 let))) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a5/��������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017357�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a5/let.sls�������������������������������������������������0000664�0000000�0000000�00000002470�13751542066�0020671�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Copyright © 2020 Göran Weinholt ;; SPDX-License-Identifier: MIT #!r6rs ;; SRFI 5: let form with define-style syntax and rest arguments (library (srfi :5 let) (export let) (import (rename (rnrs) (let rnrs:let))) (define-syntax let (lambda (x) (define (let-args x) (syntax-case x () ;; Push lhs and rhs to the end of lhs* and rhs*, respectively [(_ ((lhs rhs) . x*) (lhs* ...) (rhs* ...)) (identifier? #'lhs) (let-args #'(_ x* (lhs* ... lhs) (rhs* ... rhs)))] ;; Finally handle the rest arguments, if any [(_ (rest arg* ...) (lhs* ...) (rhs* ...)) (identifier? #'rest) #'((lhs* ... . rest) (rhs* ... arg* ...))] [(_ () lhs* rhs*) #'(lhs* rhs*)])) (syntax-case x () ;; Named let [(_ name bindings body ...) (identifier? #'name) (with-syntax ([(lhs* rhs*) (let-args #'(let-args bindings () ()))]) #'((letrec ((name (lambda lhs* body ...))) name) . rhs*))] ;; Define-style named let [(_ (name . bindings) body ...) (identifier? #'name) #'(let name bindings body ...)] ;; Let, possibly with rest arguments [(_ bindings body ...) (with-syntax ([(lhs* rhs*) (let-args #'(let-args bindings () ()))]) #'((lambda lhs* body ...) . rhs*))])))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a51.sls����������������������������������������������������0000664�0000000�0000000�00000000216�13751542066�0020162�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi :51) (export rest-values arg-and arg-ands err-and err-ands arg-or arg-ors err-or err-ors) (import (srfi :51 rest-values))) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a51/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017440�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a51/rest-values.sls����������������������������������������0000664�0000000�0000000�00000000444�13751542066�0022437�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi :51 rest-values) (export rest-values arg-and arg-ands err-and err-ands arg-or arg-ors err-or err-ors) (import (except (rnrs) error) (only (srfi :1) every append-reverse) (srfi :23) (srfi private include)) (include/resolve ("srfi" "%3a51") "srfi-51-impl.scm")) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a51/srfi-51-impl.scm���������������������������������������0000664�0000000�0000000�00000023021�13751542066�0022267�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; ;; Reference implementation of SRFI 51 ;; ;; Copyright (C) Joo ChurlSoo (2004). All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to ;; deal in the Software without restriction, including without limitation the ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or ;; sell copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;; IN THE SOFTWARE. ;; (define (rest-values rest . default) (let* ((caller (if (or (null? default) (boolean? (car default)) (integer? (car default)) (memq (car default) (list + -))) '() (if (string? rest) rest (list rest)))) (rest-list (if (null? caller) rest (car default))) (rest-length (if (list? rest-list) (length rest-list) (if (string? caller) (error caller rest-list 'rest-list '(list? rest-list)) (apply error "bad rest list" rest-list 'rest-list '(list? rest-list) caller)))) (default (if (null? caller) default (cdr default))) (default-list (if (null? default) default (cdr default))) (default-length (length default-list)) (number (and (not (null? default)) (let ((option (car default))) (or (and (integer? option) (or (and (> rest-length (abs option)) (if (string? caller) (error caller rest-list 'rest-list `(<= (length rest-list) ,(abs option))) (apply error "too many arguments" rest-list 'rest-list `(<= (length rest-list) ,(abs option)) caller))) (and (> default-length (abs option)) (if (string? caller) (error caller default-list 'default-list `(<= (length default-list) ,(abs option))) (apply error "too many defaults" default-list 'default-list `(<= (length default-list) ,(abs option)) caller))) option)) (eq? option #t) (and (not option) 'false) (and (eq? option +) +) (and (eq? option -) -) (if (string? caller) (error caller option 'option '(or (boolean? option) (integer? option) (memq option (list + -)))) (apply error "bad optional argument" option 'option '(or (boolean? option) (integer? option) (memq option (list + -))) caller))))))) (cond ((or (eq? #t number) (eq? 'false number)) (and (not (every pair? default-list)) (if (string? caller) (error caller default-list 'default-list '(every pair? default-list)) (apply error "bad default list" default-list 'default-list '(every pair? default-list) caller))) (let loop ((rest-list rest-list) (default-list default-list) (result '())) (if (null? default-list) (if (null? rest-list) (apply values (reverse result)) (if (eq? #t number) (if (string? caller) (error caller rest-list 'rest-list '(null? rest-list)) (apply error "bad argument" rest-list 'rest-list '(null? rest-list) caller)) (apply values (append-reverse result rest-list)))) (if (null? rest-list) (apply values (append-reverse result (map car default-list))) (let ((default (car default-list))) (let lp ((rest rest-list) (head '())) (if (null? rest) (loop (reverse head) (cdr default-list) (cons (car default) result)) (if (list? default) (if (member (car rest) default) (loop (append-reverse head (cdr rest)) (cdr default-list) (cons (car rest) result)) (lp (cdr rest) (cons (car rest) head))) (if ((cdr default) (car rest)) (loop (append-reverse head (cdr rest)) (cdr default-list) (cons (car rest) result)) (lp (cdr rest) (cons (car rest) head))))))))))) ((or (and (integer? number) (> number 0)) (eq? number +)) (and (not (every pair? default-list)) (if (string? caller) (error caller default-list 'default-list '(every pair? default-list)) (apply error "bad default list" default-list 'default-list '(every pair? default-list) caller))) (let loop ((rest rest-list) (default default-list)) (if (or (null? rest) (null? default)) (apply values (if (> default-length rest-length) (append rest-list (map car (list-tail default-list rest-length))) rest-list)) (let ((arg (car rest)) (par (car default))) (if (list? par) (if (member arg par) (loop (cdr rest) (cdr default)) (if (string? caller) (error caller arg 'arg `(member arg ,par)) (apply error "unmatched argument" arg 'arg `(member arg ,par) caller))) (if ((cdr par) arg) (loop (cdr rest) (cdr default)) (if (string? caller) (error caller arg 'arg `(,(cdr par) arg)) (apply error "incorrect argument" arg 'arg `(,(cdr par) arg) caller)))))))) (else (apply values (if (> default-length rest-length) (append rest-list (list-tail default-list rest-length)) rest-list)))))) (define-syntax arg-and (syntax-rules() ((arg-and arg (a1 a2 ...) ...) (and (or (symbol? 'arg) (error "bad syntax" 'arg '(symbol? 'arg) '(arg-and arg (a1 a2 ...) ...))) (or (a1 a2 ...) (error "incorrect argument" arg 'arg '(a1 a2 ...))) ...)) ((arg-and caller arg (a1 a2 ...) ...) (and (or (symbol? 'arg) (error "bad syntax" 'arg '(symbol? 'arg) '(arg-and caller arg (a1 a2 ...) ...))) (or (a1 a2 ...) (if (string? caller) (error caller arg 'arg '(a1 a2 ...)) (error "incorrect argument" arg 'arg '(a1 a2 ...) caller))) ...)))) ;; accessory macro for arg-ands (define-syntax caller-arg-and (syntax-rules() ((caller-arg-and caller arg (a1 a2 ...) ...) (and (or (symbol? 'arg) (error "bad syntax" 'arg '(symbol? 'arg) '(caller-arg-and caller arg (a1 a2 ...) ...))) (or (a1 a2 ...) (if (string? caller) (error caller arg 'arg '(a1 a2 ...)) (error "incorrect argument" arg 'arg '(a1 a2 ...) caller))) ...)) ((caller-arg-and null caller arg (a1 a2 ...) ...) (and (or (symbol? 'arg) (error "bad syntax" 'arg '(symbol? 'arg) '(caller-arg-and caller arg (a1 a2 ...) ...))) (or (a1 a2 ...) (if (string? caller) (error caller arg 'arg '(a1 a2 ...)) (error "incorrect argument" arg 'arg '(a1 a2 ...) caller))) ...)))) (define-syntax arg-ands (syntax-rules (common) ((arg-ands (a1 a2 ...) ...) (and (arg-and a1 a2 ...) ...)) ((arg-ands common caller (a1 a2 ...) ...) (and (caller-arg-and caller a1 a2 ...) ...)))) (define-syntax arg-or (syntax-rules() ((arg-or arg (a1 a2 ...) ...) (or (and (not (symbol? 'arg)) (error "bad syntax" 'arg '(symbol? 'arg) '(arg-or arg (a1 a2 ...) ...))) (and (a1 a2 ...) (error "incorrect argument" arg 'arg '(a1 a2 ...))) ...)) ((arg-or caller arg (a1 a2 ...) ...) (or (and (not (symbol? 'arg)) (error "bad syntax" 'arg '(symbol? 'arg) '(arg-or caller arg (a1 a2 ...) ...))) (and (a1 a2 ...) (if (string? caller) (error caller arg 'arg '(a1 a2 ...)) (error "incorrect argument" arg 'arg '(a1 a2 ...) caller))) ...)))) ;; accessory macro for arg-ors (define-syntax caller-arg-or (syntax-rules() ((caller-arg-or caller arg (a1 a2 ...) ...) (or (and (not (symbol? 'arg)) (error "bad syntax" 'arg '(symbol? 'arg) '(caller-arg-or caller arg (a1 a2 ...) ...))) (and (a1 a2 ...) (if (string? caller) (error caller arg 'arg '(a1 a2 ...)) (error "incorrect argument" arg 'arg '(a1 a2 ...) caller))) ...)) ((caller-arg-or null caller arg (a1 a2 ...) ...) (or (and (not (symbol? 'arg)) (error "bad syntax" 'arg '(symbol? 'arg) '(caller-arg-or caller arg (a1 a2 ...) ...))) (and (a1 a2 ...) (if (string? caller) (error caller arg 'arg '(a1 a2 ...)) (error "incorrect argument" arg 'arg '(a1 a2 ...) caller))) ...)))) (define-syntax arg-ors (syntax-rules (common) ((arg-ors (a1 a2 ...) ...) (or (arg-or a1 a2 ...) ...)) ((arg-ors common caller (a1 a2 ...) ...) (or (caller-arg-or caller a1 a2 ...) ...)))) (define-syntax err-and (syntax-rules () ((err-and err expression ...) (and (or expression (if (string? err) (error err 'expression) (error "false expression" 'expression err))) ...)))) (define-syntax err-ands (syntax-rules () ((err-ands (err expression ...) ...) (and (err-and err expression ...) ...)))) (define-syntax err-or (syntax-rules () ((err-or err expression ...) (or (and expression (if (string? err) (error err 'expression) (error "true expression" 'expression err))) ...)))) (define-syntax err-ors (syntax-rules () ((err-ors (err expression ...) ...) (or (err-or err expression ...) ...)))) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a54.sls����������������������������������������������������0000664�0000000�0000000�00000000076�13751542066�0020171�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi :54) (export cat) (import (srfi :54 cat))) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a54/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017443�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a54/cat.sls������������������������������������������������0000664�0000000�0000000�00000000272�13751542066�0020736�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi :54 cat) (export cat) (import (except (rnrs) error) (rnrs r5rs) (srfi :23) (srfi private include)) (include/resolve ("srfi" "%3a54") "srfi-54-impl.scm")) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a54/srfi-54-impl.scm���������������������������������������0000664�0000000�0000000�00000030611�13751542066�0022300�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; ;; SRFI 54 Reference Implementation ;; ;; Copyright (C) Joo ChurlSoo (2004). All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to ;; deal in the Software without restriction, including without limitation the ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or ;; sell copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS ;; IN THE SOFTWARE. ;; ;; 01/07/2018 - AWK - updated get-output-string/open-output-string, ;; exact->inexact, and inexact->exact to R6RS equivalent (define (cat object . rest) (let* ((str-rest (part string? rest)) (str-list (car str-rest)) (rest-list (cdr str-rest))) (if (null? rest-list) (apply string-append (cond ((number? object) (number->string object)) ((string? object) object) ((char? object) (string object)) ((boolean? object) (if object "#t" "#f")) ((symbol? object) (symbol->string object)) (else (let-values (((str-port p) (open-string-output-port))) (write object str-port) (p)))) str-list) (alet-cat* rest-list ((width 0 (and (integer? width) (exact? width))) (port #f (or (boolean? port) (output-port? port)) (if (eq? port #t) (current-output-port) port)) (char #\space (char? char)) (converter #f (and (pair? converter) (procedure? (car converter)) (procedure? (cdr converter)))) (precision #f (and (integer? precision) (inexact? precision))) (sign #f (eq? 'sign sign)) (radix 'decimal (memq radix '(decimal octal binary hexadecimal))) (exactness #f (memq exactness '(exact inexact))) (separator #f (and (list? separator) (< 0 (length separator) 3) (char? (car separator)) (or (null? (cdr separator)) (let ((n (cadr separator))) (and (integer? n) (exact? n) (< 0 n)))))) (writer #f (procedure? writer)) (pipe #f (and (list? pipe) (not (null? pipe)) (every? procedure? pipe))) (take #f (and (list? take) (< 0 (length take) 3) (every? (lambda (x) (and (integer? x) (exact? x))) take)))) (let* ((str (cond ((and converter ((car converter) object)) (let* ((str ((cdr converter) object)) (pad (- (abs width) (string-length str)))) (cond ((<= pad 0) str) ((< 0 width) (string-append (make-string pad char) str)) (else (string-append str (make-string pad char)))))) ((number? object) (and (not (eq? radix 'decimal)) precision (error "cat: non-decimal cannot have a decimal point")) (and precision (< precision 0) (eq? exactness 'exact) (error "cat: exact number cannot have a decimal point without exact sign")) (let* ((exact-sign (and precision (<= 0 precision) (or (eq? exactness 'exact) (and (exact? object) (not (eq? exactness 'inexact)))) "#e")) (inexact-sign (and (not (eq? radix 'decimal)) (or (and (inexact? object) (not (eq? exactness 'exact))) (eq? exactness 'inexact)) "#i")) (radix-sign (cdr (assq radix '((decimal . #f) (octal . "#o") (binary . "#b") (hexadecimal . "#x"))))) (plus-sign (and sign (< 0 (real-part object)) "+")) (exactness-sign (or exact-sign inexact-sign)) (str (if precision (let ((precision (exact (abs precision))) (imag (imag-part object))) (if (= 0 imag) (e-mold object precision) (string-append (e-mold (real-part object) precision) (if (< 0 imag) "+" "") (e-mold imag precision) "i"))) (number->string (cond (inexact-sign (exact object)) (exactness (if (eq? exactness 'exact) (exact object) (inexact object))) (else object)) (cdr (assq radix '((decimal . 10) (octal . 8) (binary . 2) (hexadecimal . 16))))))) (str (if (and separator (not (or (and (eq? radix 'decimal) (str-index str #\e)) (str-index str #\i) (str-index str #\/)))) (let ((sep (string (car separator))) (num (if (null? (cdr separator)) 3 (cadr separator))) (dot-index (str-index str #\.))) (if dot-index (string-append (separate (substring str 0 dot-index) sep num (if (< object 0) 'minus #t)) "." (separate (substring str (+ 1 dot-index) (string-length str)) sep num #f)) (separate str sep num (if (< object 0) 'minus #t)))) str)) (pad (- (abs width) (+ (string-length str) (if exactness-sign 2 0) (if radix-sign 2 0) (if plus-sign 1 0)))) (pad (if (< 0 pad) pad 0))) (if (< 0 width) (if (char-numeric? char) (if (< (real-part object) 0) (string-append (or exactness-sign "") (or radix-sign "") "-" (make-string pad char) (substring str 1 (string-length str))) (string-append (or exactness-sign "") (or radix-sign "") (or plus-sign "") (make-string pad char) str)) (string-append (make-string pad char) (or exactness-sign "") (or radix-sign "") (or plus-sign "") str)) (string-append (or exactness-sign "") (or radix-sign "") (or plus-sign "") str (make-string pad char))))) (else (let* ((str (cond (writer (let-values (((str-port p) (open-string-output-port))) (writer object str-port) (p))) ((string? object) object) ((char? object) (string object)) ((boolean? object) (if object "#t" "#f")) ((symbol? object) (symbol->string object)) (else (let-values (((str-port p) (open-string-output-port))) (write object str-port) (p))))) (str (if pipe (let loop ((str ((car pipe) str)) (fns (cdr pipe))) (if (null? fns) str (loop ((car fns) str) (cdr fns)))) str)) (str (if take (let ((left (car take)) (right (if (null? (cdr take)) 0 (cadr take))) (len (string-length str))) (define (substr str beg end) (let ((end (cond ((< end 0) 0) ((< len end) len) (else end))) (beg (cond ((< beg 0) 0) ((< len beg) len) (else beg)))) (if (and (= beg 0) (= end len)) str (substring str beg end)))) (string-append (if (< left 0) (substr str (abs left) len) (substr str 0 left)) (if (< right 0) (substr str 0 (+ len right)) (substr str (- len right) len)))) str)) (pad (- (abs width) (string-length str)))) (cond ((<= pad 0) str) ((< 0 width) (string-append (make-string pad char) str)) (else (string-append str (make-string pad char)))))))) (str (apply string-append str str-list))) (and port (display str port)) str))))) (define-syntax alet-cat* ; borrowed from SRFI-86 (syntax-rules () ((alet-cat* z (a . e) bd ...) (let ((y z)) (%alet-cat* y (a . e) bd ...))))) (define-syntax %alet-cat* ; borrowed from SRFI-86 (syntax-rules () ((%alet-cat* z ((n d t ...)) bd ...) (let ((n (if (null? z) d (if (null? (cdr z)) (wow-cat-end z n t ...) (error "cat: too many arguments" (cdr z)))))) bd ...)) ((%alet-cat* z ((n d t ...) . e) bd ...) (let ((n (if (null? z) d (wow-cat! z n d t ...)))) (%alet-cat* z e bd ...))) ((%alet-cat* z e bd ...) (let ((e z)) bd ...)))) (define-syntax wow-cat! ; borrowed from SRFI-86 (syntax-rules () ((wow-cat! z n d) (let ((n (car z))) (set! z (cdr z)) n)) ((wow-cat! z n d t) (let ((n (car z))) (if t (begin (set! z (cdr z)) n) (let lp ((head (list n)) (tail (cdr z))) (if (null? tail) d (let ((n (car tail))) (if t (begin (set! z (append (reverse head) (cdr tail))) n) (lp (cons n head) (cdr tail))))))))) ((wow-cat! z n d t ts) (let ((n (car z))) (if t (begin (set! z (cdr z)) ts) (let lp ((head (list n)) (tail (cdr z))) (if (null? tail) d (let ((n (car tail))) (if t (begin (set! z (append (reverse head) (cdr tail))) ts) (lp (cons n head) (cdr tail))))))))) ((wow-cat! z n d t ts fs) (let ((n (car z))) (if t (begin (set! z (cdr z)) ts) (begin (set! z (cdr z)) fs)))))) (define-syntax wow-cat-end ; borrowed from SRFI-86 (syntax-rules () ((wow-cat-end z n) (car z)) ((wow-cat-end z n t) (let ((n (car z))) (if t n (error "cat: too many argument" z)))) ((wow-cat-end z n t ts) (let ((n (car z))) (if t ts (error "cat: too many argument" z)))) ((wow-cat-end z n t ts fs) (let ((n (car z))) (if t ts fs))))) (define (str-index str char) (let ((len (string-length str))) (let lp ((n 0)) (and (< n len) (if (char=? char (string-ref str n)) n (lp (+ n 1))))))) (define (every? pred ls) (let lp ((ls ls)) (or (null? ls) (and (pred (car ls)) (lp (cdr ls)))))) (define (part pred ls) (let lp ((ls ls) (true '()) (false '())) (cond ((null? ls) (cons (reverse true) (reverse false))) ((pred (car ls)) (lp (cdr ls) (cons (car ls) true) false)) (else (lp (cdr ls) true (cons (car ls) false)))))) (define (e-mold num pre) (let* ((str (number->string (inexact num))) (e-index (str-index str #\e))) (if e-index (string-append (mold (substring str 0 e-index) pre) (substring str e-index (string-length str))) (mold str pre)))) (define (mold str pre) (let ((ind (str-index str #\.))) (if ind (let ((d-len (- (string-length str) (+ ind 1)))) (cond ((= d-len pre) str) ((< d-len pre) (string-append str (make-string (- pre d-len) #\0))) ;;((char<? #\4 (string-ref str (+ 1 ind pre))) ;;(let ((com (expt 10 pre))) ;; (number->string (/ (round (* (string->number str) com)) com)))) ((or (char<? #\5 (string-ref str (+ 1 ind pre))) (and (char=? #\5 (string-ref str (+ 1 ind pre))) (or (< (+ 1 pre) d-len) (memv (string-ref str (+ ind (if (= 0 pre) -1 pre))) '(#\1 #\3 #\5 #\7 #\9))))) (apply string (let* ((minus (char=? #\- (string-ref str 0))) (str (substring str (if minus 1 0) (+ 1 ind pre))) (char-list (reverse (let lp ((index (- (string-length str) 1)) (raise #t)) (if (= -1 index) (if raise '(#\1) '()) (let ((chr (string-ref str index))) (if (char=? #\. chr) (cons chr (lp (- index 1) raise)) (if raise (if (char=? #\9 chr) (cons #\0 (lp (- index 1) raise)) (cons (integer->char (+ 1 (char->integer chr))) (lp (- index 1) #f))) (cons chr (lp (- index 1) raise)))))))))) (if minus (cons #\- char-list) char-list)))) (else (substring str 0 (+ 1 ind pre))))) (string-append str "." (make-string pre #\0))))) (define (separate str sep num opt) (let* ((len (string-length str)) (pos (if opt (let ((pos (remainder (if (eq? opt 'minus) (- len 1) len) num))) (if (= 0 pos) num pos)) num))) (apply string-append (let loop ((ini 0) (pos (if (eq? opt 'minus) (+ pos 1) pos))) (if (< pos len) (cons (substring str ini pos) (cons sep (loop pos (+ pos num)))) (list (substring str ini len))))))) �����������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a6.sls�����������������������������������������������������0000664�0000000�0000000�00000000323�13751542066�0020101�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :6) (export get-output-string open-input-string open-output-string) (import (srfi :6 basic-string-ports)) ) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a6/��������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017360�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a6/basic-string-ports.mzscheme.sls�������������������������0000664�0000000�0000000�00000002570�13751542066�0025453�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :6 basic-string-ports) (export (rename (open-string-input-port open-input-string)) open-output-string get-output-string) (import (rnrs) (only (scheme base) make-weak-hasheq hash-ref hash-set!)) (define accumed-ht (make-weak-hasheq)) (define (open-output-string) (letrec ((sop (make-custom-textual-output-port "string-output-port" (lambda (string start count) ; write! (when (positive? count) (let ((al (hash-ref accumed-ht sop))) (hash-set! accumed-ht sop (cons (substring string start (+ start count)) al)))) count) #F ; get-position TODO? #F ; set-position! TODO? #F #| closed TODO? |# ))) (hash-set! accumed-ht sop '()) sop)) (define (get-output-string sop) (if (output-port? sop) (cond ((hash-ref accumed-ht sop #F) => (lambda (al) (apply string-append (reverse al)))) (else (assertion-violation 'get-output-string "not a string-output-port" sop))) (assertion-violation 'get-output-string "not an output-port" sop))) ) ����������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a6/basic-string-ports.sls����������������������������������0000664�0000000�0000000�00000000633�13751542066�0023637�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :6 basic-string-ports) (export (rename (open-string-input-port open-input-string)) open-output-string get-output-string) (import (only (rnrs io ports) open-string-input-port) (srfi :6 basic-string-ports compat)) ) �����������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a6/basic-string-ports/�������������������������������������0000775�0000000�0000000�00000000000�13751542066�0023112�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a6/basic-string-ports/compat.chezscheme.sls����������������0000664�0000000�0000000�00000001640�13751542066�0027236�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;; Copyright (c) 2012 Aaron W. Hsu <arcfide@sacrideo.us> ;;; ;;; Permission to use, copy, modify, and distribute this software for ;;; any purpose with or without fee is hereby granted, provided that the ;;; above copyright notice and this permission notice appear in all ;;; copies. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE ;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL ;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA ;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR ;;; PERFORMANCE OF THIS SOFTWARE. (library (srfi :6 basic-string-ports compat) (export open-output-string get-output-string) (import (chezscheme))) ������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a6/basic-string-ports/compat.ikarus.sls��������������������0000664�0000000�0000000�00000000504�13751542066�0026414�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :6 basic-string-ports compat) (export open-output-string get-output-string) (import (only (ikarus) open-output-string get-output-string))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a6/basic-string-ports/compat.ironscheme.sls����������������0000664�0000000�0000000�00000000741�13751542066�0027255�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an ;; MIT-style license. My license is in the file named LICENSE from the original ;; collection this file is distributed with. If this file is redistributed with ;; some other collection, my license must also be included. (library (srfi :6 basic-string-ports compat) (export open-output-string get-output-string) (import (only (ironscheme) open-output-string get-output-string))) �������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a6/basic-string-ports/compat.larceny.sls�������������������0000664�0000000�0000000�00000000512�13751542066�0026552�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :6 basic-string-ports compat) (export open-output-string get-output-string) (import (primitives open-output-string get-output-string)) )��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a6/basic-string-ports/compat.loko.sls����������������������0000664�0000000�0000000�00000000351�13751542066�0026062�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Copyright © 2019 Göran Weinholt ;; SPDX-License-Identifier: MIT #!r6rs (library (srfi :6 basic-string-ports compat) (export open-output-string get-output-string) (import (only (loko) open-output-string get-output-string))) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a6/basic-string-ports/compat.ypsilon.sls�������������������0000664�0000000�0000000�00000000620�13751542066�0026612�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :6 basic-string-ports compat) (export (rename (make-string-output-port open-output-string) (get-accumulated-string get-output-string))) (import (only (core) make-string-output-port get-accumulated-string)) ) ����������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a60.sls����������������������������������������������������0000664�0000000�0000000�00000003137�13751542066�0020167�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; SRFI-60 r6rs library entry ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to ;; deal in the Software without restriction, including without limitation the ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or ;; sell copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL ;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING ;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER ;; DEALINGS IN THE SOFTWARE. (library (srfi :60) (export logand bitwise-and logior bitwise-ior logxor bitwise-xor lognot bitwise-not bitwise-if bitwise-merge logtest any-bits-set? logcount bit-count integer-length log2-binary-factors first-set-bit logbit? bit-set? copy-bit bit-field copy-bit-field ash arithmetic-shift rotate-bit-field reverse-bit-field integer->list integer->list list->integer booleans->integer) (import (srfi :60 integer-bits))) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a60/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017440�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a60/integer-bits.sls���������������������������������������0000664�0000000�0000000�00000006462�13751542066�0022567�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; SRFI-60 R6RS implementation ;; ;; Builds out the SRFI-60 specified bitwise operators using the set of bitwise ;; operators that is part of the standard R6RS library. In some cases these ;; could directly use Chez Scheme library procedures directly, but this library ;; does not do that yet. ;; ;; Copyright (c) 2018 - 2020 Andrew W. Keep (library (srfi :60 integer-bits) (export logand bitwise-and logior bitwise-ior logxor bitwise-xor lognot bitwise-not bitwise-if bitwise-merge logtest any-bits-set? logcount bit-count integer-length log2-binary-factors first-set-bit logbit? bit-set? copy-bit bit-field copy-bit-field ash arithmetic-shift rotate-bit-field reverse-bit-field integer->list integer->list list->integer booleans->integer) (import (rnrs)) (define logand (case-lambda [() (bitwise-and)] [(i) i] [(i j) (bitwise-and i j)] [(i j k) (bitwise-and i j k)] [args (apply bitwise-and args)])) (define logior (case-lambda [() (bitwise-ior)] [(i) i] [(i j) (bitwise-ior i j)] [(i j k) (bitwise-ior i j k)] [args (apply bitwise-ior args)])) (define logxor (case-lambda [() (bitwise-xor)] [(i) i] [(i j) (bitwise-xor i j)] [(i j k) (bitwise-xor i j k)] [args (apply bitwise-xor args)])) (define lognot (lambda (n) (bitwise-not n))) (define bitwise-merge (lambda (m n0 n1) (bitwise-if m n0 n1))) (define logtest (lambda (j k) (not (zero? (logand j k))))) (define any-bits-set? (lambda (j k) (not (zero? (logand j k))))) (define logcount (lambda (n) (if (< n 0) (bitwise-bit-count (bitwise-not n)) (bitwise-bit-count n)))) (define bit-count (lambda (n) (if (< n 0) (bitwise-bit-count (bitwise-not n)) (bitwise-bit-count n)))) (define integer-length (lambda (n) (bitwise-length n))) (define log2-binary-factors (lambda (n) (bitwise-first-bit-set n))) (define first-set-bit (lambda (n) (bitwise-first-bit-set n))) (define logbit? (lambda (i n) (bitwise-bit-set? n i))) (define bit-set? (lambda (i n) (bitwise-bit-set? n i))) (define copy-bit (lambda (i n b) (bitwise-copy-bit n i (if b 1 0)))) (define bit-field (lambda (n s e) (bitwise-bit-field n s e))) (define copy-bit-field (lambda (to from s e) (bitwise-copy-bit-field to s e from))) (define ash (lambda (n count) (bitwise-arithmetic-shift n count))) (define arithmetic-shift (lambda (n count) (bitwise-arithmetic-shift n count))) (define rotate-bit-field (lambda (n count start end) (bitwise-rotate-bit-field n start end count))) (define reverse-bit-field (lambda (n start end) (bitwise-reverse-bit-field n start end))) (define integer->list (case-lambda [(k len) (let loop ([i len] [ls '()]) (if (fx=? i 0) ls (let ([i (fx- i 1)]) (loop i (cons (bitwise-bit-set? k i) ls)))))] [(k) (integer->list k (bitwise-length k))])) (define list->integer (lambda (ls) (let loop ([ls ls] [i 0] [n 0]) (if (null? ls) n (loop (cdr ls) (fx+ i 1) (bitwise-copy-bit n i (if (car ls) 1 0))))))) (define booleans->integer (lambda args (list->integer args)))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a61.sls����������������������������������������������������0000664�0000000�0000000�00000000215�13751542066�0020162�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :61) (export cond) (import (srfi :61 cond)) ) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a61/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017441�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a61/cond.sls�����������������������������������������������0000664�0000000�0000000�00000001713�13751542066�0021111�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :61 cond) (export (rename (general-cond cond))) (import (rnrs)) (define-syntax general-cond (lambda (stx) (syntax-case stx () ((_ clauses ...) (with-syntax (((ours ...) (map (lambda (c) (syntax-case c (=>) ((generator guard => receiver) #'((let-values ((vals generator)) (and (apply guard vals) vals)) => (lambda (vals) (apply receiver vals)))) (_ c))) #'(clauses ...)))) #'(cond ours ...)))))) ) �����������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a64.sls����������������������������������������������������0000664�0000000�0000000�00000003513�13751542066�0020171�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :64) (export test-apply test-approximate test-assert test-begin test-end test-eq test-equal test-eqv test-error test-expect-fail test-group test-group-with-cleanup test-log-to-file test-match-all test-match-any test-match-name test-match-nth test-on-bad-count-simple test-on-bad-end-name-simple test-on-final-simple test-on-group-begin-simple test-on-group-end-simple test-on-test-end-simple test-passed? test-read-eval-string test-result-alist test-result-alist! test-result-clear test-result-kind test-result-ref test-result-remove test-result-set! test-runner-aux-value test-runner-aux-value! test-runner-create test-runner-current test-runner-factory test-runner-fail-count test-runner-fail-count! test-runner-get test-runner-group-path test-runner-group-stack test-runner-group-stack! test-runner-null test-runner-on-bad-count test-runner-on-bad-count! test-runner-on-bad-end-name test-runner-on-bad-end-name! test-runner-on-final test-runner-on-final! test-runner-on-group-begin test-runner-on-group-begin! test-runner-on-group-end test-runner-on-group-end! test-runner-on-test-begin test-runner-on-test-begin! test-runner-on-test-end test-runner-on-test-end! test-runner-pass-count test-runner-pass-count! test-runner-reset test-runner-simple test-runner-skip-count test-runner-skip-count! test-runner-test-name test-runner-xfail-count test-runner-xfail-count! test-runner-xpass-count test-runner-xpass-count! test-runner? test-skip test-with-runner) (import (srfi :64 testing)) ) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a64/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017444�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a64/srfi-64-test.scm���������������������������������������0000664�0000000�0000000�00000063621�13751542066�0022327�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;; ;;; This is a test suite written in the notation of ;;; SRFI-64, A Scheme API for test suites ;;; (test-begin "SRFI 64 - Meta-Test Suite") ;;; ;;; Ironically, in order to set up the meta-test environment, ;;; we have to invoke one of the most sophisticated features: ;;; custom test runners ;;; ;;; The `prop-runner' invokes `thunk' in the context of a new ;;; test runner, and returns the indicated properties of the ;;; last-executed test result. (define (prop-runner props thunk) (let ((r (test-runner-null)) (plist '())) ;; (test-runner-on-test-end! r (lambda (runner) (set! plist (test-result-alist runner)))) ;; (test-with-runner r (thunk)) ;; reorder the properties so they are in the order ;; given by `props'. Note that any property listed in `props' ;; that is not in the property alist will occur as #f (map (lambda (k) (assq k plist)) props))) ;;; `on-test-runner' creates a null test runner and then ;;; arranged for `visit' to be called with the runner ;;; whenever a test is run. The results of the calls to ;;; `visit' are returned in a list (define (on-test-runner thunk visit) (let ((r (test-runner-null)) (results '())) ;; (test-runner-on-test-end! r (lambda (runner) (set! results (cons (visit r) results)))) ;; (test-with-runner r (thunk)) (reverse results))) ;;; ;;; The `triv-runner' invokes `thunk' ;;; and returns a list of 6 lists, the first 5 of which ;;; are a list of the names of the tests that, respectively, ;;; PASS, FAIL, XFAIL, XPASS, and SKIP. ;;; The last item is a list of counts. ;;; (define (triv-runner thunk) (let ((r (test-runner-null)) (accum-pass '()) (accum-fail '()) (accum-xfail '()) (accum-xpass '()) (accum-skip '())) ;; (test-runner-on-bad-count! r (lambda (runner count expected-count) (error (string-append "bad count " (number->string count) " but expected " (number->string expected-count))))) (test-runner-on-bad-end-name! r (lambda (runner begin end) (error (string-append "bad end grojup name " end " but expected " begin)))) (test-runner-on-test-end! r (lambda (runner) (let ((n (test-runner-test-name runner))) (case (test-result-kind runner) ((pass) (set! accum-pass (cons n accum-pass))) ((fail) (set! accum-fail (cons n accum-fail))) ((xpass) (set! accum-xpass (cons n accum-xpass))) ((xfail) (set! accum-xfail (cons n accum-xfail))) ((skip) (set! accum-skip (cons n accum-skip))))))) ;; (test-with-runner r (thunk)) (list (reverse accum-pass) ; passed as expected (reverse accum-fail) ; failed, but was expected to pass (reverse accum-xfail) ; failed as expected (reverse accum-xpass) ; passed, but was expected to fail (reverse accum-skip) ; was not executed (list (test-runner-pass-count r) (test-runner-fail-count r) (test-runner-xfail-count r) (test-runner-xpass-count r) (test-runner-skip-count r))))) (define (path-revealing-runner thunk) (let ((r (test-runner-null)) (seq '())) ;; (test-runner-on-test-end! r (lambda (runner) (set! seq (cons (list (test-runner-group-path runner) (test-runner-test-name runner)) seq)))) (test-with-runner r (thunk)) (reverse seq))) ;;; ;;; Now we can start testing compliance with SRFI-64 ;;; (test-begin "1. Simple test-cases") (test-begin "1.1. test-assert") (define (t) (triv-runner (lambda () (test-assert "a" #t) (test-assert "b" #f)))) (test-equal "1.1.1. Very simple" '(("a") ("b") () () () (1 1 0 0 0)) (t)) (test-equal "1.1.2. A test with no name" '(("a") ("") () () () (1 1 0 0 0)) (triv-runner (lambda () (test-assert "a" #t) (test-assert #f)))) (test-equal "1.1.3. Tests can have the same name" '(("a" "a") () () () () (2 0 0 0 0)) (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t)))) (define (choke) (vector-ref '#(1 2) 3)) (test-equal "1.1.4. One way to FAIL is to throw an error" '(() ("a") () () () (0 1 0 0 0)) (triv-runner (lambda () (test-assert "a" (choke))))) (test-end);1.1 (test-begin "1.2. test-eqv") (define (mean x y) (/ (+ x y) 2.0)) (test-equal "1.2.1. Simple numerical equivalence" '(("c") ("a" "b") () () () (1 2 0 0 0)) (triv-runner (lambda () (test-eqv "a" (mean 3 5) 4) (test-eqv "b" (mean 3 5) 4.5) (test-eqv "c" (mean 3 5) 4.0)))) (test-end);1.2 (test-end "1. Simple test-cases") ;;; ;;; ;;; (test-begin "2. Tests for catching errors") (test-begin "2.1. test-error") (test-equal "2.1.1. Baseline test; PASS with no optional args" '(("") () () () () (1 0 0 0 0)) (triv-runner (lambda () ;; PASS (test-error (vector-ref '#(1 2) 9))))) (test-equal "2.1.2. Baseline test; FAIL with no optional args" '(() ("") () () () (0 1 0 0 0)) (triv-runner (lambda () ;; FAIL: the expr does not raise an error and `test-error' is ;; claiming that it will, so this test should FAIL (test-error (vector-ref '#(1 2) 0))))) (test-equal "2.1.3. PASS with a test name and error type" '(("a") () () () () (1 0 0 0 0)) (triv-runner (lambda () ;; PASS (test-error "a" #t (vector-ref '#(1 2) 9))))) (test-end "2.1. test-error") (test-end "2. Tests for catching errors") ;;; ;;; ;;; (test-begin "3. Test groups and paths") (test-equal "3.1. test-begin with unspecific test-end" '(("b") () () () () (1 0 0 0 0)) (triv-runner (lambda () (test-begin "a") (test-assert "b" #t) (test-end)))) (test-equal "3.2. test-begin with name-matching test-end" '(("b") () () () () (1 0 0 0 0)) (triv-runner (lambda () (test-begin "a") (test-assert "b" #t) (test-end "a")))) ;;; since the error raised by `test-end' on a mismatch is not a test ;;; error, we actually expect the triv-runner itself to fail (test-error "3.3. test-begin with mismatched test-end" #t (triv-runner (lambda () (test-begin "a") (test-assert "b" #t) (test-end "x")))) (test-equal "3.4. test-begin with name and count" '(("b" "c") () () () () (2 0 0 0 0)) (triv-runner (lambda () (test-begin "a" 2) (test-assert "b" #t) (test-assert "c" #t) (test-end "a")))) ;; similarly here, a mismatched count is a lexical error ;; and not a test failure... (test-error "3.5. test-begin with mismatched count" #t (triv-runner (lambda () (test-begin "a" 99) (test-assert "b" #t) (test-end "a")))) (test-equal "3.6. introspecting on the group path" '((() "w") (("a" "b") "x") (("a" "b") "y") (("a") "z")) ;; ;; `path-revealing-runner' is designed to return a list ;; of the tests executed, in order. Each entry is a list ;; (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list ;; of test groups starting from the topmost ;; (path-revealing-runner (lambda () (test-assert "w" #t) (test-begin "a") (test-begin "b") (test-assert "x" #t) (test-assert "y" #t) (test-end) (test-assert "z" #t)))) (test-end "3. Test groups and paths") ;;; ;;; ;;; (test-begin "4. Handling set-up and cleanup") (test-equal "4.1. Normal exit path" '(in 1 2 out) (let ((ex '())) (define (do s) (set! ex (cons s ex))) ;; (triv-runner (lambda () (test-group-with-cleanup "foo" (do 'in) (do 1) (do 2) (do 'out)))) (reverse ex))) (test-equal "4.2. Exception exit path" '(in 1 out) (let ((ex '())) (define (do s) (set! ex (cons s ex))) ;; ;; the outer runner is to run the `test-error' in, to ;; catch the exception raised in the inner runner, ;; since we don't want to depend on any other ;; exception-catching support ;; (triv-runner (lambda () (test-error (triv-runner (lambda () (test-group-with-cleanup "foo" (do 'in) (test-assert #t) (do 1) (test-assert #t) (choke) (test-assert #t) (do 2) (test-assert #t) (do 'out))))))) (reverse ex))) (test-end "4. Handling set-up and cleanup") ;;; ;;; ;;; (test-begin "5. Test specifiers") (test-begin "5.1. test-match-named") (test-equal "5.1.1. match test names" '(("y") () () () ("x") (1 0 0 0 1)) (triv-runner (lambda () (test-skip (test-match-name "x")) (test-assert "x" #t) (test-assert "y" #t)))) (test-equal "5.1.2. but not group names" '(("z") () () () () (1 0 0 0 0)) (triv-runner (lambda () (test-skip (test-match-name "x")) (test-begin "x") (test-assert "z" #t) (test-end)))) (test-end) (test-begin "5.2. test-match-nth") ;; See also: [6.4. Short-circuit evaluation] (test-equal "5.2.1. skip the nth one after" '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) (triv-runner (lambda () (test-assert "v" #t) (test-skip (test-match-nth 2)) (test-assert "w" #t) ; 1 (test-assert "x" #t) ; 2 SKIP (test-assert "y" #t) ; 3 (test-assert "z" #t)))) ; 4 (test-equal "5.2.2. skip m, starting at n" '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) (triv-runner (lambda () (test-assert "v" #t) (test-skip (test-match-nth 2 2)) (test-assert "w" #t) ; 1 (test-assert "x" #t) ; 2 SKIP (test-assert "y" #t) ; 3 SKIP (test-assert "z" #t)))) ; 4 (test-end) (test-begin "5.3. test-match-any") (test-equal "5.3.1. basic disjunction" '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) (triv-runner (lambda () (test-assert "v" #t) (test-skip (test-match-any (test-match-nth 3) (test-match-name "x"))) (test-assert "w" #t) ; 1 (test-assert "x" #t) ; 2 SKIP(NAME) (test-assert "y" #t) ; 3 SKIP(COUNT) (test-assert "z" #t)))) ; 4 (test-equal "5.3.2. disjunction is commutative" '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) (triv-runner (lambda () (test-assert "v" #t) (test-skip (test-match-any (test-match-name "x") (test-match-nth 3))) (test-assert "w" #t) ; 1 (test-assert "x" #t) ; 2 SKIP(NAME) (test-assert "y" #t) ; 3 SKIP(COUNT) (test-assert "z" #t)))) ; 4 (test-end) (test-begin "5.4. test-match-all") (test-equal "5.4.1. basic conjunction" '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) (triv-runner (lambda () (test-assert "v" #t) (test-skip (test-match-all (test-match-nth 2 2) (test-match-name "x"))) (test-assert "w" #t) ; 1 (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT) (test-assert "y" #t) ; 3 SKIP(COUNT) (test-assert "z" #t)))) ; 4 (test-equal "5.4.2. conjunction is commutative" '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) (triv-runner (lambda () (test-assert "v" #t) (test-skip (test-match-all (test-match-name "x") (test-match-nth 2 2))) (test-assert "w" #t) ; 1 (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT) (test-assert "y" #t) ; 3 SKIP(COUNT) (test-assert "z" #t)))) ; 4 (test-end) (test-end "5. Test specifiers") ;;; ;;; ;;; (test-begin "6. Skipping selected tests") (test-equal "6.1. Skip by specifier - match-name" '(("x") () () () ("y") (1 0 0 0 1)) (triv-runner (lambda () (test-begin "a") (test-skip (test-match-name "y")) (test-assert "x" #t) ; PASS (test-assert "y" #f) ; SKIP (test-end)))) (test-equal "6.2. Shorthand specifiers" '(("x") () () () ("y") (1 0 0 0 1)) (triv-runner (lambda () (test-begin "a") (test-skip "y") (test-assert "x" #t) ; PASS (test-assert "y" #f) ; SKIP (test-end)))) (test-begin "6.3. Specifier Stack") (test-equal "6.3.1. Clearing the Specifier Stack" '(("x" "x") ("y") () () ("y") (2 1 0 0 1)) (triv-runner (lambda () (test-begin "a") (test-skip "y") (test-assert "x" #t) ; PASS (test-assert "y" #f) ; SKIP (test-end) (test-begin "b") (test-assert "x" #t) ; PASS (test-assert "y" #f) ; FAIL (test-end)))) (test-equal "6.3.2. Inheriting the Specifier Stack" '(("x" "x") () () () ("y" "y") (2 0 0 0 2)) (triv-runner (lambda () (test-skip "y") (test-begin "a") (test-assert "x" #t) ; PASS (test-assert "y" #f) ; SKIP (test-end) (test-begin "b") (test-assert "x" #t) ; PASS (test-assert "y" #f) ; SKIP (test-end)))) (test-end);6.3 (test-begin "6.4. Short-circuit evaluation") (test-equal "6.4.1. In test-match-all" '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1)) (triv-runner (lambda () (test-begin "a") (test-skip (test-match-all "y" (test-match-nth 2))) ;; let's label the substructure forms so we can ;; see which one `test-match-nth' is going to skip ;; ; # "y" 2 result (test-assert "x" #t) ; 1 - #f #f PASS (test-assert "y" #f) ; 2 - #t #t SKIP (test-assert "y" #f) ; 3 - #t #f FAIL (test-assert "x" #f) ; 4 - #f #f FAIL (test-assert "z" #f) ; 5 - #f #f FAIL (test-end)))) (test-equal "6.4.2. In separate skip-list entries" '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2)) (triv-runner (lambda () (test-begin "a") (test-skip "y") (test-skip (test-match-nth 2)) ;; let's label the substructure forms so we can ;; see which one `test-match-nth' is going to skip ;; ; # "y" 2 result (test-assert "x" #t) ; 1 - #f #f PASS (test-assert "y" #f) ; 2 - #t #t SKIP (test-assert "y" #f) ; 3 - #t #f SKIP (test-assert "x" #f) ; 4 - #f #f FAIL (test-assert "z" #f) ; 5 - #f #f FAIL (test-end)))) (test-begin "6.4.3. Skipping test suites") (test-equal "6.4.3.1. Introduced using 'test-begin'" '(("x") () () () () (1 0 0 0 0)) (triv-runner (lambda () (test-begin "a") (test-skip "b") (test-begin "b") ; not skipped (test-assert "x" #t) (test-end "b") (test-end "a")))) (test-expect-fail 1) ;; ??? (test-equal "6.4.3.2. Introduced using 'test-group'" '(() () () () () (0 0 0 0 1)) (triv-runner (lambda () (test-begin "a") (test-skip "b") (test-group "b" ; skipped (test-assert "x" #t)) (test-end "a")))) (test-equal "6.4.3.3. Non-skipped 'test-group'" '(("x") () () () () (1 0 0 0 0)) (triv-runner (lambda () (test-begin "a") (test-skip "c") (test-group "b" (test-assert "x" #t)) (test-end "a")))) (test-end) ; 6.4.3 (test-end);6.4 (test-end "6. Skipping selected tests") ;;; ;;; ;;; (test-begin "7. Expected failures") (test-equal "7.1. Simple example" '(() ("x") ("z") () () (0 1 1 0 0)) (triv-runner (lambda () (test-assert "x" #f) (test-expect-fail "z") (test-assert "z" #f)))) (test-equal "7.2. Expected exception" '(() ("x") ("z") () () (0 1 1 0 0)) (triv-runner (lambda () (test-assert "x" #f) (test-expect-fail "z") (test-assert "z" (choke))))) (test-equal "7.3. Unexpectedly PASS" '(() () ("y") ("x") () (0 0 1 1 0)) (triv-runner (lambda () (test-expect-fail "x") (test-expect-fail "y") (test-assert "x" #t) (test-assert "y" #f)))) (test-end "7. Expected failures") ;;; ;;; ;;; (test-begin "8. Test-runner") ;;; ;;; Because we want this test suite to be accurate even ;;; when the underlying implementation chooses to use, e.g., ;;; a global variable to implement what could be thread variables ;;; or SRFI-39 parameter objects, we really need to save and restore ;;; their state ourselves ;;; (define (with-factory-saved thunk) (let* ((saved (test-runner-factory)) (result (thunk))) (test-runner-factory saved) result)) (test-begin "8.1. test-runner-current") (test-assert "8.1.1. automatically restored" (let ((a 0) (b 1) (c 2)) ; (triv-runner (lambda () (set! a (test-runner-current)) ;; (triv-runner (lambda () (set! b (test-runner-current)))) ;; (set! c (test-runner-current)))) ;; (and (eq? a c) (not (eq? a b))))) (test-end) (test-begin "8.2. test-runner-simple") (test-assert "8.2.1. default on-test hook" (eq? (test-runner-on-test-end (test-runner-simple)) test-on-test-end-simple)) (test-assert "8.2.2. default on-final hook" (eq? (test-runner-on-final (test-runner-simple)) test-on-final-simple)) (test-end) (test-begin "8.3. test-runner-factory") (test-assert "8.3.1. default factory" (eq? (test-runner-factory) test-runner-simple)) (test-assert "8.3.2. settable factory" (with-factory-saved (lambda () (test-runner-factory test-runner-null) ;; we have no way, without bringing in other SRFIs, ;; to make sure the following doesn't print anything, ;; but it shouldn't: (test-with-runner (test-runner-create) (lambda () (test-begin "a") (test-assert #t) ; pass (test-assert #f) ; fail (test-assert (vector-ref '#(3) 10)) ; fail with error (test-end "a"))) (eq? (test-runner-factory) test-runner-null)))) (test-end) ;;; This got tested about as well as it could in 8.3.2 (test-begin "8.4. test-runner-create") (test-end) ;;; This got tested about as well as it could in 8.3.2 (test-begin "8.5. test-runner-factory") (test-end) (test-begin "8.6. test-apply") (test-equal "8.6.1. Simple (form 1) test-apply" '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) (triv-runner (lambda () (test-begin "a") (test-assert "w" #t) (test-apply (test-match-name "p") (lambda () (test-begin "p") (test-assert "x" #t) (test-end) (test-begin "z") (test-assert "p" #t) ; only this one should execute in here (test-end))) (test-assert "v" #t)))) (test-equal "8.6.2. Simple (form 2) test-apply" '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) (triv-runner (lambda () (test-begin "a") (test-assert "w" #t) (test-apply (test-runner-current) (test-match-name "p") (lambda () (test-begin "p") (test-assert "x" #t) (test-end) (test-begin "z") (test-assert "p" #t) ; only this one should execute in here (test-end))) (test-assert "v" #t)))) (test-expect-fail 1) ;; depends on all test-match-nth being called. (test-equal "8.6.3. test-apply with skips" '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3)) (triv-runner (lambda () (test-begin "a") (test-assert "w" #t) (test-skip (test-match-nth 2)) (test-skip (test-match-nth 4)) (test-apply (test-runner-current) (test-match-name "p") (test-match-name "q") (lambda () ; only execute if SKIP=no and APPLY=yes (test-assert "x" #t) ; # 1 SKIP=no APPLY=no (test-assert "p" #t) ; # 2 SKIP=yes APPLY=yes (test-assert "q" #t) ; # 3 SKIP=no APPLY=yes (test-assert "x" #f) ; # 4 SKIP=yes APPLY=no 0)) (test-assert "v" #t)))) ;;; Unfortunately, since there is no way to UNBIND the current test runner, ;;; there is no way to test the behavior of `test-apply' in the absence ;;; of a current runner within our little meta-test framework. ;;; ;;; To test the behavior manually, you should be able to invoke: ;;; ;;; (test-apply "a" (lambda () (test-assert "a" #t))) ;;; ;;; from the top level (with SRFI 64 available) and it should create a ;;; new, default (simple) test runner. (test-end) ;;; This entire suite depends heavily on 'test-with-runner'. If it didn't ;;; work, this suite would probably go down in flames (test-begin "8.7. test-with-runner") (test-end) ;;; Again, this suite depends heavily on many of the test-runner ;;; components. We'll just test those that aren't being exercised ;;; by the meta-test framework (test-begin "8.8. test-runner components") (define (auxtrack-runner thunk) (let ((r (test-runner-null))) (test-runner-aux-value! r '()) (test-runner-on-test-end! r (lambda (r) (test-runner-aux-value! r (cons (test-runner-test-name r) (test-runner-aux-value r))))) (test-with-runner r (thunk)) (reverse (test-runner-aux-value r)))) (test-equal "8.8.1. test-runner-aux-value" '("x" "" "y") (auxtrack-runner (lambda () (test-assert "x" #t) (test-begin "a") (test-assert #t) (test-end) (test-assert "y" #f)))) (test-end) ; 8.8 (test-end "8. Test-runner") (test-begin "9. Test Result Properties") (test-begin "9.1. test-result-alist") (define (symbol-alist? l) (if (null? l) #t (and (pair? l) (pair? (car l)) (symbol? (caar l)) (symbol-alist? (cdr l))))) ;;; check the various syntactic forms (test-assert (symbol-alist? (car (on-test-runner (lambda () (test-assert #t)) (lambda (r) (test-result-alist r)))))) (test-assert (symbol-alist? (car (on-test-runner (lambda () (test-assert #t)) (lambda (r) (test-result-alist r)))))) ;;; check to make sure the required properties are returned (test-equal '((result-kind . pass)) (prop-runner '(result-kind) (lambda () (test-assert #t))) ) (test-equal '((result-kind . fail) (expected-value . 2) (actual-value . 3)) (prop-runner '(result-kind expected-value actual-value) (lambda () (test-equal 2 (+ 1 2))))) (test-end "9.1. test-result-alist") (test-begin "9.2. test-result-ref") (test-equal '(pass) (on-test-runner (lambda () (test-assert #t)) (lambda (r) (test-result-ref r 'result-kind)))) (test-equal '(pass) (on-test-runner (lambda () (test-assert #t)) (lambda (r) (test-result-ref r 'result-kind)))) (test-equal '(fail pass) (on-test-runner (lambda () (test-assert (= 1 2)) (test-assert (= 1 1))) (lambda (r) (test-result-ref r 'result-kind)))) (test-end "9.2. test-result-ref") (test-begin "9.3. test-result-set!") (test-equal '(100 100) (on-test-runner (lambda () (test-assert (= 1 2)) (test-assert (= 1 1))) (lambda (r) (test-result-set! r 'foo 100) (test-result-ref r 'foo)))) (test-end "9.3. test-result-set!") (test-end "9. Test Result Properties") ;;; ;;; ;;; #| Time to stop having fun... (test-begin "9. For fun, some meta-test errors") (test-equal "9.1. Really PASSes, but test like it should FAIL" '(() ("b") () () ()) (triv-runner (lambda () (test-assert "b" #t)))) (test-expect-fail "9.2. Expect to FAIL and do so") (test-expect-fail "9.3. Expect to FAIL but PASS") (test-skip "9.4. SKIP this one") (test-assert "9.2. Expect to FAIL and do so" #f) (test-assert "9.3. Expect to FAIL but PASS" #t) (test-assert "9.4. SKIP this one" #t) (test-end) |# (test-end "SRFI 64 - Meta-Test Suite") ;;; ���������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a64/testing-impl.scm���������������������������������������0000664�0000000�0000000�00000102743�13751542066�0022573�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Copyright (c) 2005, 2006 Per Bothner ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the "Software"), to deal in the Software without ;; restriction, including without limitation the rights to use, copy, ;; modify, merge, publish, distribute, sublicense, and/or sell copies ;; of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. (cond-expand (r6rs) (chicken (require-extension syntax-case)) (guile (use-modules (ice-9 syncase) (srfi srfi-9) ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7 (srfi srfi-39))) (sisc (require-extension (srfi 9 34 35 39))) (kawa (module-compile-options warn-undefined-variable: #t warn-invoke-unknown-method: #t) (provide 'srfi-64) (provide 'testing) (require 'srfi-34) (require 'srfi-35)) (else () )) (cond-expand (r6rs (define-syntax %test-export (syntax-rules () ((%test-export . names) (begin))))) (kawa (define-syntax %test-export (syntax-rules () ((%test-export test-begin . other-names) (module-export %test-begin . other-names))))) (else (define-syntax %test-export (syntax-rules () ((%test-export . names) (if #f #f)))))) ;; List of exported names (%test-export test-begin ;; must be listed first, since in Kawa (at least) it is "magic". test-end test-assert test-eqv test-eq test-equal test-approximate test-assert test-error test-apply test-with-runner test-match-nth test-match-all test-match-any test-match-name test-skip test-expect-fail test-read-eval-string test-runner-group-path test-group-with-cleanup test-result-ref test-result-set! test-result-clear test-result-remove test-result-kind test-passed? test-log-to-file ; Misc test-runner functions test-runner? test-runner-reset test-runner-null test-runner-simple test-runner-current test-runner-factory test-runner-get test-runner-create test-runner-test-name ;; test-runner field setter and getter functions - see %test-record-define: test-runner-pass-count test-runner-pass-count! test-runner-fail-count test-runner-fail-count! test-runner-xpass-count test-runner-xpass-count! test-runner-xfail-count test-runner-xfail-count! test-runner-skip-count test-runner-skip-count! test-runner-group-stack test-runner-group-stack! test-runner-on-test-begin test-runner-on-test-begin! test-runner-on-test-end test-runner-on-test-end! test-runner-on-group-begin test-runner-on-group-begin! test-runner-on-group-end test-runner-on-group-end! test-runner-on-final test-runner-on-final! test-runner-on-bad-count test-runner-on-bad-count! test-runner-on-bad-end-name test-runner-on-bad-end-name! test-result-alist test-result-alist! test-runner-aux-value test-runner-aux-value! ;; default/simple call-back functions, used in default test-runner, ;; but can be called to construct more complex ones. test-on-group-begin-simple test-on-group-end-simple test-on-bad-count-simple test-on-bad-end-name-simple test-on-final-simple test-on-test-end-simple test-on-final-simple) (cond-expand (srfi-9 (define-syntax %test-record-define (syntax-rules () ((%test-record-define alloc runner? (name index getter setter) ...) (define-record-type test-runner (alloc) runner? (name getter setter) ...))))) (else (define %test-runner-cookie (list "test-runner")) (define-syntax %test-record-define (syntax-rules () ((%test-record-define alloc runner? (name index getter setter) ...) (begin (define (runner? obj) (and (vector? obj) (> (vector-length obj) 1) (eq (vector-ref obj 0) %test-runner-cookie))) (define (alloc) (let ((runner (make-vector 22))) (vector-set! runner 0 %test-runner-cookie) runner)) (begin (define (getter runner) (vector-ref runner index)) ...) (begin (define (setter runner value) (vector-set! runner index value)) ...))))))) (%test-record-define %test-runner-alloc test-runner? ;; Cumulate count of all tests that have passed and were expected to. (pass-count 1 test-runner-pass-count test-runner-pass-count!) (fail-count 2 test-runner-fail-count test-runner-fail-count!) (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!) (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!) (skip-count 5 test-runner-skip-count test-runner-skip-count!) (skip-list 6 %test-runner-skip-list %test-runner-skip-list!) (fail-list 7 %test-runner-fail-list %test-runner-fail-list!) ;; Normally #t, except when in a test-apply. (run-list 8 %test-runner-run-list %test-runner-run-list!) (skip-save 9 %test-runner-skip-save %test-runner-skip-save!) (fail-save 10 %test-runner-fail-save %test-runner-fail-save!) (group-stack 11 test-runner-group-stack test-runner-group-stack!) (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!) (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!) ;; Call-back when entering a group. Takes (runner suite-name count). (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!) ;; Call-back when leaving a group. (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!) ;; Call-back when leaving the outermost group. (on-final 16 test-runner-on-final test-runner-on-final!) ;; Call-back when expected number of tests was wrong. (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!) ;; Call-back when name in test=end doesn't match test-begin. (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!) ;; Cumulate count of all tests that have been done. (total-count 19 %test-runner-total-count %test-runner-total-count!) ;; Stack (list) of (count-at-start . expected-count): (count-list 20 %test-runner-count-list %test-runner-count-list!) (result-alist 21 test-result-alist test-result-alist!) ;; Field can be used by test-runner for any purpose. ;; test-runner-simple uses it for a log file. (aux-value 22 test-runner-aux-value test-runner-aux-value!) ) (define (test-runner-reset runner) (test-result-alist! runner '()) (test-runner-pass-count! runner 0) (test-runner-fail-count! runner 0) (test-runner-xpass-count! runner 0) (test-runner-xfail-count! runner 0) (test-runner-skip-count! runner 0) (%test-runner-total-count! runner 0) (%test-runner-count-list! runner '()) (%test-runner-run-list! runner #t) (%test-runner-skip-list! runner '()) (%test-runner-fail-list! runner '()) (%test-runner-skip-save! runner '()) (%test-runner-fail-save! runner '()) (test-runner-group-stack! runner '())) (define (test-runner-group-path runner) (reverse (test-runner-group-stack runner))) (define (%test-null-callback runner) #f) (define (test-runner-null) (let ((runner (%test-runner-alloc))) (test-runner-reset runner) (test-runner-on-group-begin! runner (lambda (runner name count) #f)) (test-runner-on-group-end! runner %test-null-callback) (test-runner-on-final! runner %test-null-callback) (test-runner-on-test-begin! runner %test-null-callback) (test-runner-on-test-end! runner %test-null-callback) (test-runner-on-bad-count! runner (lambda (runner count expected) #f)) (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f)) runner)) ;; Not part of the specification. FIXME ;; Controls whether a log file is generated. (define test-log-to-file #t) (define (test-runner-simple) (let ((runner (%test-runner-alloc))) (test-runner-reset runner) (test-runner-on-group-begin! runner test-on-group-begin-simple) (test-runner-on-group-end! runner test-on-group-end-simple) (test-runner-on-final! runner test-on-final-simple) (test-runner-on-test-begin! runner test-on-test-begin-simple) (test-runner-on-test-end! runner test-on-test-end-simple) (test-runner-on-bad-count! runner test-on-bad-count-simple) (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) runner)) (cond-expand (srfi-39 (define test-runner-current (make-parameter #f)) (define test-runner-factory (make-parameter test-runner-simple))) (else (define %test-runner-current #f) (define-syntax test-runner-current (syntax-rules () ((test-runner-current) %test-runner-current) ((test-runner-current runner) (set! %test-runner-current runner)))) (define %test-runner-factory test-runner-simple) (define-syntax test-runner-factory (syntax-rules () ((test-runner-factory) %test-runner-factory) ((test-runner-factory runner) (set! %test-runner-factory runner)))))) ;; A safer wrapper to test-runner-current. (define (test-runner-get) (let ((r (test-runner-current))) (if (not r) (cond-expand (srfi-23 (error "test-runner not initialized - test-begin missing?")) (else #t))) r)) (define (%test-specificier-matches spec runner) (spec runner)) (define (test-runner-create) ((test-runner-factory))) (define (%test-any-specifier-matches list runner) (let ((result #f)) (let loop ((l list)) (cond ((null? l) result) (else (if (%test-specificier-matches (car l) runner) (set! result #t)) (loop (cdr l))))))) ;; Returns #f, #t, or 'xfail. (define (%test-should-execute runner) (let ((run (%test-runner-run-list runner))) (cond ((or (not (or (eqv? run #t) (%test-any-specifier-matches run runner))) (%test-any-specifier-matches (%test-runner-skip-list runner) runner)) (test-result-set! runner 'result-kind 'skip) #f) ((%test-any-specifier-matches (%test-runner-fail-list runner) runner) (test-result-set! runner 'result-kind 'xfail) 'xfail) (else #t)))) (define (%test-begin suite-name count) (if (not (test-runner-current)) (test-runner-current (test-runner-create))) (let ((runner (test-runner-current))) ((test-runner-on-group-begin runner) runner suite-name count) (%test-runner-skip-save! runner (cons (%test-runner-skip-list runner) (%test-runner-skip-save runner))) (%test-runner-fail-save! runner (cons (%test-runner-fail-list runner) (%test-runner-fail-save runner))) (%test-runner-count-list! runner (cons (cons (%test-runner-total-count runner) count) (%test-runner-count-list runner))) (test-runner-group-stack! runner (cons suite-name (test-runner-group-stack runner))))) (cond-expand ((and (not r6rs) kawa) ;; Kawa has test-begin built in, implemented as: ;; (begin ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64))) ;; (%test-begin suite-name [count])) ;; This puts test-begin but only test-begin in the default environment., ;; which makes normal test suites loadable without non-portable commands. ) (else (define-syntax test-begin (syntax-rules () ((test-begin suite-name) (%test-begin suite-name #f)) ((test-begin suite-name count) (%test-begin suite-name count)))))) (define (test-on-group-begin-simple runner suite-name count) (if (null? (test-runner-group-stack runner)) (begin (display "%%%% Starting test ") (display suite-name) (if test-log-to-file (let* ((log-file-name (if (string? test-log-to-file) test-log-to-file (string-append suite-name ".log"))) (log-file (cond-expand ((and (not r6rs) mzscheme) (open-output-file log-file-name 'truncate/replace)) (else (open-output-file log-file-name))))) (display "%%%% Starting test " log-file) (display suite-name log-file) (newline log-file) (test-runner-aux-value! runner log-file) (display " (Writing full log to \"") (display log-file-name) (display "\")"))) (newline))) (let ((log (test-runner-aux-value runner))) (if (output-port? log) (begin (display "Group begin: " log) (display suite-name log) (newline log)))) #f) (define (test-on-group-end-simple runner) (let ((log (test-runner-aux-value runner))) (if (output-port? log) (begin (display "Group end: " log) (display (car (test-runner-group-stack runner)) log) (newline log)))) #f) (define (%test-on-bad-count-write runner count expected-count port) (display "*** Total number of tests was " port) (display count port) (display " but should be " port) (display expected-count port) (display ". ***" port) (newline port) (display "*** Discrepancy indicates testsuite error or exceptions. ***" port) (newline port)) (define (test-on-bad-count-simple runner count expected-count) (%test-on-bad-count-write runner count expected-count (current-output-port)) (let ((log (test-runner-aux-value runner))) (if (output-port? log) (%test-on-bad-count-write runner count expected-count log)))) (define (test-on-bad-end-name-simple runner begin-name end-name) (let ((msg (string-append (%test-format-line runner) "test-end " begin-name " does not match test-begin " end-name))) (cond-expand (srfi-23 (error msg)) (else (display msg) (newline))))) (define (%test-final-report1 value label port) (if (> value 0) (begin (display label port) (display value port) (newline port)))) (define (%test-final-report-simple runner port) (%test-final-report1 (test-runner-pass-count runner) "# of expected passes " port) (%test-final-report1 (test-runner-xfail-count runner) "# of expected failures " port) (%test-final-report1 (test-runner-xpass-count runner) "# of unexpected successes " port) (%test-final-report1 (test-runner-fail-count runner) "# of unexpected failures " port) (%test-final-report1 (test-runner-skip-count runner) "# of skipped tests " port)) (define (test-on-final-simple runner) (%test-final-report-simple runner (current-output-port)) (let ((log (test-runner-aux-value runner))) (if (output-port? log) (%test-final-report-simple runner log)))) (define (%test-format-line runner) (let* ((line-info (test-result-alist runner)) (source-file (assq 'source-file line-info)) (source-line (assq 'source-line line-info)) (file (if source-file (cdr source-file) ""))) (if source-line (string-append file ":" (number->string (cdr source-line)) ": ") ""))) (define (%test-end suite-name line-info) (let* ((r (test-runner-get)) (groups (test-runner-group-stack r)) (line (%test-format-line r))) (test-result-alist! r line-info) (if (null? groups) (let ((msg (string-append line "test-end not in a group"))) (cond-expand (srfi-23 (error msg)) (else (display msg) (newline))))) (if (and suite-name (not (equal? suite-name (car groups)))) ((test-runner-on-bad-end-name r) r suite-name (car groups))) (let* ((count-list (%test-runner-count-list r)) (expected-count (cdar count-list)) (saved-count (caar count-list)) (group-count (- (%test-runner-total-count r) saved-count))) (if (and expected-count (not (= expected-count group-count))) ((test-runner-on-bad-count r) r group-count expected-count)) ((test-runner-on-group-end r) r) (test-runner-group-stack! r (cdr (test-runner-group-stack r))) (%test-runner-skip-list! r (car (%test-runner-skip-save r))) (%test-runner-skip-save! r (cdr (%test-runner-skip-save r))) (%test-runner-fail-list! r (car (%test-runner-fail-save r))) (%test-runner-fail-save! r (cdr (%test-runner-fail-save r))) (%test-runner-count-list! r (cdr count-list)) (if (null? (test-runner-group-stack r)) ((test-runner-on-final r) r))))) (define-syntax test-group (syntax-rules () ((test-group suite-name . body) (let ((r (test-runner-current))) ;; Ideally should also set line-number, if available. (test-result-alist! r (list (cons 'test-name suite-name))) (if (%test-should-execute r) (dynamic-wind (lambda () (test-begin suite-name)) (lambda () . body) (lambda () (test-end suite-name)))))))) (define-syntax test-group-with-cleanup (syntax-rules () ((test-group-with-cleanup suite-name form cleanup-form) (test-group suite-name (dynamic-wind (lambda () #f) (lambda () form) (lambda () cleanup-form)))) ((test-group-with-cleanup suite-name cleanup-form) (test-group-with-cleanup suite-name #f cleanup-form)) ((test-group-with-cleanup suite-name form1 form2 form3 . rest) (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest)))) (define (test-on-test-begin-simple runner) (let ((log (test-runner-aux-value runner))) (if (output-port? log) (let* ((results (test-result-alist runner)) (source-file (assq 'source-file results)) (source-line (assq 'source-line results)) (source-form (assq 'source-form results)) (test-name (assq 'test-name results))) (display "Test begin:" log) (newline log) (if test-name (%test-write-result1 test-name log)) (if source-file (%test-write-result1 source-file log)) (if source-line (%test-write-result1 source-line log)) (if source-form (%test-write-result1 source-form log)))))) (define-syntax test-result-ref (syntax-rules () ((test-result-ref runner pname) (test-result-ref runner pname #f)) ((test-result-ref runner pname default) (let ((p (assq pname (test-result-alist runner)))) (if p (cdr p) default))))) (define (test-on-test-end-simple runner) (let ((log (test-runner-aux-value runner)) (kind (test-result-ref runner 'result-kind))) (if (memq kind '(fail xpass)) (let* ((results (test-result-alist runner)) (source-file (assq 'source-file results)) (source-line (assq 'source-line results)) (test-name (assq 'test-name results))) (if (or source-file source-line) (begin (if source-file (display (cdr source-file))) (display ":") (if source-line (display (cdr source-line))) (display ": "))) (display (if (eq? kind 'xpass) "XPASS" "FAIL")) (if test-name (begin (display " ") (display (cdr test-name)))) (newline))) (if (output-port? log) (begin (display "Test end:" log) (newline log) (let loop ((list (test-result-alist runner))) (if (pair? list) (let ((pair (car list))) ;; Write out properties not written out by on-test-begin. (if (not (memq (car pair) '(test-name source-file source-line source-form))) (%test-write-result1 pair log)) (loop (cdr list))))))))) (define (%test-write-result1 pair port) (display " " port) (display (car pair) port) (display ": " port) (write (cdr pair) port) (newline port)) (define (test-result-set! runner pname value) (let* ((alist (test-result-alist runner)) (p (assq pname alist))) (if p (set-cdr! p value) (test-result-alist! runner (cons (cons pname value) alist))))) (define (test-result-clear runner) (test-result-alist! runner '())) (define (test-result-remove runner pname) (let* ((alist (test-result-alist runner)) (p (assq pname alist))) (if p (test-result-alist! runner (let loop ((r alist)) (if (eq? r p) (cdr r) (cons (car r) (loop (cdr r))))))))) (define (test-result-kind . rest) (let ((runner (if (pair? rest) (car rest) (test-runner-current)))) (test-result-ref runner 'result-kind))) (define (test-passed? . rest) (let ((runner (if (pair? rest) (car rest) (test-runner-get)))) (memq (test-result-ref runner 'result-kind) '(pass xpass)))) (define (%test-report-result) (let* ((r (test-runner-get)) (result-kind (test-result-kind r))) (case result-kind ((pass) (test-runner-pass-count! r (+ 1 (test-runner-pass-count r)))) ((fail) (test-runner-fail-count! r (+ 1 (test-runner-fail-count r)))) ((xpass) (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r)))) ((xfail) (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r)))) (else (test-runner-skip-count! r (+ 1 (test-runner-skip-count r))))) (%test-runner-total-count! r (+ 1 (%test-runner-total-count r))) ((test-runner-on-test-end r) r))) (cond-expand (r6rs (define-syntax %test-evaluate-with-catch (syntax-rules () ((%test-evaluate-with-catch test-expression) (guard (ex (else #F)) test-expression))))) (guile (define-syntax %test-evaluate-with-catch (syntax-rules () ((%test-evaluate-with-catch test-expression) (catch #t (lambda () test-expression) (lambda (key . args) #f)))))) (kawa (define-syntax %test-evaluate-with-catch (syntax-rules () ((%test-evaluate-with-catch test-expression) (try-catch test-expression (ex <java.lang.Throwable> (test-result-set! (test-runner-current) 'actual-error ex) #f)))))) (srfi-34 (define-syntax %test-evaluate-with-catch (syntax-rules () ((%test-evaluate-with-catch test-expression) (guard (err (else #f)) test-expression))))) (chicken (define-syntax %test-evaluate-with-catch (syntax-rules () ((%test-evaluate-with-catch test-expression) (condition-case test-expression (ex () #f)))))) (else (define-syntax %test-evaluate-with-catch (syntax-rules () ((%test-evaluate-with-catch test-expression) test-expression))))) (cond-expand ((and (not r6rs) (or kawa mzscheme)) (cond-expand (mzscheme (define-for-syntax (%test-syntax-file form) (let ((source (syntax-source form))) (cond ((string? source) file) ((path? source) (path->string source)) (else #f))))) (kawa (define (%test-syntax-file form) (syntax-source form)))) (define-for-syntax (%test-source-line2 form) (let* ((line (syntax-line form)) (file (%test-syntax-file form)) (line-pair (if line (list (cons 'source-line line)) '()))) (cons (cons 'source-form (syntax-object->datum form)) (if file (cons (cons 'source-file file) line-pair) line-pair))))) (else (define (%test-source-line2 form) '()))) (define (%test-on-test-begin r) (%test-should-execute r) ((test-runner-on-test-begin r) r) (not (eq? 'skip (test-result-ref r 'result-kind)))) (define (%test-on-test-end r result) (test-result-set! r 'result-kind (if (eq? (test-result-ref r 'result-kind) 'xfail) (if result 'xpass 'xfail) (if result 'pass 'fail)))) (define (test-runner-test-name runner) (test-result-ref runner 'test-name "")) (define-syntax %test-comp2body (syntax-rules () ((%test-comp2body r comp expected expr) (let () (if (%test-on-test-begin r) (let ((exp expected)) (test-result-set! r 'expected-value exp) (let ((res (%test-evaluate-with-catch expr))) (test-result-set! r 'actual-value res) (%test-on-test-end r (comp exp res))))) (%test-report-result))))) (define (%test-approximimate= error) (lambda (value expected) (and (>= value (- expected error)) (<= value (+ expected error))))) (define-syntax %test-comp1body (syntax-rules () ((%test-comp1body r expr) (let () (if (%test-on-test-begin r) (let () (let ((res (%test-evaluate-with-catch expr))) (test-result-set! r 'actual-value res) (%test-on-test-end r res)))) (%test-report-result))))) (cond-expand ((and (not r6rs) (or kawa mzscheme)) ;; Should be made to work for any Scheme with syntax-case ;; However, I haven't gotten the quoting working. FIXME. (define-syntax test-end (lambda (x) (syntax-case (list x (list 'quote (%test-source-line2 x))) () (((mac suite-name) line) (syntax (%test-end suite-name line))) (((mac) line) (syntax (%test-end #f line)))))) (define-syntax test-assert (lambda (x) (syntax-case (list x (list 'quote (%test-source-line2 x))) () (((mac tname expr) line) (syntax (let* ((r (test-runner-get)) (name tname)) (test-result-alist! r (cons (cons 'test-name tname) line)) (%test-comp1body r expr)))) (((mac expr) line) (syntax (let* ((r (test-runner-get))) (test-result-alist! r line) (%test-comp1body r expr))))))) (define-for-syntax (%test-comp2 comp x) (syntax-case (list x (list 'quote (%test-source-line2 x)) comp) () (((mac tname expected expr) line comp) (syntax (let* ((r (test-runner-get)) (name tname)) (test-result-alist! r (cons (cons 'test-name tname) line)) (%test-comp2body r comp expected expr)))) (((mac expected expr) line comp) (syntax (let* ((r (test-runner-get))) (test-result-alist! r line) (%test-comp2body r comp expected expr)))))) (define-syntax test-eqv (lambda (x) (%test-comp2 (syntax eqv?) x))) (define-syntax test-eq (lambda (x) (%test-comp2 (syntax eq?) x))) (define-syntax test-equal (lambda (x) (%test-comp2 (syntax equal?) x))) (define-syntax test-approximate ;; FIXME - needed for non-Kawa (lambda (x) (syntax-case (list x (list 'quote (%test-source-line2 x))) () (((mac tname expected expr error) line) (syntax (let* ((r (test-runner-get)) (name tname)) (test-result-alist! r (cons (cons 'test-name tname) line)) (%test-comp2body r (%test-approximimate= error) expected expr)))) (((mac expected expr error) line) (syntax (let* ((r (test-runner-get))) (test-result-alist! r line) (%test-comp2body r (%test-approximimate= error) expected expr)))))))) (else (define-syntax test-end (syntax-rules () ((test-end) (%test-end #f '())) ((test-end suite-name) (%test-end suite-name '())))) (define-syntax test-assert (syntax-rules () ((test-assert tname test-expression) (let ((r (test-runner-get))) (test-result-alist! r `((test-name . ,tname) (source-form . test-expression))) (%test-comp1body r test-expression))) ((test-assert test-expression) (let ((r (test-runner-get))) (test-result-alist! r '((source-form . test-expression))) (%test-comp1body r test-expression))))) (define-syntax %test-comp2 (syntax-rules () ((%test-comp2 comp tname expected expr) (let ((r (test-runner-get))) (test-result-alist! r `((test-name . ,tname) (source-form . expr))) (%test-comp2body r comp expected expr))) ((%test-comp2 comp expected expr) (let ((r (test-runner-get))) (test-result-alist! r '((source-form . expr))) (%test-comp2body r comp expected expr))))) (define-syntax test-equal (syntax-rules () ((test-equal . rest) (%test-comp2 equal? . rest)))) (define-syntax test-eqv (syntax-rules () ((test-eqv . rest) (%test-comp2 eqv? . rest)))) (define-syntax test-eq (syntax-rules () ((test-eq . rest) (%test-comp2 eq? . rest)))) (define-syntax test-approximate (syntax-rules () ((test-approximate tname expected expr error) (%test-comp2 (%test-approximimate= error) tname expected expr)) ((test-approximate expected expr error) (%test-comp2 (%test-approximimate= error) expected expr)))))) (cond-expand (r6rs (define-syntax %test-error (syntax-rules () ((%test-error etype expr) (let ((t etype)) (when (procedure? t) (test-result-set! (test-runner-get) 'expected-error t)) (guard (ex (else (test-result-set! (test-runner-get) 'actual-error ex) (if (procedure? t) (t ex) #T))) expr #F)))))) (guile (define-syntax %test-error (syntax-rules () ((%test-error r etype expr) (%test-comp1body r (catch #t (lambda () expr) (lambda (key . args) #t))))))) (mzscheme (define-syntax %test-error (syntax-rules () ((%test-error r etype expr) (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t))) (let () (test-result-set! r 'actual-value expr) #f))))))) (chicken (define-syntax %test-error (syntax-rules () ((%test-error r etype expr) (%test-comp1body r (condition-case expr (ex () #t))))))) (kawa (define-syntax %test-error (syntax-rules () ((%test-error r etype expr) (let () (if (%test-on-test-begin r) (let ((et etype)) (test-result-set! r 'expected-error et) (%test-on-test-end r (try-catch (let () (test-result-set! r 'actual-value expr) #f) (ex <java.lang.Throwable> (test-result-set! r 'actual-error ex) (cond ((and (instance? et <gnu.bytecode.ClassType>) (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>)) (instance? ex et)) (else #t))))) (%test-report-result)))))))) ((and srfi-34 srfi-35) (define-syntax %test-error (syntax-rules () ((%test-error r etype expr) (%test-comp1body r (guard (ex ((condition-type? etype) (and (condition? ex) (condition-has-type? ex etype))) ((procedure? etype) (etype ex)) ((equal? type #t) #t) (else #t)) expr)))))) (srfi-34 (define-syntax %test-error (syntax-rules () ((%test-error r etype expr) (%test-comp1body r (guard (ex (else #t)) expr)))))) (else (define-syntax %test-error (syntax-rules () ((%test-error r etype expr) (begin ((test-runner-on-test-begin r) r) (test-result-set! r 'result-kind 'skip) (%test-report-result))))))) (cond-expand ((and (not r6rs) (or kawa mzscheme)) (define-syntax test-error (lambda (x) (syntax-case (list x (list 'quote (%test-source-line2 x))) () (((mac tname etype expr) line) (syntax (let* ((r (test-runner-get)) (name tname)) (test-result-alist! r (cons (cons 'test-name tname) line)) (%test-error r etype expr)))) (((mac etype expr) line) (syntax (let* ((r (test-runner-get))) (test-result-alist! r line) (%test-error r etype expr)))) (((mac expr) line) (syntax (let* ((r (test-runner-get))) (test-result-alist! r line) (%test-error r #t expr)))))))) (else (define-syntax test-error (syntax-rules () ((test-error name etype expr) (test-assert name (%test-error etype expr))) ((test-error etype expr) (test-assert (%test-error etype expr))) ((test-error expr) (test-assert (%test-error #t expr))))))) (define (test-apply first . rest) (if (test-runner? first) (test-with-runner first (apply test-apply rest)) (let ((r (test-runner-current))) (if r (let ((run-list (%test-runner-run-list r))) (cond ((null? rest) (%test-runner-run-list! r (reverse! run-list)) (first)) ;; actually apply procedure thunk (else (%test-runner-run-list! r (if (eq? run-list #t) (list first) (cons first run-list))) (apply test-apply rest) (%test-runner-run-list! r run-list)))) (let ((r (test-runner-create))) (test-with-runner r (apply test-apply first rest)) ((test-runner-on-final r) r)))))) (define-syntax test-with-runner (syntax-rules () ((test-with-runner runner form ...) (let ((saved-runner (test-runner-current))) (dynamic-wind (lambda () (test-runner-current runner)) (lambda () form ...) (lambda () (test-runner-current saved-runner))))))) ;;; Predicates (define (%test-match-nth n count) (let ((i 0)) (lambda (runner) (set! i (+ i 1)) (and (>= i n) (< i (+ n count)))))) (define-syntax test-match-nth (syntax-rules () ((test-match-nth n) (test-match-nth n 1)) ((test-match-nth n count) (%test-match-nth n count)))) (define (%test-match-all . pred-list) (lambda (runner) (let ((result #t)) (let loop ((l pred-list)) (if (null? l) result (begin (if (not ((car l) runner)) (set! result #f)) (loop (cdr l)))))))) (define-syntax test-match-all (syntax-rules () ((test-match-all pred ...) (%test-match-all (%test-as-specifier pred) ...)))) (define (%test-match-any . pred-list) (lambda (runner) (let ((result #f)) (let loop ((l pred-list)) (if (null? l) result (begin (if ((car l) runner) (set! result #t)) (loop (cdr l)))))))) (define-syntax test-match-any (syntax-rules () ((test-match-any pred ...) (%test-match-any (%test-as-specifier pred) ...)))) ;; Coerce to a predicate function: (define (%test-as-specifier specifier) (cond ((procedure? specifier) specifier) ((integer? specifier) (test-match-nth 1 specifier)) ((string? specifier) (test-match-name specifier)) (else (error "not a valid test specifier")))) (define-syntax test-skip (syntax-rules () ((test-skip pred ...) (let ((runner (test-runner-get))) (%test-runner-skip-list! runner (cons (test-match-all (%test-as-specifier pred) ...) (%test-runner-skip-list runner))))))) (define-syntax test-expect-fail (syntax-rules () ((test-expect-fail pred ...) (let ((runner (test-runner-get))) (%test-runner-fail-list! runner (cons (test-match-all (%test-as-specifier pred) ...) (%test-runner-fail-list runner))))))) (define (test-match-name name) (lambda (runner) (equal? name (test-runner-test-name runner)))) (define (test-read-eval-string string) (let* ((port (open-input-string string)) (form (read port))) (if (eof-object? (read-char port)) (eval form) (cond-expand (srfi-23 (error "(not at eof)")) (else "error"))))) �����������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a64/testing.sls��������������������������������������������0000664�0000000�0000000�00000005571�13751542066�0021654�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :64 testing) (export test-begin test-end test-assert test-eqv test-eq test-equal test-approximate test-error test-apply test-with-runner test-match-nth test-match-all test-match-any test-match-name test-skip test-expect-fail test-read-eval-string test-group test-runner-group-path test-group-with-cleanup test-result-ref test-result-set! test-result-clear test-result-remove test-result-kind test-passed? (rename (%test-log-to-file test-log-to-file)) ; Misc test-runner functions test-runner? test-runner-reset test-runner-null test-runner-simple test-runner-current test-runner-factory test-runner-get test-runner-create test-runner-test-name ;; test-runner field setter and getter functions - see %test-record-define: test-runner-pass-count test-runner-pass-count! test-runner-fail-count test-runner-fail-count! test-runner-xpass-count test-runner-xpass-count! test-runner-xfail-count test-runner-xfail-count! test-runner-skip-count test-runner-skip-count! test-runner-group-stack test-runner-group-stack! test-runner-on-test-begin test-runner-on-test-begin! test-runner-on-test-end test-runner-on-test-end! test-runner-on-group-begin test-runner-on-group-begin! test-runner-on-group-end test-runner-on-group-end! test-runner-on-final test-runner-on-final! test-runner-on-bad-count test-runner-on-bad-count! test-runner-on-bad-end-name test-runner-on-bad-end-name! test-result-alist test-result-alist! test-runner-aux-value test-runner-aux-value! ;; default/simple call-back functions, used in default test-runner, ;; but can be called to construct more complex ones. test-on-group-begin-simple test-on-group-end-simple test-on-bad-count-simple test-on-bad-end-name-simple test-on-final-simple test-on-test-end-simple) (import (rnrs base) (rnrs control) (rnrs exceptions) (rnrs io simple) (rnrs lists) (rename (rnrs eval) (eval rnrs:eval)) (rnrs mutable-pairs) (srfi :0 cond-expand) (only (srfi :1 lists) reverse!) (srfi :6 basic-string-ports) (srfi :9 records) (srfi :39 parameters) (srfi :23 error tricks) (srfi private include)) (define (eval form) (rnrs:eval form (environment '(rnrs) '(rnrs eval) '(rnrs mutable-pairs) '(rnrs mutable-strings) '(rnrs r5rs)))) (define %test-log-to-file (case-lambda (() test-log-to-file) ((val) (set! test-log-to-file val)))) (SRFI-23-error->R6RS "(library (srfi :64 testing))" (include/resolve ("srfi" "%3a64") "testing-impl.scm")) (set! test-log-to-file #F) ) ���������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a67.sls����������������������������������������������������0000664�0000000�0000000�00000002004�13751542066�0020166�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :67) (export </<=? </<? <=/<=? <=/<? <=? <? =? >/>=? >/>? >=/>=? >=/>? >=? >? boolean-compare chain<=? chain<? chain=? chain>=? chain>? char-compare char-compare-ci compare-by< compare-by<= compare-by=/< compare-by=/> compare-by> compare-by>= complex-compare cond-compare debug-compare default-compare if-not=? if3 if<=? if<? if=? if>=? if>? integer-compare kth-largest list-compare list-compare-as-vector max-compare min-compare not=? number-compare pair-compare pair-compare-car pair-compare-cdr pairwise-not=? rational-compare real-compare refine-compare select-compare string-compare string-compare-ci symbol-compare vector-compare vector-compare-as-list) (import (srfi :67 compare-procedures)) ) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a67/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017447�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a67/compare-procedures.sls���������������������������������0000664�0000000�0000000�00000002150�13751542066�0023767�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :67 compare-procedures) (export </<=? </<? <=/<=? <=/<? <=? <? =? >/>=? >/>? >=/>=? >=/>? >=? >? boolean-compare chain<=? chain<? chain=? chain>=? chain>? char-compare char-compare-ci compare-by< compare-by<= compare-by=/< compare-by=/> compare-by> compare-by>= complex-compare cond-compare debug-compare default-compare if-not=? if3 if<=? if<? if=? if>=? if>? integer-compare kth-largest list-compare list-compare-as-vector max-compare min-compare not=? number-compare pair-compare pair-compare-car pair-compare-cdr pairwise-not=? rational-compare real-compare refine-compare select-compare string-compare string-compare-ci symbol-compare vector-compare vector-compare-as-list) (import (except (rnrs) error) (only (rnrs r5rs) modulo) (only (srfi :27 random-bits) random-integer) (srfi :23 error) (srfi private include)) (include/resolve ("srfi" "%3a67") "compare.scm") ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a67/compare.scm��������������������������������������������0000664�0000000�0000000�00000057162�13751542066�0021614�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard. ; ; Permission is hereby granted, free of charge, to any person obtaining ; a copy of this software and associated documentation files (the ; ``Software''), to deal in the Software without restriction, including ; without limitation the rights to use, copy, modify, merge, publish, ; distribute, sublicense, and/or sell copies of the Software, and to ; permit persons to whom the Software is furnished to do so, subject to ; the following conditions: ; ; The above copyright notice and this permission notice shall be ; included in all copies or substantial portions of the Software. ; ; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, ; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ; ; ----------------------------------------------------------------------- ; ; Compare procedures SRFI (reference implementation) ; Sebastian.Egner@philips.com, Jensaxel@soegaard.net ; history of this file: ; SE, 14-Oct-2004: first version ; SE, 18-Oct-2004: 1st redesign: axioms for 'compare function' ; SE, 29-Oct-2004: 2nd redesign: higher order reverse/map/refine/unite ; SE, 2-Nov-2004: 3rd redesign: macros cond/refine-compare replace h.o.f's ; SE, 10-Nov-2004: (im,re) replaced by (re,im) in complex-compare ; SE, 11-Nov-2004: case-compare by case (not by cond); select-compare added ; SE, 12-Jan-2005: pair-compare-cdr ; SE, 15-Feb-2005: stricter typing for compare-<type>; pairwise-not=? ; SE, 16-Feb-2005: case-compare -> if-compare -> if3; <? </<? chain<? etc. ; JS, 24-Feb-2005: selection-compare added ; SE, 25-Feb-2005: selection-compare -> kth-largest modified; if<? etc. ; JS, 28-Feb-2005: kth-largest modified - is "stable" now ; SE, 28-Feb-2005: simplified pairwise-not=?/kth-largest; min/max debugged ; SE, 07-Apr-2005: compare-based type checks made explicit ; SE, 18-Apr-2005: added (rel? compare) and eq?-test ; SE, 16-May-2005: naming convention changed; compare-by< etc. optional x y ; ============================================================================= ; Reference Implementation ; ======================== ; ; in R5RS (including hygienic macros) ; + SRFI-16 (case-lambda) ; + SRFI-23 (error) ; + SRFI-27 (random-integer) ; Implementation remarks: ; * In general, the emphasis of this implementation is on correctness ; and portability, not on efficiency. ; * Variable arity procedures are expressed in terms of case-lambda ; in the hope that this will produce efficient code for the case ; where the arity is statically known at the call site. ; * In procedures that are required to type-check their arguments, ; we use (compare x x) for executing extra checks. This relies on ; the assumption that eq? is used to catch this case quickly. ; * Care has been taken to reference comparison procedures of R5RS ; only at the time the operations here are being defined. This ; makes it possible to redefine these operations, if need be. ; * For the sake of efficiency, some inlining has been done by hand. ; This is mainly expressed by macros producing defines. ; * Identifiers of the form compare:<something> are private. ; ; Hints for low-level implementation: ; * The basis of this SRFI are the atomic compare procedures, ; i.e. boolean-compare, char-compare, etc. and the conditionals ; if3, if=?, if<? etc., and default-compare. These should make ; optimal use of the available type information. ; * For the sake of speed, the reference implementation does not ; use a LET to save the comparison value c for the ERROR call. ; This can be fixed in a low-level implementation at no cost. ; * Type-checks based on (compare x x) are made explicit by the ; expression (compare:check result compare x ...). ; * Eq? should can used to speed up built-in compare procedures, ; but it can only be used after type-checking at least one of ; the arguments. (define (compare:checked result compare . args) (for-each (lambda (x) (compare x x)) args) result) ; 3-sided conditional (define-syntax if3 (syntax-rules () ((if3 c less equal greater) (case c ((-1) less) (( 0) equal) (( 1) greater) (else (error "comparison value not in {-1,0,1}")))))) ; 2-sided conditionals for comparisons (define-syntax compare:if-rel? (syntax-rules () ((compare:if-rel? c-cases a-cases c consequence) (compare:if-rel? c-cases a-cases c consequence (if #f #f))) ((compare:if-rel? c-cases a-cases c consequence alternate) (case c (c-cases consequence) (a-cases alternate) (else (error "comparison value not in {-1,0,1}")))))) (define-syntax if=? (syntax-rules () ((if=? arg ...) (compare:if-rel? (0) (-1 1) arg ...)))) (define-syntax if<? (syntax-rules () ((if<? arg ...) (compare:if-rel? (-1) (0 1) arg ...)))) (define-syntax if>? (syntax-rules () ((if>? arg ...) (compare:if-rel? (1) (-1 0) arg ...)))) (define-syntax if<=? (syntax-rules () ((if<=? arg ...) (compare:if-rel? (-1 0) (1) arg ...)))) (define-syntax if>=? (syntax-rules () ((if>=? arg ...) (compare:if-rel? (0 1) (-1) arg ...)))) (define-syntax if-not=? (syntax-rules () ((if-not=? arg ...) (compare:if-rel? (-1 1) (0) arg ...)))) ; predicates from compare procedures (define-syntax compare:define-rel? (syntax-rules () ((compare:define-rel? rel? if-rel?) (define rel? (case-lambda (() (lambda (x y) (if-rel? (default-compare x y) #t #f))) ((compare) (lambda (x y) (if-rel? (compare x y) #t #f))) ((x y) (if-rel? (default-compare x y) #t #f)) ((compare x y) (if (procedure? compare) (if-rel? (compare x y) #t #f) (error "not a procedure (Did you mean rel/rel??): " compare)))))))) (compare:define-rel? =? if=?) (compare:define-rel? <? if<?) (compare:define-rel? >? if>?) (compare:define-rel? <=? if<=?) (compare:define-rel? >=? if>=?) (compare:define-rel? not=? if-not=?) ; chains of length 3 (define-syntax compare:define-rel1/rel2? (syntax-rules () ((compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?) (define rel1/rel2? (case-lambda (() (lambda (x y z) (if-rel1? (default-compare x y) (if-rel2? (default-compare y z) #t #f) (compare:checked #f default-compare z)))) ((compare) (lambda (x y z) (if-rel1? (compare x y) (if-rel2? (compare y z) #t #f) (compare:checked #f compare z)))) ((x y z) (if-rel1? (default-compare x y) (if-rel2? (default-compare y z) #t #f) (compare:checked #f default-compare z))) ((compare x y z) (if-rel1? (compare x y) (if-rel2? (compare y z) #t #f) (compare:checked #f compare z)))))))) (compare:define-rel1/rel2? </<? if<? if<?) (compare:define-rel1/rel2? </<=? if<? if<=?) (compare:define-rel1/rel2? <=/<? if<=? if<?) (compare:define-rel1/rel2? <=/<=? if<=? if<=?) (compare:define-rel1/rel2? >/>? if>? if>?) (compare:define-rel1/rel2? >/>=? if>? if>=?) (compare:define-rel1/rel2? >=/>? if>=? if>?) (compare:define-rel1/rel2? >=/>=? if>=? if>=?) ; chains of arbitrary length (define-syntax compare:define-chain-rel? (syntax-rules () ((compare:define-chain-rel? chain-rel? if-rel?) (define chain-rel? (case-lambda ((compare) #t) ((compare x1) (compare:checked #t compare x1)) ((compare x1 x2) (if-rel? (compare x1 x2) #t #f)) ((compare x1 x2 x3) (if-rel? (compare x1 x2) (if-rel? (compare x2 x3) #t #f) (compare:checked #f compare x3))) ((compare x1 x2 . x3+) (if-rel? (compare x1 x2) (let chain? ((head x2) (tail x3+)) (if (null? tail) #t (if-rel? (compare head (car tail)) (chain? (car tail) (cdr tail)) (apply compare:checked #f compare (cdr tail))))) (apply compare:checked #f compare x3+)))))))) (compare:define-chain-rel? chain=? if=?) (compare:define-chain-rel? chain<? if<?) (compare:define-chain-rel? chain>? if>?) (compare:define-chain-rel? chain<=? if<=?) (compare:define-chain-rel? chain>=? if>=?) ; pairwise inequality (define pairwise-not=? (let ((= =) (<= <=)) (case-lambda ((compare) #t) ((compare x1) (compare:checked #t compare x1)) ((compare x1 x2) (if-not=? (compare x1 x2) #t #f)) ((compare x1 x2 x3) (if-not=? (compare x1 x2) (if-not=? (compare x2 x3) (if-not=? (compare x1 x3) #t #f) #f) (compare:checked #f compare x3))) ((compare . x1+) (let unequal? ((x x1+) (n (length x1+)) (unchecked? #t)) (if (< n 2) (if (and unchecked? (= n 1)) (compare:checked #t compare (car x)) #t) (let* ((i-pivot (random-integer n)) (x-pivot (list-ref x i-pivot))) (let split ((i 0) (x x) (x< '()) (x> '())) (if (null? x) (and (unequal? x< (length x<) #f) (unequal? x> (length x>) #f)) (if (= i i-pivot) (split (+ i 1) (cdr x) x< x>) (if3 (compare (car x) x-pivot) (split (+ i 1) (cdr x) (cons (car x) x<) x>) (if unchecked? (apply compare:checked #f compare (cdr x)) #f) (split (+ i 1) (cdr x) x< (cons (car x) x>))))))))))))) ; min/max (define min-compare (case-lambda ((compare x1) (compare:checked x1 compare x1)) ((compare x1 x2) (if<=? (compare x1 x2) x1 x2)) ((compare x1 x2 x3) (if<=? (compare x1 x2) (if<=? (compare x1 x3) x1 x3) (if<=? (compare x2 x3) x2 x3))) ((compare x1 x2 x3 x4) (if<=? (compare x1 x2) (if<=? (compare x1 x3) (if<=? (compare x1 x4) x1 x4) (if<=? (compare x3 x4) x3 x4)) (if<=? (compare x2 x3) (if<=? (compare x2 x4) x2 x4) (if<=? (compare x3 x4) x3 x4)))) ((compare x1 x2 . x3+) (let min ((xmin (if<=? (compare x1 x2) x1 x2)) (xs x3+)) (if (null? xs) xmin (min (if<=? (compare xmin (car xs)) xmin (car xs)) (cdr xs))))))) (define max-compare (case-lambda ((compare x1) (compare:checked x1 compare x1)) ((compare x1 x2) (if>=? (compare x1 x2) x1 x2)) ((compare x1 x2 x3) (if>=? (compare x1 x2) (if>=? (compare x1 x3) x1 x3) (if>=? (compare x2 x3) x2 x3))) ((compare x1 x2 x3 x4) (if>=? (compare x1 x2) (if>=? (compare x1 x3) (if>=? (compare x1 x4) x1 x4) (if>=? (compare x3 x4) x3 x4)) (if>=? (compare x2 x3) (if>=? (compare x2 x4) x2 x4) (if>=? (compare x3 x4) x3 x4)))) ((compare x1 x2 . x3+) (let max ((xmax (if>=? (compare x1 x2) x1 x2)) (xs x3+)) (if (null? xs) xmax (max (if>=? (compare xmax (car xs)) xmax (car xs)) (cdr xs))))))) ; kth-largest (define kth-largest (let ((= =) (< <)) (case-lambda ((compare k x0) (case (modulo k 1) ((0) (compare:checked x0 compare x0)) (else (error "bad index" k)))) ((compare k x0 x1) (case (modulo k 2) ((0) (if<=? (compare x0 x1) x0 x1)) ((1) (if<=? (compare x0 x1) x1 x0)) (else (error "bad index" k)))) ((compare k x0 x1 x2) (case (modulo k 3) ((0) (if<=? (compare x0 x1) (if<=? (compare x0 x2) x0 x2) (if<=? (compare x1 x2) x1 x2))) ((1) (if3 (compare x0 x1) (if<=? (compare x1 x2) x1 (if<=? (compare x0 x2) x2 x0)) (if<=? (compare x0 x2) x1 x0) (if<=? (compare x0 x2) x0 (if<=? (compare x1 x2) x2 x1)))) ((2) (if<=? (compare x0 x1) (if<=? (compare x1 x2) x2 x1) (if<=? (compare x0 x2) x2 x0))) (else (error "bad index" k)))) ((compare k x0 . x1+) ; |x1+| >= 1 (if (not (and (integer? k) (exact? k))) (error "bad index" k)) (let ((n (+ 1 (length x1+)))) (let kth ((k (modulo k n)) (n n) ; = |x| (rev #t) ; are x<, x=, x> reversed? (x (cons x0 x1+))) (let ((pivot (list-ref x (random-integer n)))) (let split ((x x) (x< '()) (n< 0) (x= '()) (n= 0) (x> '()) (n> 0)) (if (null? x) (cond ((< k n<) (kth k n< (not rev) x<)) ((< k (+ n< n=)) (if rev (list-ref x= (- (- n= 1) (- k n<))) (list-ref x= (- k n<)))) (else (kth (- k (+ n< n=)) n> (not rev) x>))) (if3 (compare (car x) pivot) (split (cdr x) (cons (car x) x<) (+ n< 1) x= n= x> n>) (split (cdr x) x< n< (cons (car x) x=) (+ n= 1) x> n>) (split (cdr x) x< n< x= n= (cons (car x) x>) (+ n> 1)))))))))))) ; compare functions from predicates (define compare-by< (case-lambda ((lt) (lambda (x y) (if (lt x y) -1 (if (lt y x) 1 0)))) ((lt x y) (if (lt x y) -1 (if (lt y x) 1 0))))) (define compare-by> (case-lambda ((gt) (lambda (x y) (if (gt x y) 1 (if (gt y x) -1 0)))) ((gt x y) (if (gt x y) 1 (if (gt y x) -1 0))))) (define compare-by<= (case-lambda ((le) (lambda (x y) (if (le x y) (if (le y x) 0 -1) 1))) ((le x y) (if (le x y) (if (le y x) 0 -1) 1)))) (define compare-by>= (case-lambda ((ge) (lambda (x y) (if (ge x y) (if (ge y x) 0 1) -1))) ((ge x y) (if (ge x y) (if (ge y x) 0 1) -1)))) (define compare-by=/< (case-lambda ((eq lt) (lambda (x y) (if (eq x y) 0 (if (lt x y) -1 1)))) ((eq lt x y) (if (eq x y) 0 (if (lt x y) -1 1))))) (define compare-by=/> (case-lambda ((eq gt) (lambda (x y) (if (eq x y) 0 (if (gt x y) 1 -1)))) ((eq gt x y) (if (eq x y) 0 (if (gt x y) 1 -1))))) ; refine and extend construction (define-syntax refine-compare (syntax-rules () ((refine-compare) 0) ((refine-compare c1) c1) ((refine-compare c1 c2 cs ...) (if3 c1 -1 (refine-compare c2 cs ...) 1)))) (define-syntax select-compare (syntax-rules (else) ((select-compare x y clause ...) (let ((x-val x) (y-val y)) (select-compare (x-val y-val clause ...)))) ; used internally: (select-compare (x y clause ...)) ((select-compare (x y)) 0) ((select-compare (x y (else c ...))) (refine-compare c ...)) ((select-compare (x y (t? c ...) clause ...)) (let ((t?-val t?)) (let ((tx (t?-val x)) (ty (t?-val y))) (if tx (if ty (refine-compare c ...) -1) (if ty 1 (select-compare (x y clause ...))))))))) (define-syntax cond-compare (syntax-rules (else) ((cond-compare) 0) ((cond-compare (else cs ...)) (refine-compare cs ...)) ((cond-compare ((tx ty) cs ...) clause ...) (let ((tx-val tx) (ty-val ty)) (if tx-val (if ty-val (refine-compare cs ...) -1) (if ty-val 1 (cond-compare clause ...))))))) ; R5RS atomic types (define-syntax compare:type-check (syntax-rules () ((compare:type-check type? type-name x) (if (not (type? x)) (error (string-append "not " type-name ":") x))) ((compare:type-check type? type-name x y) (begin (compare:type-check type? type-name x) (compare:type-check type? type-name y))))) (define-syntax compare:define-by=/< (syntax-rules () ((compare:define-by=/< compare = < type? type-name) (define compare (let ((= =) (< <)) (lambda (x y) (if (type? x) (if (eq? x y) 0 (if (type? y) (if (= x y) 0 (if (< x y) -1 1)) (error (string-append "not " type-name ":") y))) (error (string-append "not " type-name ":") x)))))))) (define (boolean-compare x y) (compare:type-check boolean? "boolean" x y) (if x (if y 0 1) (if y -1 0))) (compare:define-by=/< char-compare char=? char<? char? "char") (compare:define-by=/< char-compare-ci char-ci=? char-ci<? char? "char") (compare:define-by=/< string-compare string=? string<? string? "string") (compare:define-by=/< string-compare-ci string-ci=? string-ci<? string? "string") (define (symbol-compare x y) (compare:type-check symbol? "symbol" x y) (string-compare (symbol->string x) (symbol->string y))) (compare:define-by=/< integer-compare = < integer? "integer") (compare:define-by=/< rational-compare = < rational? "rational") (compare:define-by=/< real-compare = < real? "real") (define (complex-compare x y) (compare:type-check complex? "complex" x y) (if (and (real? x) (real? y)) (real-compare x y) (refine-compare (real-compare (real-part x) (real-part y)) (real-compare (imag-part x) (imag-part y))))) (define (number-compare x y) (compare:type-check number? "number" x y) (complex-compare x y)) ; R5RS compound data structures: dotted pair, list, vector (define (pair-compare-car compare) (lambda (x y) (compare (car x) (car y)))) (define (pair-compare-cdr compare) (lambda (x y) (compare (cdr x) (cdr y)))) (define pair-compare (case-lambda ; dotted pair ((pair-compare-car pair-compare-cdr x y) (refine-compare (pair-compare-car (car x) (car y)) (pair-compare-cdr (cdr x) (cdr y)))) ; possibly improper lists ((compare x y) (cond-compare (((null? x) (null? y)) 0) (((pair? x) (pair? y)) (compare (car x) (car y)) (pair-compare compare (cdr x) (cdr y))) (else (compare x y)))) ; for convenience ((x y) (pair-compare default-compare x y)))) (define list-compare (case-lambda ((compare x y empty? head tail) (cond-compare (((empty? x) (empty? y)) 0) (else (compare (head x) (head y)) (list-compare compare (tail x) (tail y) empty? head tail)))) ; for convenience (( x y empty? head tail) (list-compare default-compare x y empty? head tail)) ((compare x y ) (list-compare compare x y null? car cdr)) (( x y ) (list-compare default-compare x y null? car cdr)))) (define list-compare-as-vector (case-lambda ((compare x y empty? head tail) (refine-compare (let compare-length ((x x) (y y)) (cond-compare (((empty? x) (empty? y)) 0) (else (compare-length (tail x) (tail y))))) (list-compare compare x y empty? head tail))) ; for convenience (( x y empty? head tail) (list-compare-as-vector default-compare x y empty? head tail)) ((compare x y ) (list-compare-as-vector compare x y null? car cdr)) (( x y ) (list-compare-as-vector default-compare x y null? car cdr)))) (define vector-compare (let ((= =)) (case-lambda ((compare x y size ref) (let ((n (size x)) (m (size y))) (refine-compare (integer-compare n m) (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1] (if (= i n) 0 (refine-compare (compare (ref x i) (ref y i)) (compare-rest (+ i 1)))))))) ; for convenience (( x y size ref) (vector-compare default-compare x y size ref)) ((compare x y ) (vector-compare compare x y vector-length vector-ref)) (( x y ) (vector-compare default-compare x y vector-length vector-ref))))) (define vector-compare-as-list (let ((= =)) (case-lambda ((compare x y size ref) (let ((nx (size x)) (ny (size y))) (let ((n (min nx ny))) (let compare-rest ((i 0)) ; compare x[i..n-1] y[i..n-1] (if (= i n) (integer-compare nx ny) (refine-compare (compare (ref x i) (ref y i)) (compare-rest (+ i 1)))))))) ; for convenience (( x y size ref) (vector-compare-as-list default-compare x y size ref)) ((compare x y ) (vector-compare-as-list compare x y vector-length vector-ref)) (( x y ) (vector-compare-as-list default-compare x y vector-length vector-ref))))) ; default compare (define (default-compare x y) (select-compare x y (null? 0) (pair? (default-compare (car x) (car y)) (default-compare (cdr x) (cdr y))) (boolean? (boolean-compare x y)) (char? (char-compare x y)) (string? (string-compare x y)) (symbol? (symbol-compare x y)) (number? (number-compare x y)) (vector? (vector-compare default-compare x y)) (else (error "unrecognized type in default-compare" x y)))) ; Note that we pass default-compare to compare-{pair,vector} explictly. ; This makes sure recursion proceeds with this default-compare, which ; need not be the one in the lexical scope of compare-{pair,vector}. ; debug compare (define (debug-compare c) (define (checked-value c x y) (let ((c-xy (c x y))) (if (or (eqv? c-xy -1) (eqv? c-xy 0) (eqv? c-xy 1)) c-xy (error "compare value not in {-1,0,1}" c-xy (list c x y))))) (define (random-boolean) (zero? (random-integer 2))) (define q ; (u v w) such that u <= v, v <= w, and not u <= w '#( ;x < y x = y x > y [x < z] 0 0 0 ; y < z 0 (z y x) (z y x) ; y = z 0 (z y x) (z y x) ; y > z ;x < y x = y x > y [x = z] (y z x) (z x y) 0 ; y < z (y z x) 0 (x z y) ; y = z 0 (y x z) (x z y) ; y > z ;x < y x = y x > y [x > z] (x y z) (x y z) 0 ; y < z (x y z) (x y z) 0 ; y = z 0 0 0 ; y > z )) (let ((z? #f) (z #f)) ; stored element from previous call (lambda (x y) (let ((c-xx (checked-value c x x)) (c-yy (checked-value c y y)) (c-xy (checked-value c x y)) (c-yx (checked-value c y x))) (if (not (zero? c-xx)) (error "compare error: not reflexive" c x)) (if (not (zero? c-yy)) (error "compare error: not reflexive" c y)) (if (not (zero? (+ c-xy c-yx))) (error "compare error: not anti-symmetric" c x y)) (if z? (let ((c-xz (checked-value c x z)) (c-zx (checked-value c z x)) (c-yz (checked-value c y z)) (c-zy (checked-value c z y))) (if (not (zero? (+ c-xz c-zx))) (error "compare error: not anti-symmetric" c x z)) (if (not (zero? (+ c-yz c-zy))) (error "compare error: not anti-symmetric" c y z)) (let ((ijk (vector-ref q (+ c-xy (* 3 c-yz) (* 9 c-xz) 13)))) (if (list? ijk) (apply error "compare error: not transitive" c (map (lambda (i) (case i ((x) x) ((y) y) ((z) z))) ijk))))) (set! z? #t)) (set! z (if (random-boolean) x y)) ; randomized testing c-xy)))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a67/examples.scm�������������������������������������������0000664�0000000�0000000�00000131150�13751542066�0021772�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard. ; ; Permission is hereby granted, free of charge, to any person obtaining ; a copy of this software and associated documentation files (the ; ``Software''), to deal in the Software without restriction, including ; without limitation the rights to use, copy, modify, merge, publish, ; distribute, sublicense, and/or sell copies of the Software, and to ; permit persons to whom the Software is furnished to do so, subject to ; the following conditions: ; ; The above copyright notice and this permission notice shall be ; included in all copies or substantial portions of the Software. ; ; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, ; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ; ; ----------------------------------------------------------------------- ; ; Compare procedures SRFI (confidence tests) ; Sebastian.Egner@philips.com, Jensaxel@soegaard.net, 2005 ; ; history of this file: ; SE, 14-Oct-2004: first version ; .. ; SE, 28-Feb-2005: adapted to make it one-source PLT,S48,Chicken ; JS, 01-Mar-2005: first version ; SE, 18-Apr-2005: added (<? [c] [x y]) and (</<? [c] [x y z]) ; SE, 13-May-2005: included examples for <? etc. ; SE, 16-May-2005: naming convention changed; compare-by< optional x y ; ; This program runs some examples on 'compare.scm'. ; It has been tested under ; * PLT 208p1 ; * Scheme 48 1.1 ; * Chicken 1.70. ; Portability workarounds ; ======================= ; ; The purpose of these procedures is to push the examples ; through a Scheme system with severe limitations. It is ; not the intention to supply the functionality. ; poor man's complex (define (pm-complex? z) (or (real? z) (and (pair? z) (eq? (car z) 'complex)))) (define (pm-number? z) (or (real? z) (pm-complex? z))) (define (pm-make-rectangular re im) (list 'complex re im)) (define (pm-real-part z) (if (pm-complex? z) (cadr z) z)) (define (pm-imag-part z) (if (pm-complex? z) (caddr z) z)) ; apply on truncated argument list (define (make-apply limit) (let ((original-apply apply)) (lambda (f . xs) (let ((args (let loop ((xs xs) (rev-args '())) (cond ((null? xs) (reverse rev-args)) ((null? (cdr xs)) (append (reverse rev-args) (car xs))) (else (loop (cdr xs) (cons (car xs) rev-args))))))) (if (<= (length args) limit) (original-apply f args) (original-apply f (begin (display "*** warning: truncated apply") (newline) (let truncate ((n 0) (rev-args '()) (xs args)) (if (= n limit) (reverse rev-args) (truncate (+ n 1) (cons (car xs) rev-args) (cdr xs))))))))))) ; ============================================================================= ; Running the examples in PLT (DrScheme) ; ====================================== ; ; 1. Uncomment the following lines: ; ;plt (require ;plt (lib "16.ss" "srfi") ; case-lambda ;plt (lib "23.ss" "srfi") ; error ;plt (lib "27.ss" "srfi") ; random-integer ;plt (lib "42.ss" "srfi") ; eager comprehensions list-ec etc. ;plt (lib "pretty.ss")) ; pretty-print ;plt (define pretty-write pretty-print) ;plt (load "compare.scm") ; ; 2. Run this file. ; Running the examples in Scheme-48 ; ================================= ; ; 1. Invoke scheme48 with sufficient heap size (-h <words>). ; 2. Paste this into the REPL: ; ,open srfi-16 srfi-23 srfi-27 srfi-42 pp ; (define pretty-write p) ; ,load compare.scm examples.scm ; Running the examples in the Chicken Scheme Interpreter ; ====================================================== ; ; 1. Fetch and install the srfi-42 egg from the Chicken homepage ; 2. Uncomment the following lines: ; (require-extension srfi-23) ; (define random-integer random) ; (require-extension srfi-42) ; (define pretty-write display) ; (define complex? pm-complex?) ; (define number? pm-number?) ; (define make-rectangular pm-make-rectangular) ; (define real-part pm-real-part) ; (define imag-part pm-imag-part) ; (define apply (make-apply 126)) ; Grrr... ; (load "compare.scm") ; 3. Invoke csi with: ; csi -syntax examples.scm ; ; Note: Chicken doesn't have complex numbers and has a ; severe limit on the number of arguments for apply. ; ============================================================================= ; Test engine ; =========== ; ; We use an extended version of the the checker of SRFI-42 (with ; Felix' reduction on codesize) for running a batch of tests for ; the various procedures of 'compare.scm'. Moreover, we use the ; comprehensions of SRFI-42 to generate examples systematically. (define my-equal? equal?) (define my-pretty-write pretty-write) (define my-check-correct 0) (define my-check-wrong 0) (define (my-check-reset) (set! my-check-correct 0) (set! my-check-wrong 0)) ; (my-check expr => desired-result) ; evaluates expr and compares the value with desired-result. (define-syntax my-check (syntax-rules (=>) ((my-check expr => desired-result) (my-check-proc 'expr (lambda () expr) desired-result)))) (define (my-check-proc expr thunk desired-result) (newline) (my-pretty-write expr) (display " => ") (let ((actual-result (thunk))) (write actual-result) (if (my-equal? actual-result desired-result) (begin (display " ; correct") (set! my-check-correct (+ my-check-correct 1)) ) (begin (display " ; *** wrong ***, desired result:") (newline) (display " => ") (write desired-result) (set! my-check-wrong (+ my-check-wrong 1)))) (newline))) ; (my-check-ec <qualifier>* <ok?> <expr>) ; runs (every?-ec <qualifier>* <ok?>), counting the times <ok?> ; is evaluated as a correct example, and stopping at the first ; counter example for which <expr> provides the argument. (define-syntax my-check-ec (syntax-rules (nested) ((my-check-ec (nested q1 ...) q etc1 etc2 etc ...) (my-check-ec (nested q1 ... q) etc1 etc2 etc ...)) ((my-check-ec q1 q2 etc1 etc2 etc ...) (my-check-ec (nested q1 q2) etc1 etc2 etc ...)) ((my-check-ec ok? expr) (my-check-ec (nested) ok? expr)) ((my-check-ec (nested q ...) ok? expr) (my-check-ec-proc '(every?-ec q ... ok?) (lambda () (first-ec 'ok (nested q ...) (:let ok ok?) (begin (if ok (set! my-check-correct (+ my-check-correct 1)) (set! my-check-wrong (+ my-check-wrong 1)))) (if (not ok)) (list expr))) 'expr)) ((my-check-ec q ok? expr) (my-check-ec (nested q) ok? expr)))) (define (my-check-ec-proc expr thunk arg-counter-example) (let ((my-check-correct-save my-check-correct)) (newline) (my-pretty-write expr) (display " => ") (let ((result (thunk))) (if (eqv? result 'ok) (begin (display "#t ; correct (") (write (- my-check-correct my-check-correct-save)) (display " examples)") (newline)) (begin (display "#f ; *** wrong *** (after ") (write (- my-check-correct my-check-correct-save)) (display " correct examples).") (newline) (display " ; Argument of the first counter example:") (newline) (display " ; ") (write arg-counter-example) (display " = ") (write (car result))))))) (define (my-check-summary) (begin (newline) (newline) (display "*** correct examples: ") (display my-check-correct) (newline) (display "*** wrong examples: ") (display my-check-wrong) (newline) (newline))) ; ============================================================================= ; Abstractions etc. ; ================= (define ci integer-compare) ; very frequently used ; (result-ok? actual desired) ; tests if actual and desired specify the same ordering. (define (result-ok? actual desired) (eqv? actual desired)) ; (my-check-compare compare increasing-elements) ; evaluates (compare x y) for x, y in increasing-elements ; and checks the result against -1, 0, or 1 depending on ; the position of x and y in the list increasing-elements. (define-syntax my-check-compare (syntax-rules () ((my-check-compare compare increasing-elements) (my-check-ec (:list x (index ix) increasing-elements) (:list y (index iy) increasing-elements) (result-ok? (compare x y) (ci ix iy)) (list x y))))) ; sorted lists (define my-booleans '(#f #t)) (define my-chars '(#\a #\b #\c)) (define my-chars-ci '(#\a #\B #\c #\D)) (define my-strings '("" "a" "aa" "ab" "b" "ba" "bb")) (define my-strings-ci '("" "a" "aA" "Ab" "B" "bA" "BB")) (define my-symbols '(a aa ab b ba bb)) (define my-reals (append-ec (:range xn -6 7) (:let x (/ xn 3)) (list x (+ x (exact->inexact (/ 1 100)))))) (define my-rationals (list-ec (:list x my-reals) (and (exact? x) (rational? x)) x)) (define my-integers (list-ec (:list x my-reals) (if (and (exact? x) (integer? x))) x)) (define my-complexes (list-ec (:list re-x my-reals) (if (inexact? re-x)) (:list im-x my-reals) (if (inexact? im-x)) (make-rectangular re-x im-x))) (define my-lists '(() (1) (1 1) (1 2) (2) (2 1) (2 2))) (define my-vector-as-lists (map list->vector my-lists)) (define my-list-as-vectors '(() (1) (2) (1 1) (1 2) (2 1) (2 2))) (define my-vectors (map list->vector my-list-as-vectors)) (define my-null-or-pairs '(() (1) (1 1) (1 2) (1 . 1) (1 . 2) (2) (2 1) (2 2) (2 . 1) (2 . 2))) (define my-objects (append my-null-or-pairs my-booleans my-chars my-strings my-symbols my-integers my-vectors)) ; ============================================================================= ; The checks ; ========== (define (check:if3) ; basic functionality (my-check (if3 -1 'n 'z 'p) => 'n) (my-check (if3 0 'n 'z 'p) => 'z) (my-check (if3 1 'n 'z 'p) => 'p) ; check arguments are evaluated only once (my-check (let ((x -1)) (if3 (let ((x0 x)) (set! x (+ x 1)) x0) 'n 'z 'p)) => 'n) (my-check (let ((x -1) (y 0)) (if3 (let ((x0 x)) (set! x (+ x 1)) x0) (begin (set! y (+ y 1)) y) (begin (set! y (+ y 10)) y) (begin (set! y (+ y 100)) y))) => 1) (my-check (let ((x 0) (y 0)) (if3 (let ((x0 x)) (set! x (+ x 1)) x0) (begin (set! y (+ y 1)) y) (begin (set! y (+ y 10)) y) (begin (set! y (+ y 100)) y))) => 10) (my-check (let ((x 1) (y 0)) (if3 (let ((x0 x)) (set! x (+ x 1)) x0) (begin (set! y (+ y 1)) y) (begin (set! y (+ y 10)) y) (begin (set! y (+ y 100)) y))) => 100) ) ; check:if3 (define-syntax my-check-if2 (syntax-rules () ((my-check-if2 if-rel? rel) (begin ; check result (my-check (if-rel? -1 'yes 'no) => (if (rel -1 0) 'yes 'no)) (my-check (if-rel? 0 'yes 'no) => (if (rel 0 0) 'yes 'no)) (my-check (if-rel? 1 'yes 'no) => (if (rel 1 0) 'yes 'no)) ; check result of 'laterally challenged if' (my-check (let ((x #f)) (if-rel? -1 (set! x #t)) x) => (rel -1 0)) (my-check (let ((x #f)) (if-rel? 0 (set! x #t)) x) => (rel 0 0)) (my-check (let ((x #f)) (if-rel? 1 (set! x #t)) x) => (rel 1 0)) ; check that <c> is evaluated exactly once (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) -1) #t #f) n) => 1) (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) 0) #t #f) n) => 1) (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) 1) #t #f) n) => 1) (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) -1) #t) n) => 1) (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) 0) #t) n) => 1) (my-check (let ((n 0)) (if-rel? (begin (set! n (+ n 1)) 1) #t) n) => 1) )))) (define (check:ifs) (my-check-if2 if=? =) (my-check-if2 if<? <) (my-check-if2 if>? >) (my-check-if2 if<=? <=) (my-check-if2 if>=? >=) (my-check-if2 if-not=? (lambda (x y) (not (= x y)))) ) ; check:if2 ; <? etc. macros (define-syntax my-check-chain2 (syntax-rules () ((my-check-chain2 rel? rel) (begin ; all chains of length 2 (my-check (rel? ci 0 0) => (rel 0 0)) (my-check (rel? ci 0 1) => (rel 0 1)) (my-check (rel? ci 1 0) => (rel 1 0)) ; using default-compare (my-check (rel? 0 0) => (rel 0 0)) (my-check (rel? 0 1) => (rel 0 1)) (my-check (rel? 1 0) => (rel 1 0)) ; as a combinator (my-check ((rel? ci) 0 0) => (rel 0 0)) (my-check ((rel? ci) 0 1) => (rel 0 1)) (my-check ((rel? ci) 1 0) => (rel 1 0)) ; using default-compare as a combinator (my-check ((rel?) 0 0) => (rel 0 0)) (my-check ((rel?) 0 1) => (rel 0 1)) (my-check ((rel?) 1 0) => (rel 1 0)) )))) (define (list->set xs) ; xs a list of integers (if (null? xs) '() (let ((max-xs (let max-without-apply ((m 1) (xs xs)) (if (null? xs) m (max-without-apply (max m (car xs)) (cdr xs)))))) (let ((in-xs? (make-vector (+ max-xs 1) #f))) (do-ec (:list x xs) (vector-set! in-xs? x #t)) (list-ec (:vector in? (index x) in-xs?) (if in?) x))))) (define-syntax arguments-used ; set of arguments (integer, >=0) used in compare (syntax-rules () ((arguments-used (rel1/rel2 compare arg ...)) (let ((used '())) (rel1/rel2 (lambda (x y) (set! used (cons x (cons y used))) (compare x y)) arg ...) (list->set used))))) (define-syntax my-check-chain3 (syntax-rules () ((my-check-chain3 rel1/rel2? rel1 rel2) (begin ; all chains of length 3 (my-check (rel1/rel2? ci 0 0 0) => (and (rel1 0 0) (rel2 0 0))) (my-check (rel1/rel2? ci 0 0 1) => (and (rel1 0 0) (rel2 0 1))) (my-check (rel1/rel2? ci 0 1 0) => (and (rel1 0 1) (rel2 1 0))) (my-check (rel1/rel2? ci 1 0 0) => (and (rel1 1 0) (rel2 0 0))) (my-check (rel1/rel2? ci 1 1 0) => (and (rel1 1 1) (rel2 1 0))) (my-check (rel1/rel2? ci 1 0 1) => (and (rel1 1 0) (rel2 0 1))) (my-check (rel1/rel2? ci 0 1 1) => (and (rel1 0 1) (rel2 1 1))) (my-check (rel1/rel2? ci 0 1 2) => (and (rel1 0 1) (rel2 1 2))) (my-check (rel1/rel2? ci 0 2 1) => (and (rel1 0 2) (rel2 2 1))) (my-check (rel1/rel2? ci 1 2 0) => (and (rel1 1 2) (rel2 2 0))) (my-check (rel1/rel2? ci 1 0 2) => (and (rel1 1 0) (rel2 0 2))) (my-check (rel1/rel2? ci 2 0 1) => (and (rel1 2 0) (rel2 0 1))) (my-check (rel1/rel2? ci 2 1 0) => (and (rel1 2 1) (rel2 1 0))) ; using default-compare (my-check (rel1/rel2? 0 0 0) => (and (rel1 0 0) (rel2 0 0))) (my-check (rel1/rel2? 0 0 1) => (and (rel1 0 0) (rel2 0 1))) (my-check (rel1/rel2? 0 1 0) => (and (rel1 0 1) (rel2 1 0))) (my-check (rel1/rel2? 1 0 0) => (and (rel1 1 0) (rel2 0 0))) (my-check (rel1/rel2? 1 1 0) => (and (rel1 1 1) (rel2 1 0))) (my-check (rel1/rel2? 1 0 1) => (and (rel1 1 0) (rel2 0 1))) (my-check (rel1/rel2? 0 1 1) => (and (rel1 0 1) (rel2 1 1))) (my-check (rel1/rel2? 0 1 2) => (and (rel1 0 1) (rel2 1 2))) (my-check (rel1/rel2? 0 2 1) => (and (rel1 0 2) (rel2 2 1))) (my-check (rel1/rel2? 1 2 0) => (and (rel1 1 2) (rel2 2 0))) (my-check (rel1/rel2? 1 0 2) => (and (rel1 1 0) (rel2 0 2))) (my-check (rel1/rel2? 2 0 1) => (and (rel1 2 0) (rel2 0 1))) (my-check (rel1/rel2? 2 1 0) => (and (rel1 2 1) (rel2 1 0))) ; as a combinator (my-check ((rel1/rel2? ci) 0 0 0) => (and (rel1 0 0) (rel2 0 0))) (my-check ((rel1/rel2? ci) 0 0 1) => (and (rel1 0 0) (rel2 0 1))) (my-check ((rel1/rel2? ci) 0 1 0) => (and (rel1 0 1) (rel2 1 0))) (my-check ((rel1/rel2? ci) 1 0 0) => (and (rel1 1 0) (rel2 0 0))) (my-check ((rel1/rel2? ci) 1 1 0) => (and (rel1 1 1) (rel2 1 0))) (my-check ((rel1/rel2? ci) 1 0 1) => (and (rel1 1 0) (rel2 0 1))) (my-check ((rel1/rel2? ci) 0 1 1) => (and (rel1 0 1) (rel2 1 1))) (my-check ((rel1/rel2? ci) 0 1 2) => (and (rel1 0 1) (rel2 1 2))) (my-check ((rel1/rel2? ci) 0 2 1) => (and (rel1 0 2) (rel2 2 1))) (my-check ((rel1/rel2? ci) 1 2 0) => (and (rel1 1 2) (rel2 2 0))) (my-check ((rel1/rel2? ci) 1 0 2) => (and (rel1 1 0) (rel2 0 2))) (my-check ((rel1/rel2? ci) 2 0 1) => (and (rel1 2 0) (rel2 0 1))) (my-check ((rel1/rel2? ci) 2 1 0) => (and (rel1 2 1) (rel2 1 0))) ; as a combinator using default-compare (my-check ((rel1/rel2?) 0 0 0) => (and (rel1 0 0) (rel2 0 0))) (my-check ((rel1/rel2?) 0 0 1) => (and (rel1 0 0) (rel2 0 1))) (my-check ((rel1/rel2?) 0 1 0) => (and (rel1 0 1) (rel2 1 0))) (my-check ((rel1/rel2?) 1 0 0) => (and (rel1 1 0) (rel2 0 0))) (my-check ((rel1/rel2?) 1 1 0) => (and (rel1 1 1) (rel2 1 0))) (my-check ((rel1/rel2?) 1 0 1) => (and (rel1 1 0) (rel2 0 1))) (my-check ((rel1/rel2?) 0 1 1) => (and (rel1 0 1) (rel2 1 1))) (my-check ((rel1/rel2?) 0 1 2) => (and (rel1 0 1) (rel2 1 2))) (my-check ((rel1/rel2?) 0 2 1) => (and (rel1 0 2) (rel2 2 1))) (my-check ((rel1/rel2?) 1 2 0) => (and (rel1 1 2) (rel2 2 0))) (my-check ((rel1/rel2?) 1 0 2) => (and (rel1 1 0) (rel2 0 2))) (my-check ((rel1/rel2?) 2 0 1) => (and (rel1 2 0) (rel2 0 1))) (my-check ((rel1/rel2?) 2 1 0) => (and (rel1 2 1) (rel2 1 0))) ; test if all arguments are type checked (my-check (arguments-used (rel1/rel2? ci 0 1 2)) => '(0 1 2)) (my-check (arguments-used (rel1/rel2? ci 0 2 1)) => '(0 1 2)) (my-check (arguments-used (rel1/rel2? ci 1 2 0)) => '(0 1 2)) (my-check (arguments-used (rel1/rel2? ci 1 0 2)) => '(0 1 2)) (my-check (arguments-used (rel1/rel2? ci 2 0 1)) => '(0 1 2)) (my-check (arguments-used (rel1/rel2? ci 2 1 0)) => '(0 1 2)) )))) (define-syntax my-check-chain (syntax-rules () ((my-check-chain chain-rel? rel) (begin ; the chain of length 0 (my-check (chain-rel? ci) => #t) ; a chain of length 1 (my-check (chain-rel? ci 0) => #t) ; all chains of length 2 (my-check (chain-rel? ci 0 0) => (rel 0 0)) (my-check (chain-rel? ci 0 1) => (rel 0 1)) (my-check (chain-rel? ci 1 0) => (rel 1 0)) ; all chains of length 3 (my-check (chain-rel? ci 0 0 0) => (rel 0 0 0)) (my-check (chain-rel? ci 0 0 1) => (rel 0 0 1)) (my-check (chain-rel? ci 0 1 0) => (rel 0 1 0)) (my-check (chain-rel? ci 1 0 0) => (rel 1 0 0)) (my-check (chain-rel? ci 1 1 0) => (rel 1 1 0)) (my-check (chain-rel? ci 1 0 1) => (rel 1 0 1)) (my-check (chain-rel? ci 0 1 1) => (rel 0 1 1)) (my-check (chain-rel? ci 0 1 2) => (rel 0 1 2)) (my-check (chain-rel? ci 0 2 1) => (rel 0 2 1)) (my-check (chain-rel? ci 1 2 0) => (rel 1 2 0)) (my-check (chain-rel? ci 1 0 2) => (rel 1 0 2)) (my-check (chain-rel? ci 2 0 1) => (rel 2 0 1)) (my-check (chain-rel? ci 2 1 0) => (rel 2 1 0)) ; check if all arguments are used (my-check (arguments-used (chain-rel? ci 0)) => '(0)) (my-check (arguments-used (chain-rel? ci 0 1)) => '(0 1)) (my-check (arguments-used (chain-rel? ci 1 0)) => '(0 1)) (my-check (arguments-used (chain-rel? ci 0 1 2)) => '(0 1 2)) (my-check (arguments-used (chain-rel? ci 0 2 1)) => '(0 1 2)) (my-check (arguments-used (chain-rel? ci 1 2 0)) => '(0 1 2)) (my-check (arguments-used (chain-rel? ci 1 0 2)) => '(0 1 2)) (my-check (arguments-used (chain-rel? ci 2 0 1)) => '(0 1 2)) (my-check (arguments-used (chain-rel? ci 2 1 0)) => '(0 1 2)) )))) (define (check:predicates-from-compare) (my-check-chain2 =? =) (my-check-chain2 <? <) (my-check-chain2 >? >) (my-check-chain2 <=? <=) (my-check-chain2 >=? >=) (my-check-chain2 not=? (lambda (x y) (not (= x y)))) (my-check-chain3 </<? < <) (my-check-chain3 </<=? < <=) (my-check-chain3 <=/<? <= <) (my-check-chain3 <=/<=? <= <=) (my-check-chain3 >/>? > >) (my-check-chain3 >/>=? > >=) (my-check-chain3 >=/>? >= >) (my-check-chain3 >=/>=? >= >=) (my-check-chain chain=? =) (my-check-chain chain<? <) (my-check-chain chain>? >) (my-check-chain chain<=? <=) (my-check-chain chain>=? >=) ) ; check:predicates-from-compare ; pairwise-not=? (define pairwise-not=?:long-sequences (let () (define (extremal-pivot-sequence r) ; The extremal pivot sequence of order r is a ; permutation of {0..2^(r+1)-2} such that the ; middle element is minimal, and this property ; holds recursively for each binary subdivision. ; This sequence exposes a naive implementation of ; pairwise-not=? chosing the middle element as pivot. (if (zero? r) '(0) (let* ((s (extremal-pivot-sequence (- r 1))) (ns (length s))) (append (list-ec (:list x s) (+ x 1)) '(0) (list-ec (:list x s) (+ x ns 1)))))) (list (list-ec (: i 4096) i) (list-ec (: i 4097 0 -1) i) (list-ec (: i 4099) (modulo (* 1003 i) 4099)) (extremal-pivot-sequence 11)))) (define pairwise-not=?:short-sequences (let () (define (combinations/repeats n l) ; return list of all sublists of l of size n, ; the order of the elements occur in the sublists ; of the output is the same as in the input (let ((len (length l))) (cond ((= n 0) '()) ((= n 1) (map list l)) ((= len 1) (do ((r '() (cons (car l) r)) (i n (- i 1))) ((= i 0) (list r)))) (else (append (combinations/repeats n (cdr l)) (map (lambda (c) (cons (car l) c)) (combinations/repeats (- n 1) l))))))) (define (permutations l) ; return a list of all permutations of l (let ((len (length l))) (cond ((= len 0) '(())) ((= len 1) (list l)) (else (apply append (map (lambda (p) (insert-every-where (car l) p)) (permutations (cdr l)))))))) (define (insert-every-where x xs) (let loop ((result '()) (before '()) (after xs)) (let ((new (append before (cons x after)))) (cond ((null? after) (cons new result)) (else (loop (cons new result) (append before (list (car after))) (cdr after))))))) (define (sequences n max) (apply append (map permutations (combinations/repeats n (list-ec (: i max) i))))) (append-ec (: n 5) (sequences n 5)))) (define (colliding-compare x y) (ci (modulo x 3) (modulo y 3))) (define (naive-pairwise-not=? compare . xs) (let ((xs (list->vector xs))) (every?-ec (:range i (- (vector-length xs) 1)) (:let xs-i (vector-ref xs i)) (:range j (+ i 1) (vector-length xs)) (:let xs-j (vector-ref xs j)) (not=? compare xs-i xs-j)))) (define (check:pairwise-not=?) ; 0-ary, 1-ary (my-check (pairwise-not=? ci) => #t) (my-check (pairwise-not=? ci 0) => #t) ; 2-ary (my-check (pairwise-not=? ci 0 0) => #f) (my-check (pairwise-not=? ci 0 1) => #t) (my-check (pairwise-not=? ci 1 0) => #t) ; 3-ary (my-check (pairwise-not=? ci 0 0 0) => #f) (my-check (pairwise-not=? ci 0 0 1) => #f) (my-check (pairwise-not=? ci 0 1 0) => #f) (my-check (pairwise-not=? ci 1 0 0) => #f) (my-check (pairwise-not=? ci 1 1 0) => #f) (my-check (pairwise-not=? ci 1 0 1) => #f) (my-check (pairwise-not=? ci 0 1 1) => #f) (my-check (pairwise-not=? ci 0 1 2) => #t) (my-check (pairwise-not=? ci 0 2 1) => #t) (my-check (pairwise-not=? ci 1 2 0) => #t) (my-check (pairwise-not=? ci 1 0 2) => #t) (my-check (pairwise-not=? ci 2 0 1) => #t) (my-check (pairwise-not=? ci 2 1 0) => #t) ; n-ary, n large: [0..n-1], [n,n-1..1], 5^[0..96] mod 97 (my-check (apply pairwise-not=? ci (list-ec (: i 10) i)) => #t) (my-check (apply pairwise-not=? ci (list-ec (: i 100) i)) => #t) (my-check (apply pairwise-not=? ci (list-ec (: i 1000) i)) => #t) (my-check (apply pairwise-not=? ci (list-ec (: i 10 0 -1) i)) => #t) (my-check (apply pairwise-not=? ci (list-ec (: i 100 0 -1) i)) => #t) (my-check (apply pairwise-not=? ci (list-ec (: i 1000 0 -1) i)) => #t) (my-check (apply pairwise-not=? ci (list-ec (: i 97) (modulo (* 5 i) 97))) => #t) ; bury another copy of 72 = 5^50 mod 97 in 5^[0..96] mod 97 (my-check (apply pairwise-not=? ci (append (list-ec (: i 0 23) (modulo (* 5 i) 97)) '(72) (list-ec (: i 23 97) (modulo (* 5 i) 97)))) => #f) (my-check (apply pairwise-not=? ci (append (list-ec (: i 0 75) (modulo (* 5 i) 97)) '(72) (list-ec (: i 75 97) (modulo (* 5 i) 97)))) => #f) ; check if all arguments are used (my-check (arguments-used (pairwise-not=? ci 0)) => '(0)) (my-check (arguments-used (pairwise-not=? ci 0 1)) => '(0 1)) (my-check (arguments-used (pairwise-not=? ci 1 0)) => '(0 1)) (my-check (arguments-used (pairwise-not=? ci 0 2 1)) => '(0 1 2)) (my-check (arguments-used (pairwise-not=? ci 1 2 0)) => '(0 1 2)) (my-check (arguments-used (pairwise-not=? ci 1 0 2)) => '(0 1 2)) (my-check (arguments-used (pairwise-not=? ci 2 0 1)) => '(0 1 2)) (my-check (arguments-used (pairwise-not=? ci 2 1 0)) => '(0 1 2)) (my-check (arguments-used (pairwise-not=? ci 0 0 0 1 0 0 0 2 0 0 0 3)) => '(0 1 2 3)) ; Guess if the implementation is O(n log n): ; The test is run for 2^e pairwise unequal inputs, e >= 1, ; and the number of calls to the compare procedure is counted. ; all pairs: A = Binomial[2^e, 2] = 2^(2 e - 1) * (1 - 2^-e). ; divide and conquer: D = e 2^e. ; Since an implementation can be randomized, the actual count may ; be a random number. We put a threshold at 100 e 2^e and choose ; e such that A/D >= 150, i.e. e >= 12. ; The test is applied to several inputs that are known to cause ; trouble in simplistic sorting algorithms: (0..2^e-1), (2^e+1,2^e..1), ; a pseudo-random permutation, and a sequence with an extremal pivot ; at the center of each subsequence. (my-check-ec (:list input pairwise-not=?:long-sequences) (let ((compares 0)) (apply pairwise-not=? (lambda (x y) (set! compares (+ compares 1)) (ci x y)) input) ; (display compares) (newline) (< compares (* 100 12 4096))) (length input)) ; check many short sequences (my-check-ec (:list input pairwise-not=?:short-sequences) (eq? (apply pairwise-not=? colliding-compare input) (apply naive-pairwise-not=? colliding-compare input)) input) ; check if the arguments are used for short sequences (my-check-ec (:list input pairwise-not=?:short-sequences) (let ((args '())) (apply pairwise-not=? (lambda (x y) (set! args (cons x (cons y args))) (colliding-compare x y)) input) (equal? (list->set args) (list->set input))) input) ) ; check:pairwise-not=? ; min/max (define min/max:sequences (append pairwise-not=?:short-sequences pairwise-not=?:long-sequences)) (define (check:min/max) ; all lists of length 1,2,3 (my-check (min-compare ci 0) => 0) (my-check (min-compare ci 0 0) => 0) (my-check (min-compare ci 0 1) => 0) (my-check (min-compare ci 1 0) => 0) (my-check (min-compare ci 0 0 0) => 0) (my-check (min-compare ci 0 0 1) => 0) (my-check (min-compare ci 0 1 0) => 0) (my-check (min-compare ci 1 0 0) => 0) (my-check (min-compare ci 1 1 0) => 0) (my-check (min-compare ci 1 0 1) => 0) (my-check (min-compare ci 0 1 1) => 0) (my-check (min-compare ci 0 1 2) => 0) (my-check (min-compare ci 0 2 1) => 0) (my-check (min-compare ci 1 2 0) => 0) (my-check (min-compare ci 1 0 2) => 0) (my-check (min-compare ci 2 0 1) => 0) (my-check (min-compare ci 2 1 0) => 0) (my-check (max-compare ci 0) => 0) (my-check (max-compare ci 0 0) => 0) (my-check (max-compare ci 0 1) => 1) (my-check (max-compare ci 1 0) => 1) (my-check (max-compare ci 0 0 0) => 0) (my-check (max-compare ci 0 0 1) => 1) (my-check (max-compare ci 0 1 0) => 1) (my-check (max-compare ci 1 0 0) => 1) (my-check (max-compare ci 1 1 0) => 1) (my-check (max-compare ci 1 0 1) => 1) (my-check (max-compare ci 0 1 1) => 1) (my-check (max-compare ci 0 1 2) => 2) (my-check (max-compare ci 0 2 1) => 2) (my-check (max-compare ci 1 2 0) => 2) (my-check (max-compare ci 1 0 2) => 2) (my-check (max-compare ci 2 0 1) => 2) (my-check (max-compare ci 2 1 0) => 2) ; check that the first minimal value is returned (my-check (min-compare (pair-compare-car ci) '(0 1) '(0 2) '(0 3)) => '(0 1)) (my-check (max-compare (pair-compare-car ci) '(0 1) '(0 2) '(0 3)) => '(0 1)) ; check for many inputs (my-check-ec (:list input min/max:sequences) (= (apply min-compare ci input) (apply min (apply max input) input)) input) (my-check-ec (:list input min/max:sequences) (= (apply max-compare ci input) (apply max (apply min input) input)) input) ; Note the stupid extra argument in the apply for ; the standard min/max makes sure the elements are ; identical when apply truncates the arglist. ) ; check:min/max ; kth-largest (define kth-largest:sequences pairwise-not=?:short-sequences) (define (naive-kth-largest compare k . xs) (let ((vec (list->vector xs))) ; bubble sort: simple, stable, O(|xs|^2) (do-ec (:range n (- (vector-length vec) 1)) (:range i 0 (- (- (vector-length vec) 1) n)) (if>? (compare (vector-ref vec i) (vector-ref vec (+ i 1))) (let ((vec-i (vector-ref vec i))) (vector-set! vec i (vector-ref vec (+ i 1))) (vector-set! vec (+ i 1) vec-i)))) (vector-ref vec (modulo k (vector-length vec))))) (define (check:kth-largest) ; check extensively against naive-kth-largest (my-check-ec (:list input kth-largest:sequences) (: k (- -2 (length input)) (+ (length input) 2)) (= (apply naive-kth-largest colliding-compare k input) (apply kth-largest colliding-compare k input)) (list input k)) ) ;check:kth-largest ; compare-by< etc. procedures (define (check:compare-from-predicates) (my-check-compare (compare-by< <) my-integers) (my-check-compare (compare-by> >) my-integers) (my-check-compare (compare-by<= <=) my-integers) (my-check-compare (compare-by>= >=) my-integers) (my-check-compare (compare-by=/< = <) my-integers) (my-check-compare (compare-by=/> = >) my-integers) ; with explicit arguments (my-check-compare (lambda (x y) (compare-by< < x y)) my-integers) (my-check-compare (lambda (x y) (compare-by> > x y)) my-integers) (my-check-compare (lambda (x y) (compare-by<= <= x y)) my-integers) (my-check-compare (lambda (x y) (compare-by>= >= x y)) my-integers) (my-check-compare (lambda (x y) (compare-by=/< = < x y)) my-integers) (my-check-compare (lambda (x y) (compare-by=/> = > x y)) my-integers) ) ; check:compare-from-predicates (define (check:atomic) (my-check-compare boolean-compare my-booleans) (my-check-compare char-compare my-chars) (my-check-compare char-compare-ci my-chars-ci) (my-check-compare string-compare my-strings) (my-check-compare string-compare-ci my-strings-ci) (my-check-compare symbol-compare my-symbols) (my-check-compare integer-compare my-integers) (my-check-compare rational-compare my-rationals) (my-check-compare real-compare my-reals) (my-check-compare complex-compare my-complexes) (my-check-compare number-compare my-complexes) ) ; check:atomic (define (check:refine-select-cond) ; refine-compare (my-check-compare (lambda (x y) (refine-compare)) '(#f)) (my-check-compare (lambda (x y) (refine-compare (integer-compare x y))) my-integers) (my-check-compare (lambda (x y) (refine-compare (integer-compare (car x) (car y)) (symbol-compare (cdr x) (cdr y)))) '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c))) (my-check-compare (lambda (x y) (refine-compare (integer-compare (car x) (car y)) (symbol-compare (cadr x) (cadr y)) (string-compare (caddr x) (caddr y)))) '((1 a "a") (1 b "a") (1 b "b") (2 b "c") (2 c "a") (3 a "b") (3 c "b"))) ; select-compare (my-check-compare (lambda (x y) (select-compare x y)) '(#f)) (my-check-compare (lambda (x y) (select-compare x y (integer? (ci x y)))) my-integers) (my-check-compare (lambda (x y) (select-compare x y (pair? (integer-compare (car x) (car y)) (symbol-compare (cdr x) (cdr y))))) '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c))) (my-check-compare (lambda (x y) (select-compare x y (else (integer-compare x y)))) my-integers) (my-check-compare (lambda (x y) (select-compare x y (else (integer-compare (car x) (car y)) (symbol-compare (cdr x) (cdr y))))) '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c))) (my-check-compare (lambda (x y) (select-compare x y (symbol? (symbol-compare x y)) (string? (string-compare x y)))) '(a b c "a" "b" "c" 1)) ; implicit (else 0) (my-check-compare (lambda (x y) (select-compare x y (symbol? (symbol-compare x y)) (else (string-compare x y)))) '(a b c "a" "b" "c")) ; test if arguments are only evaluated once (my-check (let ((nx 0) (ny 0) (nt 0)) (select-compare (begin (set! nx (+ nx 1)) 1) (begin (set! ny (+ ny 1)) 2) ((lambda (z) (set! nt (+ nt 1)) #f) 0) ((lambda (z) (set! nt (+ nt 10)) #f) 0) ((lambda (z) (set! nt (+ nt 100)) #f) 0) (else 0)) (list nx ny nt)) => '(1 1 222)) ; cond-compare (my-check-compare (lambda (x y) (cond-compare)) '(#f)) (my-check-compare (lambda (x y) (cond-compare (((integer? x) (integer? y)) (integer-compare x y)))) my-integers) (my-check-compare (lambda (x y) (cond-compare (((pair? x) (pair? y)) (integer-compare (car x) (car y)) (symbol-compare (cdr x) (cdr y))))) '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c))) (my-check-compare (lambda (x y) (cond-compare (else (integer-compare x y)))) my-integers) (my-check-compare (lambda (x y) (cond-compare (else (integer-compare (car x) (car y)) (symbol-compare (cdr x) (cdr y))))) '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a) (3 . c))) (my-check-compare (lambda (x y) (cond-compare (((symbol? x) (symbol? y)) (symbol-compare x y)) (((string? x) (string? y)) (string-compare x y)))) '(a b c "a" "b" "c" 1)) ; implicit (else 0) (my-check-compare (lambda (x y) (cond-compare (((symbol? x) (symbol? y)) (symbol-compare x y)) (else (string-compare x y)))) '(a b c "a" "b" "c")) ) ; check:refine-select-cond ; We define our own list/vector data structure ; as '(my-list x[1] .. x[n]), n >= 0, in order ; to make sure the default ops don't work on it. (define (my-list-checked obj) (if (and (list? obj) (eqv? (car obj) 'my-list)) obj (error "expected my-list but received" obj))) (define (list->my-list list) (cons 'my-list list)) (define (my-empty? x) (null? (cdr (my-list-checked x)))) (define (my-head x) (cadr (my-list-checked x))) (define (my-tail x) (cons 'my-list (cddr (my-list-checked x)))) (define (my-size x) (- (length (my-list-checked x)) 1)) (define (my-ref x i) (list-ref (my-list-checked x) (+ i 1))) (define (check:data-structures) (my-check-compare (pair-compare-car ci) '((1 . b) (2 . a) (3 . c))) (my-check-compare (pair-compare-cdr ci) '((b . 1) (a . 2) (c . 3))) ; pair-compare (my-check-compare pair-compare my-null-or-pairs) (my-check-compare (lambda (x y) (pair-compare ci x y)) my-null-or-pairs) (my-check-compare (lambda (x y) (pair-compare ci symbol-compare x y)) '((1 . a) (1 . b) (2 . b) (2 . c) (3 . a))) ; list-compare (my-check-compare list-compare my-lists) (my-check-compare (lambda (x y) (list-compare ci x y)) my-lists) (my-check-compare (lambda (x y) (list-compare x y my-empty? my-head my-tail)) (map list->my-list my-lists)) (my-check-compare (lambda (x y) (list-compare ci x y my-empty? my-head my-tail)) (map list->my-list my-lists)) ; list-compare-as-vector (my-check-compare list-compare-as-vector my-list-as-vectors) (my-check-compare (lambda (x y) (list-compare-as-vector ci x y)) my-list-as-vectors) (my-check-compare (lambda (x y) (list-compare-as-vector x y my-empty? my-head my-tail)) (map list->my-list my-list-as-vectors)) (my-check-compare (lambda (x y) (list-compare-as-vector ci x y my-empty? my-head my-tail)) (map list->my-list my-list-as-vectors)) ; vector-compare (my-check-compare vector-compare my-vectors) (my-check-compare (lambda (x y) (vector-compare ci x y)) my-vectors) (my-check-compare (lambda (x y) (vector-compare x y my-size my-ref)) (map list->my-list my-list-as-vectors)) (my-check-compare (lambda (x y) (vector-compare ci x y my-size my-ref)) (map list->my-list my-list-as-vectors)) ; vector-compare-as-list (my-check-compare vector-compare-as-list my-vector-as-lists) (my-check-compare (lambda (x y) (vector-compare-as-list ci x y)) my-vector-as-lists) (my-check-compare (lambda (x y) (vector-compare-as-list x y my-size my-ref)) (map list->my-list my-lists)) (my-check-compare (lambda (x y) (vector-compare-as-list ci x y my-size my-ref)) (map list->my-list my-lists)) ) ; check:data-structures (define (check:default-compare) (my-check-compare default-compare my-objects) ; check if default-compare refines pair-compare (my-check-ec (:list x (index ix) my-objects) (:list y (index iy) my-objects) (:let c-coarse (pair-compare x y)) (:let c-fine (default-compare x y)) (or (eqv? c-coarse 0) (eqv? c-fine c-coarse)) (list x y)) ; check if default-compare passes on debug-compare (my-check-compare (debug-compare default-compare) my-objects) ) ; check:default-compare (define (sort-by-less xs pred) ; trivial quicksort (if (or (null? xs) (null? (cdr xs))) xs (append (sort-by-less (list-ec (:list x (cdr xs)) (if (pred x (car xs))) x) pred) (list (car xs)) (sort-by-less (list-ec (:list x (cdr xs)) (if (not (pred x (car xs)))) x) pred)))) (define (check:more-examples) ; define recursive order on tree type (nodes are dotted pairs) (my-check-compare (letrec ((c (lambda (x y) (cond-compare (((null? x) (null? y)) 0) (else (pair-compare c c x y)))))) c) (list '() (list '()) (list '() '()) (list (list '()))) ;'(() (() . ()) (() . (() . ())) ((() . ()) . ())) ; Chicken can't parse this ? ) ; redefine default-compare using select-compare (my-check-compare (letrec ((c (lambda (x y) (select-compare x y (null? 0) (pair? (pair-compare c c x y)) (boolean? (boolean-compare x y)) (char? (char-compare x y)) (string? (string-compare x y)) (symbol? (symbol-compare x y)) (number? (number-compare x y)) (vector? (vector-compare c x y)) (else (error "unrecognized type in c" x y)))))) c) my-objects) ; redefine default-compare using cond-compare (my-check-compare (letrec ((c (lambda (x y) (cond-compare (((null? x) (null? y)) 0) (((pair? x) (pair? y)) (pair-compare c c x y)) (((boolean? x) (boolean? y)) (boolean-compare x y)) (((char? x) (char? y)) (char-compare x y)) (((string? x) (string? y)) (string-compare x y)) (((symbol? x) (symbol? y)) (symbol-compare x y)) (((number? x) (number? y)) (number-compare x y)) (((vector? x) (vector? y)) (vector-compare c x y)) (else (error "unrecognized type in c" x y)))))) c) my-objects) ; compare strings with character order reversed (my-check-compare (lambda (x y) (vector-compare-as-list (lambda (x y) (char-compare y x)) x y string-length string-ref)) '("" "b" "bb" "ba" "a" "ab" "aa")) ; examples from SRFI text for <? etc. (my-check (>? "laugh" "LOUD") => #t) (my-check (<? string-compare-ci "laugh" "LOUD") => #t) (my-check (sort-by-less '(1 a "b") (<?)) => '("b" a 1)) (my-check (sort-by-less '(1 a "b") (>?)) => '(1 a "b")) ) ; check:more-examples ; Real life examples ; ================== ; (update/insert compare x s) ; inserts x into list s, or updates an equivalent element by x. ; It is assumed that s is sorted with respect to compare, ; i.e. (apply chain<=? compare s). The result is a list with x ; replacing the first element s[i] for which (=? compare s[i] x), ; or with x inserted in the proper place. ; The algorithm uses linear insertion from the front. (define (insert/update compare x s) ; insert x into list s, or update (if (null? s) (list x) (if3 (compare x (car s)) (cons x s) (cons x (cdr s)) (cons (car s) (insert/update compare x (cdr s)))))) ; (index-in-vector compare vec x) ; an index i such that (=? compare vec[i] x), or #f if there is none. ; It is assumed that s is sorted with respect to compare, ; i.e. (apply chain<=? compare (vector->list s)). If there are ; several elements equivalent to x then it is unspecified which ; these is chosen. ; The algorithm uses binary search. (define (index-in-vector compare vec x) (let binary-search ((lo -1) (hi (vector-length vec))) ; invariant: vec[lo] < x < vec[hi] (if (=? (- hi lo) 1) #f (let ((mi (quotient (+ lo hi) 2))) (if3 (compare x (vector-ref vec mi)) (binary-search lo mi) mi (binary-search mi hi)))))) ; Run the checks ; ============== (my-check-reset) ; comment in/out as needed (check:atomic) (check:if3) (check:ifs) (check:predicates-from-compare) (check:pairwise-not=?) (check:min/max) (check:kth-largest) (check:compare-from-predicates) (check:refine-select-cond) (check:data-structures) (check:default-compare) (check:more-examples) (my-check-summary) ; all examples (99486) correct? ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a69.sls����������������������������������������������������0000664�0000000�0000000�00000001231�13751542066�0020171�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :69) (export alist->hash-table hash hash-by-identity hash-table->alist hash-table-copy hash-table-delete! hash-table-equivalence-function hash-table-exists? hash-table-fold hash-table-hash-function hash-table-keys hash-table-merge! hash-table-ref hash-table-ref/default hash-table-set! hash-table-size hash-table-update! hash-table-update!/default hash-table-values hash-table-walk hash-table? make-hash-table string-ci-hash string-hash) (import (srfi :69 basic-hash-tables)) ) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a69/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017451�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a69/basic-hash-tables.sls����������������������������������0000664�0000000�0000000�00000011352�13751542066�0023450�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright (C) 2009 Andreas Rottmann. All rights reserved. Licensed ;; under an MIT-style license. See the file LICENSE in the original ;; collection this file is distributed with. (library (srfi :69 basic-hash-tables) (export ;; Type constructors and predicate make-hash-table hash-table? alist->hash-table ;; Reflective queries hash-table-equivalence-function hash-table-hash-function ;; Dealing with single elements hash-table-ref hash-table-ref/default hash-table-set! hash-table-delete! hash-table-exists? hash-table-update! hash-table-update!/default ;; Dealing with the whole contents hash-table-size hash-table-keys hash-table-values hash-table-walk hash-table-fold hash-table->alist hash-table-copy hash-table-merge! ;; Hashing hash string-hash string-ci-hash hash-by-identity) (import (rename (rnrs) (string-hash rnrs:string-hash) (string-ci-hash rnrs:string-ci-hash))) (define make-hash-table (case-lambda ((eql? hash) (make-hashtable hash eql?)) ((eql?) (cond ((eq? eql? eq?) (make-eq-hashtable)) ((eq? eql? eqv?) (make-eqv-hashtable)) ((eq? eql? equal?) (make-hashtable equal-hash eql?)) ((eq? eql? string=?) (make-hashtable rnrs:string-hash eql?)) ((eq? eql? string-ci=?) (make-hashtable rnrs:string-ci-hash eql?)) (else (assertion-violation 'make-hash-table "unrecognized equivalence predicate" eql?)))) (() (make-hashtable equal-hash equal?)))) (define hash-table? hashtable?) (define not-there (list 'not-there)) (define (alist->hash-table alist . args) (let ((table (apply make-hash-table args))) (for-each (lambda (entry) (hashtable-update! table (car entry) (lambda (x) (if (eq? x not-there) (cdr entry) x)) not-there)) alist) table)) (define hash-table-equivalence-function hashtable-equivalence-function) (define hash-table-hash-function hashtable-hash-function) (define (failure-thunk who key) (lambda () (assertion-violation who "no association for key" key))) (define hash-table-ref (case-lambda ((table key thunk) (let ((val (hashtable-ref table key not-there))) (if (eq? val not-there) (thunk) val))) ((table key) (hash-table-ref table key (failure-thunk 'hash-table-ref key))))) (define hash-table-ref/default hashtable-ref) (define hash-table-set! hashtable-set!) (define hash-table-delete! hashtable-delete!) (define hash-table-exists? hashtable-contains?) (define hash-table-update! (case-lambda ((table key proc thunk) (hashtable-update! table key (lambda (val) (if (eq? val not-there) (thunk) (proc val))) not-there)) ((table key proc) (hash-table-update! table key proc (failure-thunk 'hash-table-update! key))))) (define hash-table-update!/default hashtable-update!) (define hash-table-size hashtable-size) (define (hash-table-keys table) (vector->list (hashtable-keys table))) (define (hash-table-values table) (let-values (((keys values) (hashtable-entries table))) (vector->list values))) (define (hash-table-walk table proc) (let-values (((keys values) (hashtable-entries table))) (vector-for-each proc keys values))) (define (hash-table-fold table kons knil) (let-values (((keys values) (hashtable-entries table))) (let ((size (vector-length keys))) (let loop ((i 0) (val knil)) (if (>= i size) val (loop (+ i 1) (kons (vector-ref keys i) (vector-ref values i) val))))))) (define (hash-table->alist table) (hash-table-fold table (lambda (k v l) (cons (cons k v) l)) '())) (define hash-table-copy hashtable-copy) (define (hash-table-merge! table1 table2) (hash-table-walk table2 (lambda (k v) (hashtable-set! table1 k v))) table1) (define (make-hasher hash-proc) (case-lambda ((obj) ;; R6RS doesn't guarantee that the result of the hash procedure ;; is non-negative, so we use mod. (mod (hash-proc obj) (greatest-fixnum))) ((obj bound) (mod (hash-proc obj) bound)))) (define hash (make-hasher equal-hash)) (define hash-by-identity (make-hasher equal-hash)) ;; Very slow. (define string-hash (make-hasher rnrs:string-hash)) (define string-ci-hash (make-hasher rnrs:string-ci-hash)) ) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78.sls����������������������������������������������������0000664�0000000�0000000�00000000362�13751542066�0020175�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :78) (export check check-ec check-passed? check-report check-reset! check-set-mode!) (import (srfi :78 lightweight-testing)) ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017451�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/check.scm����������������������������������������������0000664�0000000�0000000�00000024015�13751542066�0021234�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Modified by Derick Eddington to improve the print-outs. All lines of printed ;; expected results (for failed checks) are commented-out so they don't break ;; syntactic-datum delimiting, so a print-out can be programmatically read and ;; processed. When a non-default equality predicate is used, (=> <expr>) is ;; printed. ; <PLAINTEXT> ; Copyright (c) 2005-2006 Sebastian Egner. ; ; Permission is hereby granted, free of charge, to any person obtaining ; a copy of this software and associated documentation files (the ; ``Software''), to deal in the Software without restriction, including ; without limitation the rights to use, copy, modify, merge, publish, ; distribute, sublicense, and/or sell copies of the Software, and to ; permit persons to whom the Software is furnished to do so, subject to ; the following conditions: ; ; The above copyright notice and this permission notice shall be ; included in all copies or substantial portions of the Software. ; ; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, ; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ; ; ----------------------------------------------------------------------- ; ; Lightweight testing (reference implementation) ; ============================================== ; ; Sebastian.Egner@philips.com ; in R5RS + SRFI 23 (error) + SRFI 42 (comprehensions) ; ; history of this file: ; SE, 25-Oct-2004: first version based on code used in SRFIs 42 and 67 ; SE, 19-Jan-2006: (arg ...) made optional in check-ec ; ; Naming convention "check:<identifier>" is used only internally. ; -- portability -- ; PLT: (require (lib "23.ss" "srfi") (lib "42.ss" "srfi")) ; Scheme48: ,open srfi-23 srfi-42 ; -- utilities -- (define check:write write) (define (print/header/padded x header padding) (define (print/lines) (let* ((str (call-with-string-output-port (lambda (sop) (check:write x sop)))) (sip (open-string-input-port str))) (let loop ((lines '())) (let ((l (get-line sip))) (if (eof-object? l) (reverse lines) (loop (cons l lines))))))) (let ((lines (print/lines))) (display header) (display (car lines)) (let loop ((lines (cdr lines))) (unless (null? lines) (newline) (display padding) (display (car lines)) (loop (cdr lines)))))) ; You can also use a pretty printer if you have one. ; However, the output might not improve for most cases ; because the pretty printers usually output a trailing ; newline. ; PLT: (require (lib "pretty.ss")) (define check:write pretty-print) ; Scheme48: ,open pp (define check:write p) ; -- mode -- (define check:mode #f) (define (check-set-mode! mode) (set! check:mode (case mode ((off) 0) ((summary) 1) ((report-failed) 10) ((report) 100) (else (error "unrecognized mode" mode))))) ; -- state -- (define check:correct #f) (define check:failed #f) (define (check-reset!) (set! check:correct 0) (set! check:failed '())) (define (check:add-correct!) (set! check:correct (+ check:correct 1))) (define (check:add-failed! expression actual-result expected-result pred) (set! check:failed (cons (list expression actual-result expected-result pred) check:failed))) ; -- reporting -- (define (check:report-expression expression pred) (newline) (check:write expression) (if pred (begin (print/header/padded pred "(=> " " ") (display ")")) (display "=>")) (newline)) (define (check:report-actual-result actual-result) (check:write actual-result) (display ";; ")) (define (check:report-correct cases) (display "correct") (if (not (= cases 1)) (begin (display " (") (display cases) (display " cases checked)"))) (newline)) (define (check:report-failed expected-result) (display "*** failed ***") (newline) (print/header/padded expected-result ";; expected result: " ";; ") (newline)) (define (check-report) (if (>= check:mode 1) (begin (newline) (display ";; *** checks *** : ") (display check:correct) (display " correct, ") (display (length check:failed)) (display " failed.") (if (or (null? check:failed) (<= check:mode 1)) (newline) (let* ((w (car (reverse check:failed))) (expression (car w)) (actual-result (cadr w)) (expected-result (caddr w)) (pred (cadddr w))) (display " First failed example:") (newline) (check:report-expression expression pred) (check:report-actual-result actual-result) (check:report-failed expected-result)))))) (define (check-passed? expected-total-count) (and (= (length check:failed) 0) (= check:correct expected-total-count))) ; -- simple checks -- (define (check:proc expression thunk equal equal-expr expected-result) (define equal-expr* (and (not (eq? equal? equal)) equal-expr)) (case check:mode ((0) #f) ((1) (let ((actual-result (thunk))) (if (equal actual-result expected-result) (check:add-correct!) (check:add-failed! expression actual-result expected-result equal-expr*)))) ((10) (let ((actual-result (thunk))) (if (equal actual-result expected-result) (check:add-correct!) (begin (check:report-expression expression equal-expr*) (check:report-actual-result actual-result) (check:report-failed expected-result) (check:add-failed! expression actual-result expected-result equal-expr*))))) ((100) (check:report-expression expression equal-expr*) (let ((actual-result (thunk))) (check:report-actual-result actual-result) (if (equal actual-result expected-result) (begin (check:report-correct 1) (check:add-correct!)) (begin (check:report-failed expected-result) (check:add-failed! expression actual-result expected-result equal-expr*))))) (else (error "unrecognized check:mode" check:mode))) (if #f #f)) (define-syntax check (syntax-rules (=>) ((check expr => expected) (check expr (=> equal?) expected)) ((check expr (=> equal) expected) (if (>= check:mode 1) (check:proc 'expr (lambda () #F expr) equal 'equal expected))))) ; -- parametric checks -- (define (check:proc-ec w) (let ((correct? (car w)) (expression (cadr w)) (actual-result (caddr w)) (expected-result (cadddr w)) (cases (car (cddddr w))) (equal-expr (cadr (cddddr w)))) (if correct? (begin (if (>= check:mode 100) (begin (check:report-expression expression equal-expr) (check:report-actual-result actual-result) (check:report-correct cases))) (check:add-correct!)) (begin (if (>= check:mode 10) (begin (check:report-expression expression equal-expr) (check:report-actual-result actual-result) (check:report-failed expected-result))) (check:add-failed! expression actual-result expected-result equal-expr))))) (define-syntax check-ec:make (syntax-rules (=>) ((check-ec:make qualifiers expr (=> equal) expected (arg ...)) (if (>= check:mode 1) (check:proc-ec (let* ((cases 0) (eq-p equal) (equal-expr (and (not (eq? equal? eq-p)) 'equal))) (let ((w (first-ec #f qualifiers (:let equal-pred eq-p) (:let expected-result expected) (:let actual-result (let ((arg arg) ...) ; (*) expr)) (begin (set! cases (+ cases 1))) (if (not (equal-pred actual-result expected-result))) (list (list 'let (list (list 'arg arg) ...) 'expr) actual-result expected-result cases equal-expr)))) (if w (cons #f w) (list #t '(check-ec qualifiers expr (=> equal) expected (arg ...)) (if #f #f) (if #f #f) cases equal-expr))))))))) ; (*) is a compile-time check that (arg ...) is a list ; of pairwise disjoint bound variables at this point. (define-syntax check-ec (syntax-rules (nested =>) ((check-ec expr => expected) (check-ec:make (nested) expr (=> equal?) expected ())) ((check-ec expr (=> equal) expected) (check-ec:make (nested) expr (=> equal) expected ())) ((check-ec expr => expected (arg ...)) (check-ec:make (nested) expr (=> equal?) expected (arg ...))) ((check-ec expr (=> equal) expected (arg ...)) (check-ec:make (nested) expr (=> equal) expected (arg ...))) ((check-ec qualifiers expr => expected) (check-ec:make qualifiers expr (=> equal?) expected ())) ((check-ec qualifiers expr (=> equal) expected) (check-ec:make qualifiers expr (=> equal) expected ())) ((check-ec qualifiers expr => expected (arg ...)) (check-ec:make qualifiers expr (=> equal?) expected (arg ...))) ((check-ec qualifiers expr (=> equal) expected (arg ...)) (check-ec:make qualifiers expr (=> equal) expected (arg ...))) ((check-ec (nested q1 ...) q etc ...) (check-ec (nested q1 ... q) etc ...)) ((check-ec q1 q2 etc ...) (check-ec (nested q1 q2) etc ...)))) (check-set-mode! 'report) (check-reset!) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/examples.scm�������������������������������������������0000664�0000000�0000000�00000004776�13751542066�0022011�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������; <PLAINTEXT> ; Copyright (c) 2005-2006 Sebastian Egner. ; ; Permission is hereby granted, free of charge, to any person obtaining ; a copy of this software and associated documentation files (the ; ``Software''), to deal in the Software without restriction, including ; without limitation the rights to use, copy, modify, merge, publish, ; distribute, sublicense, and/or sell copies of the Software, and to ; permit persons to whom the Software is furnished to do so, subject to ; the following conditions: ; ; The above copyright notice and this permission notice shall be ; included in all copies or substantial portions of the Software. ; ; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, ; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ; ; ----------------------------------------------------------------------- ; Lightweight testing (examples) ; ============================== ; ; Sebastian.Egner@philips.com ; in R5RS + SRFI 23 (error) + SRFI 42 (comprehensions) ; ; history of this file: ; SE, 25-Oct-2004: first version ; -- portability -- ; PLT: ; (require (lib "23.ss" "srfi") (lib "42.ss" "srfi")) (load "check.scm") ; (load "examples.scm") ; Scheme48: ; ,open srfi-23 srfi-42 ; ,load check.scm examples.scm ; -- simple test -- (check (+ 1 1) => 2) (check (+ 1 1) => 3) ; fails ; -- different equality predicate -- (check (vector 1) => (vector 1)) (check (vector 1) (=> eq?) (vector 1)) ; fails ; -- parametric tests -- (check-ec (+ 1 1) => 2) (check-ec (: x 10) (+ x 1) => (+ x 1) (x)) (check-ec (: e 100) (positive? (expt 2 e)) => #t (e)) ; fails on fixnums (check-ec (: e 100) (:let x (expt 2.0 e)) (= (+ x 1) x) => #f (x)) ; fails (check-ec (: e 100) (:let x (expt 2.0 e)) (= (+ x 1) x) => #f) (check-ec (: x 10) (: y 10) (: z 10) (* x (+ y z)) => (+ (* x y) (* x z)) (x y z)) ; passes with 10^3 cases checked ; -- toy examples -- (define (fib n) (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) (check (fib 1) => 1) (check (fib 2) => 1) (check-ec (: n 1 31) (even? (fib n)) => (= (modulo n 3) 0) (n)) ; -- reporting -- (check-report)��chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/lightweight-testing.sls��������������������������������0000664�0000000�0000000�00000001604�13751542066�0024167�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :78 lightweight-testing) (export check check-ec check-report check-set-mode! check-reset! check-passed?) (import (rnrs) (srfi :78 lightweight-testing compat) (srfi :39 parameters) (srfi :42 eager-comprehensions) (srfi :23 error tricks) (for (srfi private vanish) expand) (srfi private include)) (define-syntax check:mode (identifier-syntax (_ (check:mode-param)) ((set! _ expr) (check:mode-param expr)))) (define check:mode-param (make-parameter #F)) (let-syntax ((define (vanish-define define (check:write check:mode)))) (SRFI-23-error->R6RS "(library (srfi :78 lightweight-testing))" (include/resolve ("srfi" "%3a78") "check.scm"))) ) ����������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/lightweight-testing/�����������������������������������0000775�0000000�0000000�00000000000�13751542066�0023443�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/lightweight-testing/compat.chezscheme.sls��������������0000664�0000000�0000000�00000001641�13751542066�0027570�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;; Copyright (c) 2012 Aaron W. Hsu <arcfide@sacrideo.us> ;;; ;;; Permission to use, copy, modify, and distribute this software for ;;; any purpose with or without fee is hereby granted, provided that the ;;; above copyright notice and this permission notice appear in all ;;; copies. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE ;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL ;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA ;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR ;;; PERFORMANCE OF THIS SOFTWARE. (library (srfi :78 lightweight-testing compat) (export (rename (pretty-print check:write))) (import (chezscheme))) �����������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/lightweight-testing/compat.guile.sls�������������������0000664�0000000�0000000�00000000203�13751542066�0026550�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi srfi-78 compat) (export (rename (pretty-print check:write))) (import (only (ice-9 pretty-print) pretty-print))) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/lightweight-testing/compat.ikarus.sls������������������0000664�0000000�0000000�00000000456�13751542066�0026753�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :78 lightweight-testing compat) (export (rename (pretty-print check:write))) (import (only (ikarus) pretty-print)) ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/lightweight-testing/compat.ironscheme.sls��������������0000664�0000000�0000000�00000000704�13751542066�0027605�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an ;; MIT-style license. My license is in the file named LICENSE from the original ;; collection this file is distributed with. If this file is redistributed with ;; some other collection, my license must also be included. (library (srfi :78 lightweight-testing compat) (export (rename (pretty-print check:write))) (import (only (ironscheme) pretty-print)) ) ������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/lightweight-testing/compat.larceny.sls�����������������0000664�0000000�0000000�00000000453�13751542066�0027107�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :78 lightweight-testing compat) (export (rename (pretty-print check:write))) (import (primitives pretty-print)) ) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/lightweight-testing/compat.mzscheme.sls����������������0000664�0000000�0000000�00000000465�13751542066�0027270�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :78 lightweight-testing compat) (export (rename (pretty-print check:write))) (import (only (scheme pretty) pretty-print)) ) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a78/lightweight-testing/compat.ypsilon.sls�����������������0000664�0000000�0000000�00000000666�13751542066�0027155�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :78 lightweight-testing compat) (export check:write) (import (rnrs) (only (core) pretty-print)) (define check:write (case-lambda ((x) (check:write x (current-output-port))) ((x p) (pretty-print x p) (newline p)))) ) ��������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a8.sls�����������������������������������������������������0000664�0000000�0000000�00000000221�13751542066�0020100�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :8) (export receive) (import (srfi :8 receive)) ) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a8/��������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017362�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a8/receive.sls���������������������������������������������0000664�0000000�0000000�00000000634�13751542066�0021532�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :8 receive) (export receive) (import (rnrs)) (define-syntax receive (syntax-rules () ((_ formals expression b b* ...) (call-with-values (lambda () expression) (lambda formals b b* ...))))) ) ����������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a9.sls�����������������������������������������������������0000664�0000000�0000000�00000000234�13751542066�0020105�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :9) (export define-record-type) (import (srfi :9 records)) ) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a9/��������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017363�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a9/records.sls���������������������������������������������0000664�0000000�0000000�00000003544�13751542066�0021555�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :9 records) (export (rename (my:define-record-type define-record-type))) (import (rnrs)) (define-syntax my:define-record-type (lambda (stx) (syntax-case stx () ((_ type (constructor constructor-tag ...) predicate (field-tag accessor setter ...) ...) (and (for-all identifier? #'(type constructor constructor-tag ... predicate field-tag ... accessor ... setter ... ...)) (for-all (lambda (s) (<= 0 (length s) 1)) #'((setter ...) ...)) (for-all (lambda (ct) (memp (lambda (ft) (bound-identifier=? ct ft)) #'(field-tag ...))) #'(constructor-tag ...))) (with-syntax (((field-clause ...) (map (lambda (clause) (if (= 2 (length clause)) #`(immutable . #,clause) #`(mutable . #,clause))) #'((field-tag accessor setter ...) ...))) ((unspec-tag ...) (remp (lambda (ft) (memp (lambda (ct) (bound-identifier=? ft ct)) #'(constructor-tag ...))) #'(field-tag ...)))) #'(define-record-type (type constructor predicate) (protocol (lambda (ctor) (lambda (constructor-tag ...) (define unspec-tag) ... (ctor field-tag ...)))) (fields field-clause ...))))))) ) ������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a98.sls����������������������������������������������������0000664�0000000�0000000�00000000323�13751542066�0020174�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :98) (export get-environment-variable get-environment-variables) (import (srfi :98 os-environment-variables)) ) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a98/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017453�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a98/os-environment-variables.chezscheme.sls����������������0000664�0000000�0000000�00000011670�13751542066�0027251�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;; Copyright (c) 2012 Aaron W. Hsu <arcfide@sacrideo.us> ;;; ;;; Permission to use, copy, modify, and distribute this software for ;;; any purpose with or without fee is hereby granted, provided that the ;;; above copyright notice and this permission notice appear in all ;;; copies. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE ;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL ;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA ;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR ;;; PERFORMANCE OF THIS SOFTWARE. (library (srfi :98 os-environment-variables) (export get-environment-variables (rename (getenv get-environment-variable))) (import (rnrs) (rnrs mutable-strings) (only (chezscheme) getenv string-copy! foreign-ref foreign-entry foreign-procedure machine-type load-shared-object ftype-sizeof)) (define (get-environment-variables) (read-environ (get-environ-pointer))) (define-record-type text-buffer (nongenerative) (fields (mutable b) (mutable i)) (protocol (lambda (new) (lambda () (new (make-string 20) 0))))) (define extend-buffer! (let () (define (finish tb b i c) (string-set! b i c) (text-buffer-i-set! tb (fx+ i 1))) (lambda (tb c) (let ([b (text-buffer-b tb)] [i (text-buffer-i tb)]) (if (fx=? i (string-length b)) (let ([new-b (make-string (* i i))]) (string-copy! b 0 new-b 0 i) (text-buffer-b-set! tb new-b) (finish tb new-b i c)) (finish tb b i c)))))) (define extract-and-clear-buffer! (lambda (tb) (let ([i (text-buffer-i tb)]) (text-buffer-i-set! tb 0) (substring (text-buffer-b tb) 0 i)))) (define read-entry (let () (define (s0 ptr offset tb) (let ([c (foreign-ref 'char ptr offset)]) (cond [(char=? c #\nul) (values (cons (extract-and-clear-buffer! tb) #f) (fx+ offset (ftype-sizeof char)))] [(char=? c #\=) (s1 ptr (fx+ offset (ftype-sizeof char)) tb (extract-and-clear-buffer! tb))] [else (extend-buffer! tb c) (s0 ptr (fx+ offset (ftype-sizeof char)) tb)]))) (define (s1 ptr offset tb key) (let ([c (foreign-ref 'char ptr offset)]) (cond [(char=? c #\nul) (values (cons key (extract-and-clear-buffer! tb)) (fx+ offset (ftype-sizeof char)))] [else (extend-buffer! tb c) (s1 ptr (fx+ offset (ftype-sizeof char)) tb key)]))) s0)) (define read-environ (if (memq (machine-type) '(i3nt a6nt ti3nt ta6nt)) (lambda (ptr) (let ([tb (make-text-buffer)]) (let loop ([offset 0] [ls '()]) (let ([c (foreign-ref 'char ptr offset)]) (if (char=? c #\nul) ls (let-values ([(entry offset) (read-entry ptr offset tb)]) (loop offset (cons entry ls)))))))) (lambda (ptr) (let ([tb (make-text-buffer)]) (let loop ([offset 0] [ls '()]) (let ([entry-ptr (foreign-ref 'void* ptr offset)]) (if (= entry-ptr 0) ls (let-values ([(entry char-offset) (read-entry entry-ptr 0 tb)]) (loop (fx+ offset (ftype-sizeof void*)) (cons entry ls)))))))))) (define get-environ-pointer (case (machine-type) [(i3nt a6nt ti3nt ta6nt) (load-shared-object "msvcrt.dll") (load-shared-object "kernel32.dll") (foreign-procedure "GetEnvironmentStrings" () void*)] [(i3osx a6osx ti3osx ta6osx) (load-shared-object "libc.dylib") (let ([p (foreign-procedure "_NSGetEnviron" () void*)]) (lambda () (let ([ptr-to-ptr (p)]) (if (= ptr-to-ptr 0) 0 (foreign-ref 'void* ptr-to-ptr 0)))))] [(i3le a6le ti3le ta6le arm32le ppc32le) (load-shared-object "libc.so.6") (lambda () (let ([ptr-to-ptr (foreign-entry "environ")]) (if (= ptr-to-ptr 0) 0 (foreign-ref 'void* ptr-to-ptr 0))))] [(i3ob a6ob ti3ob ta6ob i3nb a6nb ti3nb ta6nb) (load-shared-object "libc.so") (lambda () (let ([ptr-to-ptr (foreign-entry "environ")]) (if (= ptr-to-ptr 0) 0 (foreign-ref 'void* ptr-to-ptr 0))))] [else (error 'get-environment-variables "currently unsupoorted on ~s" (machine-type))]))) ������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a98/os-environment-variables.ikarus.sls��������������������0000664�0000000�0000000�00000000544�13751542066�0026427�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :98 os-environment-variables) (export (rename (getenv get-environment-variable) (environ get-environment-variables))) (import (only (ikarus) getenv environ))) ������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a98/os-environment-variables.ironscheme.sls����������������0000664�0000000�0000000�00000000701�13751542066�0027260�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi :98 os-environment-variables) (export get-environment-variables get-environment-variable) (import (ironscheme) (except (ironscheme environment) get-environment-variables) (rename (ironscheme environment) (get-environment-variables get-env-vars))) (define (get-environment-variables) (let-values (((k v) (hashtable-entries (get-env-vars)))) (map cons (vector->list k) (vector->list v)))) ) ���������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a98/os-environment-variables.larceny.sls�������������������0000664�0000000�0000000�00000005236�13751542066�0026571�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. ;; NOTE: I believe this currently works only on Linux. ;; NOTE: If Larceny's FFI changes, this may no longer work. (library (srfi :98 os-environment-variables) (export get-environment-variable get-environment-variables) (import (rnrs base) (rnrs control) (rnrs bytevectors) (rnrs io ports) (primitives foreign-procedure #;foreign-variable foreign-null-pointer? sizeof:pointer %peek-pointer %peek8u void*->address ffi/dlopen ffi/dlsym) (srfi private feature-cond)) ;; TODO: Will the convenient string converters use the native transcoder in ;; the future? So that scheme-str->c-str-bv and c-str-ptr->scheme-str ;; won't be needed. (define (scheme-str->c-str-bv x) (let* ((bv (string->bytevector x (native-transcoder))) (len (bytevector-length bv)) (bv/z (make-bytevector (+ 1 len)))) (bytevector-copy! bv 0 bv/z 0 len) (bytevector-u8-set! bv/z len 0) bv/z)) (define (c-str-ptr->scheme-str x) (let loop ((x x) (a '())) (let ((b (%peek8u x))) (if (zero? b) (bytevector->string (u8-list->bytevector (reverse a)) (native-transcoder)) (loop (+ 1 x) (cons b a)))))) (define getenv (foreign-procedure "getenv" '(boxed) 'void*)) (define (get-environment-variable name) (unless (string? name) (assertion-violation 'get-environment-variable "not a string" name)) (let ((p (getenv (scheme-str->c-str-bv name)))) (and p (c-str-ptr->scheme-str (void*->address p))))) ;; TODO: Will foreign-variable support a pointer type in the future? ;; Would this be the correct way to use it? #;(define environ (foreign-variable "environ" 'void*)) ;; TODO: Is (ffi/dlopen "") okay? It works for me on Ubuntu Linux 8.10. (define environ (feature-cond (linux (%peek-pointer (ffi/dlsym (ffi/dlopen "") "environ"))))) (define (get-environment-variables) (define (entry->pair x) (let* ((s (c-str-ptr->scheme-str x)) (len (string-length s))) (let loop ((i 0)) (if (< i len) (if (char=? #\= (string-ref s i)) (cons (substring s 0 i) (substring s (+ 1 i) len)) (loop (+ 1 i))) (cons s #F))))) (let loop ((e environ) (a '())) (let ((entry (%peek-pointer e))) (if (foreign-null-pointer? entry) a (loop (+ sizeof:pointer e) (cons (entry->pair entry) a)))))) ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a98/os-environment-variables.mzscheme.sls������������������0000664�0000000�0000000�00000002125�13751542066�0026741�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. ;; Inspired by Danny Yoo's get-environment PLaneT package. (library (srfi :98 os-environment-variables) (export (rename (getenv get-environment-variable)) get-environment-variables) (import (rnrs base) (only (scheme base) getenv) (scheme foreign)) (unsafe!) (define environ (get-ffi-obj "environ" (ffi-lib #F) _pointer)) (define (get-environment-variables) (let loop ((i 0) (accum '())) (let ((next (ptr-ref environ _string/locale i))) (if next (loop (+ 1 i) (cons (let loop ((i 0) (len (string-length next))) (if (< i len) (if (char=? #\= (string-ref next i)) (cons (substring next 0 i) (substring next (+ 1 i) len)) (loop (+ 1 i) len)) (cons next #F))) accum)) accum)))) ) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a98/os-environment-variables.ypsilon.sls�������������������0000664�0000000�0000000�00000000660�13751542066�0026625�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi :98 os-environment-variables) (export (rename (lookup-process-environment get-environment-variable) (process-environment->alist get-environment-variables))) (import (only (core) lookup-process-environment process-environment->alist))) ��������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a99.sls����������������������������������������������������0000664�0000000�0000000�00000000565�13751542066�0020205�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by private/make-aliased-libraries.sps (library (srfi :99) (export define-record-type make-rtd record-rtd record? rtd-accessor rtd-all-field-names rtd-constructor rtd-field-mutable? rtd-field-names rtd-mutator rtd-name rtd-parent rtd-predicate rtd?) (import (srfi :99 records)) ) �������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a99/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0017454�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a99/records.sls��������������������������������������������0000664�0000000�0000000�00000003057�13751542066�0021645�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright (C) William D Clinger 2008. All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to deal ;; in the Software without restriction, including without limitation the rights ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;; copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. REMEMBER, THERE IS NO ;; SCHEME UNDERGROUND. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF ;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (library (srfi :99 records) (export record? record-rtd rtd-name rtd-parent rtd-field-names rtd-all-field-names rtd-field-mutable? make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator define-record-type) (import (srfi :99 records inspection) (srfi :99 records procedural) (srfi :99 records syntactic))) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a99/records/�����������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0021115�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a99/records/helper.sls�������������������������������������0000664�0000000�0000000�00000002627�13751542066�0023126�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright (C) William D Clinger 2008. All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to deal ;; in the Software without restriction, including without limitation the rights ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;; copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. REMEMBER, THERE IS NO ;; SCHEME UNDERGROUND. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF ;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ; This library breaks a circular interdependence between the ; procedural and inspection layers. (library (srfi :99 records helper) (export rtd?) (import (rnrs base) (rnrs records procedural)) (define rtd? record-type-descriptor?) ) ���������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a99/records/inspection.larceny.sls�������������������������0000664�0000000�0000000�00000000276�13751542066�0025454�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi :99 records inspection) (export record? record-rtd rtd-name rtd-parent rtd-field-names rtd-all-field-names rtd-field-mutable?) (import (err5rs records inspection))) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a99/records/inspection.sls���������������������������������0000664�0000000�0000000�00000005054�13751542066�0024017�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright (C) William D Clinger 2008. All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to deal ;; in the Software without restriction, including without limitation the rights ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;; copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. REMEMBER, THERE IS NO ;; SCHEME UNDERGROUND. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF ;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (library (srfi :99 records inspection) (export record? record-rtd rtd-name rtd-parent rtd-field-names rtd-all-field-names rtd-field-mutable?) (import (rnrs base) (rnrs lists) (rnrs records inspection) (srfi :99 records helper)) ; The record? predicate is already defined by (rnrs records inspection). ; The record-rtd procedure is already defined by (rnrs records inspection). (define rtd-name record-type-name) (define rtd-parent record-type-parent) (define rtd-field-names record-type-field-names) (define (rtd-all-field-names rtd) (define (loop rtd othernames) (let ((parent (rtd-parent rtd)) (names (append (vector->list (rtd-field-names rtd)) othernames))) (if parent (loop parent names) (list->vector names)))) (loop rtd '())) (define (rtd-field-mutable? rtd0 fieldname) (define (loop rtd) (if (rtd? rtd) (let* ((names (vector->list (rtd-field-names rtd))) (probe (memq fieldname names))) (if probe (record-field-mutable? rtd (- (length names) (length probe))) (loop (rtd-parent rtd)))) (assertion-violation 'rtd-field-mutable? "illegal argument" rtd0 fieldname))) (loop rtd0)) ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a99/records/procedural.larceny.sls�������������������������0000664�0000000�0000000�00000000242�13751542066�0025432�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi :99 records procedural) (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator) (import (err5rs records procedural))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a99/records/procedural.sls���������������������������������0000664�0000000�0000000�00000011525�13751542066�0024004�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright (C) William D Clinger 2008. All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to deal ;; in the Software without restriction, including without limitation the rights ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;; copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. REMEMBER, THERE IS NO ;; SCHEME UNDERGROUND. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF ;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (library (srfi :99 records procedural) (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator) (import (rnrs base) (rnrs lists) (rnrs records procedural) (srfi :99 records inspection)) ; Note: the options are permitted by ERR5RS, ; but are not part of ERR5RS. (define (make-rtd name fieldspecs . rest) (let* ((parent (if (null? rest) #f (car rest))) (options (if (null? rest) '() (cdr rest))) (sealed? (and (memq 'sealed options) #t)) (opaque? (and (memq 'opaque options) #t)) (uid (let ((probe (memq 'uid options))) (if (and probe (not (null? (cdr probe)))) (cadr probe) #f)))) (make-record-type-descriptor name parent uid sealed? opaque? (vector-map (lambda (fieldspec) (if (symbol? fieldspec) (list 'mutable fieldspec) fieldspec)) ;; NB: hack to get srfi :131 working (if (list? fieldspecs) (list->vector fieldspecs) fieldspecs))))) (define rtd? record-type-descriptor?) (define (rtd-constructor rtd . rest) ; Computes permutation and allocates permutation buffer ; when the constructor is created, not when the constructor ; is called. More error checking is recommended. (define (make-constructor fieldspecs allnames maker) (let* ((k (length fieldspecs)) (n (length allnames)) (buffer (make-vector n)) (reverse-all-names (reverse allnames))) (define (position fieldname) (let ((names (memq fieldname reverse-all-names))) (assert names) (- (length names) 1))) (let ((indexes (map position fieldspecs))) ; The following can be made quite efficient by ; hand-coding it in some lower-level language, ; e.g. Larceny's mal. Even case-lambda would ; be good enough in most systems. (lambda args (assert (= (length args) k)) (for-each (lambda (arg posn) (vector-set! buffer posn arg)) args indexes) (apply maker (vector->list buffer)))))) (if (null? rest) (record-constructor (make-record-constructor-descriptor rtd #f #f)) (begin (assert (null? (cdr rest))) (make-constructor (vector->list (car rest)) (vector->list (rtd-all-field-names rtd)) (record-constructor (make-record-constructor-descriptor rtd #f #f)))))) (define rtd-predicate record-predicate) (define (rtd-accessor rtd0 fieldname) (define (loop rtd) (if (rtd? rtd) (let* ((names (vector->list (rtd-field-names rtd))) (probe (memq fieldname names))) (if probe (record-accessor rtd (- (length names) (length probe))) (loop (rtd-parent rtd)))) (assertion-violation 'rtd-accessor "illegal argument" rtd0 fieldname))) (loop rtd0)) (define (rtd-mutator rtd0 fieldname) (define (loop rtd) (if (rtd? rtd) (let* ((names (vector->list (rtd-field-names rtd))) (probe (memq fieldname names))) (if probe (record-mutator rtd (- (length names) (length probe))) (loop (rtd-parent rtd)))) (assertion-violation 'rtd-mutator "illegal argument" rtd0 fieldname))) (loop rtd0)) ) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a99/records/syntactic.larceny.sls��������������������������0000664�0000000�0000000�00000000153�13751542066�0025274�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi :99 records syntactic) (export define-record-type) (import (err5rs records syntactic))) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/%3a99/records/syntactic.sls����������������������������������0000664�0000000�0000000�00000023536�13751542066�0023652�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright (C) William D Clinger 2008. All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person obtaining a copy ;; of this software and associated documentation files (the "Software"), to deal ;; in the Software without restriction, including without limitation the rights ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell ;; copies of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be included in ;; all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. REMEMBER, THERE IS NO ;; SCHEME UNDERGROUND. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF ;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (library (srfi :99 records syntactic) (export define-record-type) (import (for (rnrs base) run expand) (for (rnrs lists) run expand) (for (rnrs syntax-case) run expand) (srfi :99 records procedural)) (define-syntax define-record-type (syntax-rules () ((_ (type-name parent) constructor-spec predicate-spec . field-specs) (define-record-type-helper0 type-name parent constructor-spec predicate-spec . field-specs)) ((_ type-name constructor-spec predicate-spec . field-specs) (define-record-type-helper0 type-name #f constructor-spec predicate-spec . field-specs)))) (define-syntax define-record-type-helper0 (lambda (x) ; Given syntax objects, passes them to helper macro. (define (construct-record-type-definitions tname fields parent cspec pred afields mfields) (let () (define (frob x) (cond ((identifier? x) x) ((pair? x) (cons (frob (car x)) (frob (cdr x)))) ((vector? x) (vector-map frob x)) ((symbol? x) (datum->syntax tname x)) (else x))) #`(#,(frob #'define-record-type-helper) #,(frob tname) #,(frob fields) #,(frob parent) #,(frob cspec) #,(frob pred) #,(frob afields) #,(frob mfields)))) ; Given a syntax object that represents a non-empty list, ; returns the syntax object for its first element. (define (syntax-car x) (syntax-case x () ((x0 x1 ...) #'x0))) ; Given a syntax object that represents a non-empty list, ; returns the syntax object obtained by omitting the first ; element of that list. (define (syntax-cdr x) (syntax-case x () ((x0 x1 ...) #'(x1 ...)))) ; Given a syntax object that represents a non-empty list, ; returns the corresponding list of syntax objects. (define (syntax->list x) (syntax-case x () (() '()) ((x0 . x1) (cons #'x0 (syntax->list #'x1))))) (define (complain) (syntax-violation 'define-record-type "illegal syntax" x)) ; tname and pname are always identifiers here. (syntax-case x () ((_ tname pname constructor-spec predicate-spec . field-specs) (let* ((type-name (syntax->datum #'tname)) (cspec (syntax->datum #'constructor-spec)) (pspec (syntax->datum #'predicate-spec)) (fspecs (syntax->datum #'field-specs)) (type-name-string (begin (if (not (symbol? type-name)) (complain)) (symbol->string type-name))) (constructor-name (cond ((eq? cspec #f) #'constructor-spec) ((eq? cspec #t) (datum->syntax #'tname (string->symbol (string-append "make-" type-name-string)))) ((symbol? cspec) #'constructor-spec) ((and (pair? cspec) (symbol? (car cspec))) (syntax-car #'constructor-spec)) (else (complain)))) (constructor-args (cond ((pair? cspec) (if (not (for-all symbol? cspec)) (complain) (list->vector (syntax->list (syntax-cdr #'constructor-spec))))) (else #f))) (new-constructor-spec (if constructor-args (list constructor-name constructor-args) constructor-name)) (predicate-name (cond ((eq? pspec #f) #'predicate-spec) ((eq? pspec #t) (datum->syntax #'tname (string->symbol (string-append type-name-string "?")))) ((symbol? pspec) #'predicate-spec) (else (complain)))) (field-specs (map (lambda (fspec field-spec) (cond ((symbol? fspec) (list 'immutable fspec (string->symbol (string-append type-name-string "-" (symbol->string fspec))))) ((not (pair? fspec)) (complain)) ((not (list? fspec)) (complain)) ((not (for-all symbol? fspec)) (complain)) ((null? (cdr fspec)) (list 'mutable (car fspec) (string->symbol (string-append type-name-string "-" (symbol->string (car fspec)))) (string->symbol (string-append type-name-string "-" (symbol->string (car fspec)) "-set!")))) ((null? (cddr fspec)) (list 'immutable (car fspec) (syntax-car (syntax-cdr field-spec)))) ((null? (cdddr fspec)) (list 'mutable (car fspec) (syntax-car (syntax-cdr field-spec)) (syntax-car (syntax-cdr (syntax-cdr field-spec))))) (else (complain)))) fspecs (syntax->list #'field-specs))) (fields (list->vector (map cadr field-specs))) (accessor-fields (map (lambda (x) (list (caddr x) (cadr x))) (filter (lambda (x) (>= (length x) 3)) field-specs))) (mutator-fields (map (lambda (x) (list (cadddr x) (cadr x))) (filter (lambda (x) (= (length x) 4)) field-specs)))) (construct-record-type-definitions #'tname fields #'pname new-constructor-spec predicate-name accessor-fields mutator-fields)))))) (define-syntax define-record-type-helper (syntax-rules () ((_ type-name fields parent #f predicate ((accessor field) ...) ((mutator mutable-field) ...)) (define-record-type-helper type-name fields parent ignored predicate ((accessor field) ...) ((mutator mutable-field) ...))) ((_ type-name fields parent constructor #f ((accessor field) ...) ((mutator mutable-field) ...)) (define-record-type-helper type-name fields parent constructor ignored ((accessor field) ...) ((mutator mutable-field) ...))) ((_ type-name fields parent (constructor args) predicate ((accessor field) ...) ((mutator mutable-field) ...)) (begin (define type-name (make-rtd 'type-name 'fields parent)) (define constructor (rtd-constructor type-name 'args)) (define predicate (rtd-predicate type-name)) (define accessor (rtd-accessor type-name 'field)) ... (define mutator (rtd-mutator type-name 'mutable-field)) ...)) ((_ type-name fields parent constructor predicate ((accessor field) ...) ((mutator mutable-field) ...)) (begin (define type-name (make-rtd 'type-name 'fields parent)) (define constructor (rtd-constructor type-name)) (define predicate (rtd-predicate type-name)) (define accessor (rtd-accessor type-name 'field)) ... (define mutator (rtd-mutator type-name 'mutable-field)) ...)))) ) ; srfi :99 records syntactic ������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/.github/�����������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0020262�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/.github/workflows/�������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0022317�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/.github/workflows/ci.yml�������������������������������������0000664�0000000�0000000�00000000665�13751542066�0023444�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������name: Continuous Integration on: [pull_request, push] jobs: build: runs-on: ubuntu-latest steps: - uses: actions/checkout@v2 - name: install chez scheme run: sudo apt install chezscheme - name: run tests run: | cd ../ ln -s $(pwd)/chez-srfi $(pwd)/srfi cd srfi scheme-script link-dirs.chezscheme.sps cd tests sh test_all.sh ../../ ���������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/.gitignore���������������������������������������������������0000664�0000000�0000000�00000000072�13751542066�0020711�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������.bzr :* *!* *\** srfi .bzrignore .sw? .*.sw? and-let*.sls ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/LICENSE������������������������������������������������������0000664�0000000�0000000�00000003217�13751542066�0017732�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������The following license applies to all files written by Derick Eddington, unless otherwise stated. =========================================================================== Copyright (c) 2008-2010 Derick Eddington. All rights reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. Except as contained in this notice, the name(s) of the above copyright holders shall not be used in advertising or otherwise to promote the sale, use or other dealings in this Software without prior written authorization. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. =========================================================================== Files written by others retain any copyright, license, and/or other notice they originally had. ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/README.md����������������������������������������������������0000664�0000000�0000000�00000002073�13751542066�0020203�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Chez SRFIs This is a quiet holding place for the SRFI port that I did based on the Scheme Libraries project: https://launchpad.net/scheme-libraries These were originally intended to simply provide a place for me to tweak and maintain my own copy of the SRFIs for use in Chez Scheme. With the release of Chez Scheme as an Open Source project and additional implementations beginning to become more widespread, this repository has found some use for other people as well. As such, it now serves as a sort of clearing house for some patches that people have applied to my original efforts. I no longer spend a great deal of time working on these libraries, but I welcome additional patches and changes as people would like to submit them, provided that they respect the following: 1. They should work. 2. They should not result in breakage for Chez Scheme, which is the primary intended target of this repository. 3. They should strive for simplicity and avoid too many dirty hacks. More information on the SRFIs can be found upstream or in the upstream README. ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/README.upstream����������������������������������������������0000664�0000000�0000000�00000005712�13751542066�0021446�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������Scheme Requests for Implementation (SRFIs), as R6RS libraries ------------------------------------------------------------- The libraries' names conform to SRFI 97: SRFI Libraries. There is a registry of available SRFIs and other platform features which works alongside SRFI 0: Feature-Based Conditional Expansion. The porting done so far is mostly just taking the reference implementations from http://srfi.schemers.org and wrapping them in libraries and tweaking the few things needed to make them work in R6RS libraries and with implementations' functionality. Supporting any R6RS implementation supporting the *.IMPL.sls convention is easy. These SRFIs are available: (srfi :0 cond-expand) (srfi :1 lists) (srfi :2 and-let*) (srfi :4 numeric-vectors) (srfi :5 let) (srfi :6 basic-string-ports) (srfi :8 receive) (srfi :9 records) (srfi :11 let-values) (srfi :13 strings) (srfi :14 char-sets) (srfi :16 case-lambda) (srfi :17 generalized-set!) (srfi :19 time) (srfi :23 error) (srfi :25 multi-dimensional-arrays) (srfi :26 cut) (srfi :27 random-bits) (srfi :28 basic-format-strings) (srfi :29 localization) (srfi :31 rec) (srfi :34 exception-handling) (srfi :35 conditions) (srfi :37 args-fold) (srfi :38 with-shared-structure) (srfi :39 parameters) (srfi :41 streams) (srfi :42 eager-comprehensions) (srfi :43 vectors) (srfi :45 lazy) (srfi :48 intermediate-format-strings) (srfi :51 rest-values) (srfi :54 cat) (srfi :60 integer-bits) (srfi :61 cond) (srfi :64 testing) (srfi :67 compare-procedures) (srfi :69 basic-hash-tables) (srfi :78 lightweight-testing) (srfi :98 os-environment-variables) (srfi :99 records) (srfi :115 regex) (srfi :117 list-queues) (srfi :125 hashtables) (srfi :126 r6rs-hashtables) (srfi :127 lazy-sequences) (srfi :128 comparators) (srfi :129 titlecase) (srfi :130 string-cursors) (srfi :131 records) (srfi :132 sorting) (srfi :133 vectors) (srfi :141 integer-division) (srfi :143 fixnums) (srfi :145 assumptions) (srfi :151 bitwise-operations) (srfi :152 strings) (srfi :156 predicate-combiners) (srfi :158 generators-and-accumulators) Other SRFIs are not available because there hasn't been a demand for them or they're not possible as an R6RS library. If you already have ported SRFIs to R6RS, we'd love to assimilate them. You can let us know by "asking a question" at the Scheme Libraries project page: https://launchpad.net/scheme-libraries Currently supported systems are Chez Scheme, Ikarus, Larceny, and Ypsilon. PLT Scheme is only semi-supported because it has its own "srfi" directory which conflicts with having another "srfi" directory; you can symlink/copy files from this collection into PLT's "srfi" directory. For the latest development version, go to: https://code.launchpad.net/~scheme-libraries-team/scheme-libraries/srfi Bug Reporting: -------------- Submit bug reports at: https://bugs.launchpad.net/scheme-libraries/+filebug ������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/compile-all.ikarus.sps���������������������������������������0000664�0000000�0000000�00000005126�13751542066�0023150�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by ../xitomatl/utils/make-compile-all.sps ;; Do: ikarus --compile-dependencies compile-all.ikarus.sps (import (only (srfi :0)) (only (srfi :0 cond-expand)) (only (srfi :1)) (only (srfi :1 lists)) (only (srfi :11)) (only (srfi :11 let-values)) (only (srfi :13)) (only (srfi :13 strings)) (only (srfi :14)) (only (srfi :14 char-sets)) (only (srfi :16)) (only (srfi :16 case-lambda)) (only (srfi :19)) (only (srfi :19 time)) (only (srfi :19 time compat)) (only (srfi :19 time not-implemented)) (only (srfi :2)) (only (srfi :2 and-let*)) (only (srfi :23)) (only (srfi :23 error)) (only (srfi :23 error tricks)) (only (srfi :25)) (only (srfi :25 multi-dimensional-arrays)) (only (srfi :25 multi-dimensional-arrays all)) (only (srfi :25 multi-dimensional-arrays arlib)) (only (srfi :26)) (only (srfi :26 cut)) (only (srfi :27)) (only (srfi :27 random-bits)) (only (srfi :31)) (only (srfi :31 rec)) (only (srfi :37)) (only (srfi :37 args-fold)) (only (srfi :38)) (only (srfi :38 with-shared-structure)) (only (srfi :39)) (only (srfi :39 parameters)) (only (srfi :41)) (only (srfi :41 streams)) (only (srfi :41 streams derived)) (only (srfi :41 streams primitive)) (only (srfi :42)) (only (srfi :42 eager-comprehensions)) (only (srfi :43)) (only (srfi :43 vectors)) (only (srfi :45)) (only (srfi :45 lazy)) (only (srfi :48)) (only (srfi :48 intermediate-format-strings)) (only (srfi :48 intermediate-format-strings compat)) (only (srfi :6)) (only (srfi :6 basic-string-ports)) (only (srfi :6 basic-string-ports compat)) (only (srfi :61)) (only (srfi :61 cond)) (only (srfi :64)) (only (srfi :64 testing)) (only (srfi :67)) (only (srfi :67 compare-procedures)) (only (srfi :69)) (only (srfi :69 basic-hash-tables)) (only (srfi :78)) (only (srfi :78 lightweight-testing)) (only (srfi :78 lightweight-testing compat)) (only (srfi :8)) (only (srfi :8 receive)) (only (srfi :9)) (only (srfi :9 records)) (only (srfi :98)) (only (srfi :98 os-environment-variables)) (only (srfi :99)) (only (srfi :99 records)) (only (srfi :99 records helper)) (only (srfi :99 records inspection)) (only (srfi :99 records procedural)) (only (srfi :99 records syntactic)) (only (srfi private OS-id-features)) (only (srfi private check-arg)) (only (srfi private feature-cond)) (only (srfi private include)) (only (srfi private include compat)) (only (srfi private let-opt)) (only (srfi private platform-features)) (only (srfi private registry)) (only (srfi private vanish)) ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/install.chezscheme.sps���������������������������������������0000775�0000000�0000000�00000023167�13751542066�0023250�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#! /bin/sh #| exec /usr/bin/env ${SCHEME:-scheme} --script "$0" "$@" |# ;; Installs versions of srfi libs where calls to (include/resolve ...) have been inlined with requested scheme code. ;; These inlined libs are written to a separate install directory and compiled by Chez scheme. ;; ;; Inlining this way makes all referenced SRFI code compilable. ;; ;; Use from the top level dir of these srfi libs: ;; ./install.chezscheme.sps <dest-dir> ;; ;; The SRFI library will be installed under <dest-dir>. ie, <dest-dir>/srfi/... ;; <dest-dir> will be created if it does not exist. ;; ;; Written by Akce 2020, released into the public domain. ;; SPDX-License-Identifier: Unlicense ;; ;; (translate-name) copied from link-dirs.chezscheme.sps: ;;; Copyright (c) 2012 Aaron W. Hsu <arcfide@sacrideo.us> ;;; ;;; Permission to use, copy, modify, and distribute this software for ;;; any purpose with or without fee is hereby granted, provided that the ;;; above copyright notice and this permission notice appear in all ;;; copies. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE ;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL ;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA ;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR ;;; PERFORMANCE OF THIS SOFTWARE. (import (chezscheme) (private install sipp)) ;; translate-name copied from link-dirs.chezscheme.sps. ;;; Copyright (c) 2012 Aaron W. Hsu <arcfide@sacrideo.us> ;; See header for full copyright. (define (translate-name name) (let f ([i 0] [j 0]) (if (fx= i (string-length name)) (make-string j) (let ([c (string-ref name i)]) (cond [(and (char=? c #\%) (let ([next-i (fx+ i 3)]) (and (fx<= next-i (string-length name)) next-i))) => (lambda (next-i) (let ([translated-name (f next-i (fx+ j 1))]) (string-set! translated-name j (integer->char (string->number (substring name (fx+ i 1) next-i) 16))) translated-name))] [else (let ([translated-name (f (fx+ i 1) (fx+ j 1))]) (string-set! translated-name j c) translated-name)]))))) (define srfi-name? (lambda (f) (char=? #\% (string-ref f 0)))) (define copy-file (lambda (src dest) (let ([inp (open-file-input-port src)] [outp (open-file-output-port dest)]) (put-bytevector outp (get-bytevector-all inp)) (for-each close-port `(,inp ,outp))))) (define copy-directory (lambda (src dest) (let ([src-files (filter file-regular? (map (lambda (f) (join-path src f)) (directory-list src)))]) (unless (file-exists? dest) (mkdir dest)) (mkdir (join-path dest src)) (for-each (lambda (s) (copy-file s (join-path dest s))) src-files)))) (define join-path (lambda parts (apply join-string directory-separator-string parts))) (define get-sub-dirs (lambda (dir) (define join-dir (lambda (subdir) (join-path dir subdir))) (let ([subdirs (filter file-directory? (map join-dir (directory-list dir)))]) (apply append subdirs (filter pair? (map get-sub-dirs subdirs)))))) (define collect-library-dirs (case-lambda [(base-dir) (let ([subdirs (filter (lambda (f) (and (file-directory? f) (srfi-name? f))) (directory-list base-dir))]) (apply append subdirs (filter pair? (map get-sub-dirs subdirs))))])) (define try-create-dir (lambda (dir) (unless (file-directory? dir) (mkdir dir)))) (define create-dirs (lambda (dirs) (for-each try-create-dir dirs))) (define scheme-library-file? (lambda (f) (let ([ext (path-extension f)]) (and (file-regular? f) (not (file-symbolic-link? f)) (string=? ext "sls"))))) (define scheme-program-file? (lambda (f) (let ([ext (path-extension f)]) (and (file-regular? f) (not (file-symbolic-link? f)) (string=? ext "sps"))))) ;; [proc] directory-list/with-path: list directory contents with leading path. (define directory-list/with-path (lambda (dir) (define returner (cond [(string=? "." dir) ;; do not return paths with ./ prefix as this becomes a problem case for the import script that ;; 'compile-all' needs to generate. values] [else (lambda (f) (join-path dir f))])) (map ; list directory contents. returner (directory-list dir)))) (define collect-library-files (lambda (library-dirs) (apply ; flatten lists. append (filter ; remove empty dirs. pair? (map ; only get real *scheme* files. (lambda (d) (filter scheme-library-file? (directory-list/with-path d))) library-dirs))))) (define install-file (lambda (src dest) (with-output-to-file dest (lambda () (for-each pretty-print (replace-source src #t)))))) (define install-srfi (lambda (src-dir dest-dir) (define srfi-dest-dir (join-path dest-dir "srfi")) (define join-dest-dir (lambda (f) (join-path srfi-dest-dir f))) (when (file-exists? srfi-dest-dir) (error #f "SRFI destination directory exists. Please remove before running again." srfi-dest-dir)) (let* ([src-dirs (collect-library-dirs src-dir)] [src-files (collect-library-files (cons src-dir src-dirs))] [prefix-dirs (map join-dest-dir (map translate-name src-dirs))] [prefix-files (map join-dest-dir (map translate-name src-files))]) (create-dirs (apply list dest-dir srfi-dest-dir prefix-dirs)) (for-each install-file src-files prefix-files) (values srfi-dest-dir src-files)))) (define path->srfi-include (lambda (p) (define /->space (lambda (str) (list->string (map (lambda (c) (case c [(#\/) #\space] [else c])) (string->list str))))) (define filename->srfi (lambda (str) (string-append "(srfi " (/->space (translate-name str)) ")"))) (let* ([fn (path-root p)] [ext (path-extension fn)]) ;; Check for second level extension. These can exist for scheme specific implementations. ;; We'll include both generic and Chez versions. (cond [(string=? "" ext) (filename->srfi fn)] [(string=? "chezscheme" ext) (filename->srfi (path-root fn))] [else ;; Do not include specific implementations for other schemes. #f])))) ;; compile-all generates an import scheme script that compiles all imported libraries in place. ;; Doing it this way lets Chez scheme handle dependancies correctly and compile libs only once. (define compile-all (lambda (dest-dir src-files) (let ([fn "./compile-all.chezscheme.sps"]) (with-output-to-file fn (lambda () (format #t "#! /bin/sh #| exec /usr/bin/env ${SCHEME:-scheme} --compile-imported-libraries --script \"$0\" \"$@\" |# ;; DO NOT EDIT!! ;; This file was autogenerated by: $ ~a. (import (chezscheme)) (library-directories \"~a\") (import ~a ) " (apply join-string " " (command-line)) dest-dir (apply join-string "\n" (filter values (map path->srfi-include src-files))))) '(replace mode #o755)) (system fn)))) (define install-private (lambda (src-dir dest-dir) (copy-directory (join-path src-dir "private") dest-dir) ;; create a null (srfi private include) library since those imports haven't been removed. (delete-file (join-path dest-dir "private" "include.sls")) (copy-file (join-path src-dir "private" "install" "include.chezscheme.sls") (join-path dest-dir "private" "include.chezscheme.sls")))) (define install-tests (lambda (src-dir dest-dir) (let ([src-files (filter scheme-program-file? (directory-list/with-path (join-path src-dir "tests")))] [dest-test-dir (join-path dest-dir "tests")]) (try-create-dir dest-test-dir) (for-each install-file src-files (map (lambda (src) ;; Don't translate-name here. That way tests/test_all.sh works for both installed and linked SRFIs. (join-path dest-dir src)) src-files)) (copy-file (join-path src-dir "tests" "test_all.sh") (join-path dest-test-dir "test_all.sh"))))) (define main (lambda (src-dir dest-dir) (let-values ([(srfi-dest-dir lib-files) (install-srfi src-dir dest-dir)]) (install-private src-dir srfi-dest-dir) (install-tests src-dir srfi-dest-dir) (library-directories dest-dir) (compile-all dest-dir lib-files)))) (cond [(null? (cdr (command-line))) (format #t "Usage: $ ~a <destination-dir> Where <destination-dir> is in the Chez scheme library search path, (library-directories). The SRFIs will be installed beneath <destination-dir>. ie, <destination-dir>/srfi The <destination-dir>/srfi directory must not exist. " (car (command-line))) (exit 1)] [else (main "." (list-ref (command-line) 1))]) ;; vi:ft=scheme: ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/link-dirs.chezscheme.sps�������������������������������������0000775�0000000�0000000�00000004434�13751542066�0023472�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#! /usr/bin/env scheme-script ;;; Copyright (c) 2012 Aaron W. Hsu <arcfide@sacrideo.us> ;;; ;;; Permission to use, copy, modify, and distribute this software for ;;; any purpose with or without fee is hereby granted, provided that the ;;; above copyright notice and this permission notice appear in all ;;; copies. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE ;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL ;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA ;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR ;;; PERFORMANCE OF THIS SOFTWARE. (import (chezscheme)) ;;; Link all of the SRFIs to their normal directories like sane ;;; people who use Chez Scheme prefer. :-) (define (translate-name name) (let f ([i 0] [j 0]) (if (fx= i (string-length name)) (make-string j) (let ([c (string-ref name i)]) (cond [(and (char=? c #\%) (let ([next-i (fx+ i 3)]) (and (fx<= next-i (string-length name)) next-i))) => (lambda (next-i) (let ([translated-name (f next-i (fx+ j 1))]) (string-set! translated-name j (integer->char (string->number (substring name (fx+ i 1) next-i) 16))) translated-name))] [else (let ([translated-name (f (fx+ i 1) (fx+ j 1))]) (string-set! translated-name j c) translated-name)]))))) (define (link-files!) (let file-loop ([ls (directory-list (current-directory))]) (unless (null? ls) (let ([name (car ls)]) (let ([translated-name (translate-name name)]) (unless (or (string=? name translated-name) (file-exists? translated-name)) (system (format "ln -sf '~a' '~a'" name translated-name))) (when (file-directory? translated-name) (parameterize ([current-directory translated-name]) (link-files!))) (file-loop (cdr ls))))))) (link-files!) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/�����������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0020374�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/OS-id-features.sls�����������������������������������0000664�0000000�0000000�00000001326�13751542066�0023650�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private OS-id-features) (export OS-id-features) (import (rnrs)) (define (OS-id-features OS-id features-alist) (define OS-id-len (string-length OS-id)) (define (OS-id-contains? str) (define str-len (string-length str)) (let loop ((i 0)) (and (<= (+ i str-len) OS-id-len) (or (string-ci=? str (substring OS-id i (+ i str-len))) (loop (+ 1 i)))))) (apply append (map cdr (filter (lambda (x) (OS-id-contains? (car x))) features-alist)))) ) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/check-arg.sls����������������������������������������0000664�0000000�0000000�00000001120�13751542066�0022735�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. ;; If your Scheme system doesn't have a stack-tracing debugger, you can change ;; this to use the version which actually does check. (library (srfi private check-arg) (export check-arg) (import (rnrs)) #;(define (check-arg pred val who) (if (pred val) val (assertion-violation #F "check-arg failed" who pred val))) (define-syntax check-arg (syntax-rules () ((_ pred val who) val))) ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/define-values.chezscheme.sls�������������������������0000664�0000000�0000000�00000000130�13751542066�0025755�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi private define-values) (export define-values) (import (chezscheme))) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/define-values.sls������������������������������������0000664�0000000�0000000�00000002013�13751542066�0023642�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi private define-values) (export define-values) (import (rnrs) (srfi private helpers)) (define-syntax define-values (lambda (x) (syntax-case x () [(_ (fmls ...) expr) (with-syntax ([(i ...) (enumerate #'(fmls ...))] [(t ...) (generate-temporaries #'(fmls ...))]) #'(begin (define tmp (let-values ([(t ...) expr]) (vector t ...))) (define fmls (vector-ref tmp i)) ...))] [(_ (fmls ... . rest-fml) expr) (with-syntax ([(t ...) (generate-temporaries #'(fmls ...))] [(rest-t) (generate-temporaries #'(rest-fml))] [(all-fmls ...) #'(rest-fml fmls ...)] [(i ...) (enumerate #'(rest-fml fmls ...))]) #'(begin (define tmp (let-values ([(t ... . rest-t) expr]) (vector rest-t t ...))) (define all-fmls (vector-ref tmp i)) ...))])))) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/feature-cond.sls�������������������������������������0000664�0000000�0000000�00000003400�13751542066�0023470�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private feature-cond) (export feature-cond) (import (rnrs) (only (srfi private registry) available-features)) (define-syntax feature-cond (lambda (stx) (define (identifier?/name=? x n) (and (identifier? x) (symbol=? n (syntax->datum x)))) (define (make-test f) (define (invalid) (syntax-violation #F "invalid feature syntax" stx f)) (syntax-case f () ((c x ...) (identifier?/name=? (syntax c) (quote and)) (cons (syntax and) (map make-test (syntax (x ...))))) ((c x ...) (identifier?/name=? (syntax c) (quote or)) (cons (syntax or) (map make-test (syntax (x ...))))) ((c x ...) (identifier?/name=? (syntax c) (quote not)) (if (= 1 (length (syntax (x ...)))) (list (syntax not) (make-test (car (syntax (x ...))))) (invalid))) (datum (not (memq (syntax->datum (syntax datum)) (quote (and or not else)))) (syntax (and (member (quote datum) available-features) #T))) (_ (invalid)))) (syntax-case stx () ((_ (feature . exprs) ... (e . eexprs)) (identifier?/name=? (syntax e) (quote else)) (with-syntax (((test ...) (map make-test (syntax (feature ...))))) (syntax (cond (test . exprs) ... (else . eexprs))))) ((kw (feature . exprs) ...) (syntax (kw (feature . exprs) ... (else (no-clause-true)))))))) (define (no-clause-true) (assertion-violation (quote feature-cond) "no clause true")) ) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/helpers.chezscheme.sls�������������������������������0000664�0000000�0000000�00000000116�13751542066�0024674�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi private helpers) (export enumerate) (import (chezscheme))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/helpers.sls������������������������������������������0000664�0000000�0000000�00000000344�13751542066�0022562�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi private helpers) (export enumerate) (import (rnrs)) (define enumerate (lambda (ls) (let f ([ls ls] [i 0]) (if (null? ls) '() (cons i (f (cdr ls) (fx+ i 1)))))))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include.sls������������������������������������������0000664�0000000�0000000�00000003731�13751542066�0022546�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private include) (export include/resolve) (import (except (rnrs) read) (for (srfi private include compat) expand) (for (srfi private include read) expand)) (define-syntax include/resolve (lambda (stx) (define (include/lexical-context ctxt filename) (with-exception-handler (lambda (ex) (raise (condition (make-error) (make-who-condition 'include/resolve) (make-message-condition "error while trying to include") (make-irritants-condition (list filename)) (if (condition? ex) ex (make-irritants-condition (list ex)))))) (lambda () (call-with-input-file filename (lambda (fip) (let loop ((a '())) (let ((x (read fip))) (if (eof-object? x) (cons #'begin (datum->syntax ctxt (reverse a))) (loop (cons x a)))))))))) (syntax-case stx () ((ctxt (lib-path* ...) file-path) (for-all (lambda (s) (and (string? s) (positive? (string-length s)))) (syntax->datum #'(lib-path* ... file-path))) (let ((p (apply string-append (map (lambda (ps) (string-append "/" ps)) (syntax->datum #'(lib-path* ... file-path))))) (sp (search-paths))) (let loop ((search sp)) (if (null? search) (error 'include/resolve "cannot find file in search paths" (substring p 1 (string-length p)) sp) (let ((full (string-append (car search) p))) (if (file-exists? full) (include/lexical-context #'ctxt full) (loop (cdr search))))))))))) ) ���������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/���������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0022017�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/compat.chezscheme.sls������������������������0000664�0000000�0000000�00000002067�13751542066�0026147�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;; Copyright (c) 2012 Aaron W. Hsu <arcfide@sacrideo.us> ;;; ;;; Permission to use, copy, modify, and distribute this software for ;;; any purpose with or without fee is hereby granted, provided that the ;;; above copyright notice and this permission notice appear in all ;;; copies. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL ;;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE ;;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL ;;; DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA ;;; OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER ;;; TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR ;;; PERFORMANCE OF THIS SOFTWARE. (library (srfi private include compat) (export search-paths) (import (rnrs) (only (chezscheme) source-directories library-directories)) (define (search-paths) (fold-left (lambda (ls as) (cons (car as) ls)) (source-directories) (library-directories)))) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/compat.guile.sls�����������������������������0000664�0000000�0000000�00000000222�13751542066�0025125�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi private include compat) (export search-paths) (import (rnrs) (only (guile) %load-path)) (define (search-paths) %load-path)) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/compat.ikarus.sls����������������������������0000664�0000000�0000000�00000000447�13751542066�0025327�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private include compat) (export (rename (library-path search-paths))) (import (only (ikarus) library-path)) ) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/compat.ironscheme.sls������������������������0000664�0000000�0000000�00000000704�13751542066�0026161�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an ;; MIT-style license. My license is in the file named LICENSE from the original ;; collection this file is distributed with. If this file is redistributed with ;; some other collection, my license must also be included. (library (srfi private include compat) (export (rename (library-path search-paths))) (import (only (ironscheme) library-path)) ) ������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/compat.larceny.sls���������������������������0000664�0000000�0000000�00000001104�13751542066�0025455�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private include compat) (export search-paths) (import (rnrs base) (primitives current-require-path getenv absolute-path-string?)) (define (search-paths) (let ((larceny-root (getenv "LARCENY_ROOT"))) (map (lambda (crp) (if (absolute-path-string? crp) crp (string-append larceny-root "/" crp))) (current-require-path)))) ) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/compat.loko.sls������������������������������0000664�0000000�0000000�00000000331�13751542066�0024765�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Copyright © 2019 Göran Weinholt ;; SPDX-License-Identifier: MIT #!r6rs (library (srfi private include compat) (export (rename (library-directories search-paths))) (import (only (loko) library-directories))) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/compat.mzscheme.sls��������������������������0000664�0000000�0000000�00000000730�13751542066�0025637�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private include compat) (export search-paths) (import (rnrs base) (only (scheme base) current-library-collection-paths path->string) (only (scheme mpair) list->mlist)) (define (search-paths) (map path->string (list->mlist (current-library-collection-paths)))) ) ����������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/compat.sagittarius.sls�����������������������0000664�0000000�0000000�00000000445�13751542066�0026366�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private include compat) (export (rename (load-path search-paths))) (import (only (sagittarius) load-path))) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/compat.vicare.sls����������������������������0000664�0000000�0000000�00000000514�13751542066�0025275�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private include compat) (export (rename (library-source-search-path search-paths))) (import (only (vicare libraries) library-source-search-path))) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/compat.ypsilon.sls���������������������������0000664�0000000�0000000�00000000465�13751542066�0025526�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private include compat) (export (rename (scheme-library-paths search-paths))) (import (only (core) scheme-library-paths)) ) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/read.ironscheme.sls��������������������������0000664�0000000�0000000�00000000226�13751542066�0025610�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs (library (srfi private include read) (export (rename (read-annotated read))) (import (only (ironscheme reader) read-annotated)) ) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/include/read.sls�������������������������������������0000664�0000000�0000000�00000000363�13751542066�0023457�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2019 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private include read) (export read) (import (only (rnrs) read)) ) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/install/���������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0022042�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/install/include.chezscheme.sls�����������������������0000664�0000000�0000000�00000000107�13751542066�0026323�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������(library (srfi private include) (export) (import (chezscheme)) ) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/install/sipp.chezscheme.sls��������������������������0000775�0000000�0000000�00000010424�13751542066�0025661�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Scheme includes pre-processor. ;; ;; All include/resolve statements are replaced with scheme data contained in the referenced file. ;; File content is placed within a (begin) block. ;; ;; TODO Remove headers print HACK in replace-source. Maybe via a (values) return? ;; ;; Written by Akce 2020. ;; SPDX-License-Identifier: Unlicense (library (private install sipp) (export directory-separator-string join-string replace-source) (import (rnrs) (only (chezscheme) directory-separator)) ;; [proc] replace-source: opens a scheme file, replacing all instances of (include/resolve) with contents of file. ;; [return] scheme list object with forms embedded. ;; HACK ALERT: this also prints the header lines to (current-output-port) assuming that callers will print the ;; HACK ALERT: returned object to this same port. It's an easy way to get all headers followed by code/data. (define replace-source (case-lambda [(path) (replace-source path #f)] [(path print-sipp-header) (with-input-from-file path (lambda () (when print-sipp-header (display ";; DO NOT EDIT THIS FILE!!")(newline) (display ";; This inlined chez-srfi library code is autogenerated using command:")(newline) (display ";; $ ")(display (apply join-string " " (command-line)))(newline) (display ";; Source origin: https://github.com/arcfide/chez-srfi")(newline) (display ";; Please refer to project site for full credits and original code.")(newline)) ;; Print initial header block. Hopefully that's a language tag and copyright info. ;; ie, print lines till we hit the first scheme statement or empty line. ;; NOTE: multiline comments are *not* handled. (display ";;;;;; File header: ")(display path)(newline) (let loop () (case (peek-char) [(#\# #\;) (display (get-line (current-input-port))) (newline) (loop)])) (let loop ([obj (read)] [acc '()]) (cond [(eof-object? obj) (reverse acc)] [else (loop (read) (cons (replace-object obj) acc))]))))])) ;; [proc] replace-object: recurses through a scheme list object, replacing all (include/resolve) calls with the ;; contents of the referred to file. (define replace-object (lambda (obj) (cond [(pair? obj) (case (car obj) [(include/resolve) `(begin ,@(include/resolve (cdr obj))) ] [else (imap replace-object obj)])] [else obj]))) (define directory-separator-string (list->string `(,(directory-separator)))) ;; (include/resolve ((?dir ?dirn ...) ?filename)) (define include/resolve (lambda (args) (let ([dir-args (car args)] [filename (cadr args)]) ;; construct the path and let replace-source earn its keep. (replace-source (apply join-string directory-separator-string (append (cdr dir-args) (list filename))))))) ;; [proc] imap: simple map that handles improper lists. (define imap (lambda (proc ilist) (let loop ([i ilist]) (cond [(null? i) i] [else #;(pair? i) (cons* (proc (car i)) (cond [(list? (cdr i)) (loop (cdr i))] [else (proc (cdr i))]))])))) ;; [proc] string-join: join all string parts together using separator. ;; ;; Note that the signature to this version of join-string differs to string-join in SRFI-13. ;; The separator is the first arg and therefore always explicit which allows for the string ;; parts as regular arguments, rather than a list of strings. ;; ;; Naive implementation that uses (potentially) multiple calls to string-append. (define join-string (lambda (sep . str-parts) (cond [(null? str-parts) ""] [else (let loop ([acc (car str-parts)] [rest (cdr str-parts)]) (cond [(null? rest) acc] [else (loop (string-append acc sep (car rest)) (cdr rest))]))]))) ) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/let-opt.sls������������������������������������������0000664�0000000�0000000�00000012440�13751542066�0022504�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;;; LET-OPTIONALS macros ;;; Copyright (c) 2001 by Olin Shivers. ;;; Copyright (c) 1993-2003 Richard Kelsey and Jonathan Rees ;;; Copyright (c) 1994-2003 by Olin Shivers and Brian D. Carlstrom. ;;; Copyright (c) 1999-2003 by Martin Gasbichler. ;;; Copyright (c) 2001-2003 by Michael Sperber. ;;; ;;; All rights reserved. ;;; ;;; Redistribution and use in source and binary forms, with or without ;;; modification, are permitted provided that the following conditions ;;; are met: ;;; 1. Redistributions of source code must retain the above copyright ;;; notice, this list of conditions and the following disclaimer. ;;; 2. Redistributions in binary form must reproduce the above copyright ;;; notice, this list of conditions and the following disclaimer in the ;;; documentation and/or other materials provided with the distribution. ;;; 3. The name of the authors may not be used to endorse or promote products ;;; derived from this software without specific prior written permission. ;;; ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR ;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES ;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. ;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, ;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT ;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;; Made into an R6RS library by Derick Eddington. (library (srfi private let-opt) (export let-optionals* :optional) (import (rename (except (rnrs) error) (assertion-violation error))) ;;; (:optional rest-arg default-exp [test-pred]) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This form is for evaluating optional arguments and their defaults ;;; in simple procedures that take a *single* optional argument. It is ;;; a macro so that the default will not be computed unless it is needed. ;;; ;;; REST-ARG is a rest list from a lambda -- e.g., R in ;;; (lambda (a b . r) ...) ;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that. ;;; - If REST-ARG has 1 element, return that element. ;;; - If REST-ARG has >1 element, error. ;;; ;;; If there is an TEST-PRED form, it is a predicate that is used to test ;;; a non-default value. If the predicate returns false, an error is raised. (define-syntax :optional (syntax-rules () ([_ rest default-exp] (let ((maybe-arg rest)) (if (pair? maybe-arg) (if (null? (cdr maybe-arg)) (car maybe-arg) (error ':optional "too many optional arguments" maybe-arg)) default-exp))) ([_ rest default-exp arg-test] (let ((maybe-arg rest)) (if (pair? maybe-arg) (if (null? (cdr maybe-arg)) (let ((val (car maybe-arg))) (if (arg-test val) val (error ':optional "optional argument failed test" val))) (error ':optional "too many optional arguments" maybe-arg)) default-exp))))) ; erutcurts-enifed ;;; Here is a simpler but less-efficient version of LET-OPTIONALS*. ;;; It redundantly performs end-of-list checks for every optional var, ;;; even after the list runs out. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-syntax let-optionals* (syntax-rules () ((let-optionals* arg (opt-clause ...) body ...) (let ((rest arg)) (%let-optionals* rest (opt-clause ...) body ...))))) ;;; The arg-list expression *must* be a variable. ;;; (Or must be side-effect-free, in any event.) (define-syntax %let-optionals* (syntax-rules () ((%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...) (call-with-values (lambda () (xparser arg)) (lambda (rest var ...) (%let-optionals* rest (opt-clause ...) body ...)))) ((%let-optionals* arg ((var default) opt-clause ...) body ...) (call-with-values (lambda () (if (null? arg) (values default '()) (values (car arg) (cdr arg)))) (lambda (var rest) (%let-optionals* rest (opt-clause ...) body ...)))) ((%let-optionals* arg ((var default test) opt-clause ...) body ...) (call-with-values (lambda () (if (null? arg) (values default '()) (let ((var (car arg))) (if test (values var (cdr arg)) (error 'let-optionals* "arg failed LET-OPT test" var))))) (lambda (var rest) (%let-optionals* rest (opt-clause ...) body ...)))) ((%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...) (call-with-values (lambda () (if (null? arg) (values default #f '()) (let ((var (car arg))) (if test (values var #t (cdr arg)) (error 'let-optionals* "arg failed LET-OPT test" var))))) (lambda (var supplied? rest) (%let-optionals* rest (opt-clause ...) body ...)))) ((%let-optionals* arg (rest) body ...) (let ((rest arg)) body ...)) ((%let-optionals* arg () body ...) (if (null? arg) (begin body ...) (error 'let-optionals* "too many arguments in let-opt" arg))))) ; erutcurts-enifed ) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/make-aliased-libraries.sps���������������������������0000664�0000000�0000000�00000003426�13751542066�0025417�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (rnrs) (only (srfi private registry) available-features) (only (xitomatl lists) map/filter) (only (xitomatl match) match-lambda) (only (xitomatl common) format fprintf printf) (only (xitomatl strings) string-intersperse) (only (xitomatl predicates) symbol<?) (only (xitomatl environments) environment environment-symbols)) (define srfi-libraries/mnemonics (map/filter (match-lambda ;; NOTE: Uses only the 3-element names. ((:and ('srfi (:symbol ":(\\d+)" num) _) name) (list (string->number (symbol->string num)) name)) (_ #F)) available-features)) (define alias-template "#!r6rs ;; Automatically generated by ~a (library ~s (export ~a) (import ~s) ) ") (define program-name (car (command-line))) (for-each (lambda (x) (let* ((srfi-num (car x)) (lib-name (cadr x)) (exports (list-sort symbol<? (environment-symbols (environment lib-name)))) (alias-name `(srfi ,(string->symbol (format ":~d" srfi-num)))) (out-file (format "%3a~d.sls" srfi-num))) (cond ((file-exists? out-file) (printf "Skipping ~a because it already exists.\n" out-file)) (else (call-with-output-file out-file (lambda (fop) (fprintf fop alias-template program-name alias-name (string-intersperse (map symbol->string exports) "\n ") lib-name))) (printf "~a\n" out-file))))) srfi-libraries/mnemonics) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/platform-features.chezscheme.sls���������������������0000664�0000000�0000000�00000002476�13751542066�0026705�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;; Copyright (c) 2012 Aaron W. Hsu <arcfide@sacrideo.us> ;;; ;;; Permission to use, copy, modify, and distribute this software for any ;;; purpose with or without fee is hereby granted, provided that the above ;;; copyright notice and this permission notice appear in all copies. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES ;;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF ;;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ;;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES ;;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ;;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF ;;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. (library (srfi private platform-features) (export expand-time-features run-time-features) (import (chezscheme) (srfi private OS-id-features)) (define (expand-time-features) '(chezscheme syntax-case)) (define (run-time-features) (OS-id-features (symbol->string (machine-type)) '(("t" threads) ("a6" x86-64) ("i3" x86) ("le" linux posix) ("ob" openbsd posix bsd) ("fb" freebsd posix bsd) ("nb" netbsd posix bsd) ("osx" darwin posix) ("s2" solaris posix) ("nt" windows)))) ) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/platform-features.ikarus.sls�������������������������0000664�0000000�0000000�00000001303�13751542066�0026051�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private platform-features) (export expand-time-features run-time-features) (import (rnrs) (only (ikarus) host-info) (srfi private OS-id-features)) (define (expand-time-features) '(ikarus)) (define (run-time-features) (OS-id-features (host-info) '(("linux" linux posix) ("solaris" solaris posix) ("darwin" darwin posix) ("bsd" bsd) ("freebsd" freebsd posix) ("openbsd" openbsd posix) ("cygwin" cygwin posix) ;; correct? ("gnu" gnu)))) ) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/platform-features.ironscheme.sls���������������������0000664�0000000�0000000�00000001170�13751542066�0026711�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an ;; MIT-style license. My license is in the file named LICENSE from the original ;; collection this file is distributed with. If this file is redistributed with ;; some other collection, my license must also be included. (library (srfi private platform-features) (export expand-time-features run-time-features) (import (rnrs) (srfi private OS-id-features)) (define (run-time-features) (OS-id-features "windows" ;; fixme! '(("windows" windows)))) (define (expand-time-features) '(ironscheme)) ) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/platform-features.larceny.sls������������������������0000664�0000000�0000000�00000001325�13751542066�0026214�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private platform-features) (export expand-time-features run-time-features) (import (rnrs base) (rnrs lists) (primitives system-features) (srfi private OS-id-features)) (define (expand-time-features) '(larceny)) (define (run-time-features) (OS-id-features (cdr (assq 'os-name (system-features))) '(("linux" linux posix) ("solaris" solaris posix) ("darwin" darwin posix) ("bsd" bsd) ("freebsd" freebsd posix) ("openbsd" openbsd posix) ("windows" windows)))) ) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/platform-features.loko.sls���������������������������0000664�0000000�0000000�00000001066�13751542066�0025525�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Copyright © 2019 Göran Weinholt ;; SPDX-License-Identifier: MIT #!r6rs (library (srfi private platform-features) (export expand-time-features run-time-features) (import (rnrs base) (rnrs lists) (loko)) (define (expand-time-features) '(loko syntax-case)) (define (run-time-features) (let ((mt (machine-type))) (append (case (vector-ref mt 0) ((amd64) '(x86-64)) (else '())) (case (vector-ref mt 1) ((linux) '(linux posix)) (else '())))))) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/platform-features.mzscheme.sls�����������������������0000664�0000000�0000000�00000001432�13751542066�0026371�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private platform-features) (export expand-time-features run-time-features) (import (rnrs) (only (scheme base) system-type) (srfi private OS-id-features)) (define (expand-time-features) '(mzscheme)) (define (run-time-features) (OS-id-features (string-append (symbol->string (system-type 'os)) " " (system-type 'machine)) '(("linux" linux posix) ("macosx" mac-os-x darwin posix) ("solaris" solaris posix) ("gnu" gnu) ("bsd" bsd) ("freebsd" freebsd posix) ("openbsd" openbsd posix) ("windows" windows)))) ) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/platform-features.ypsilon.sls������������������������0000664�0000000�0000000�00000001306�13751542066�0026253�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private platform-features) (export expand-time-features run-time-features) (import (rnrs) (only (core) architecture-feature) (srfi private OS-id-features)) (define (expand-time-features) '(ypsilon)) (define (run-time-features) (OS-id-features (architecture-feature 'operating-system) '(("linux" linux posix) ("solaris" solaris posix) ("darwin" darwin posix) ("bsd" bsd) ("freebsd" freebsd posix) ("openbsd" openbsd posix) ("windows" windows)))) ) ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/registry-names-update.sps����������������������������0000664�0000000�0000000�00000003120�13751542066�0025350�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Copyright 2019 Lassi Kortela ;; SPDX-License-Identifier: MIT (import (chezscheme)) (define output-file "registry-names.sls") (define download-command (string-append "curl --fail --silent --show-error " "https://raw.githubusercontent.com/" "scheme-requests-for-implementation/srfi-common" "/master/" "admin/srfi-data.scm")) (define transcoder (make-transcoder (utf-8-codec) (eol-style lf))) (define (read-all port) (let loop ((xs '())) (let ((x (read port))) (if (eof-object? x) (reverse xs) (loop (cons x xs)))))) (define provided (call-with-port (open-input-file "registry-provided.scm") read-all)) (define srfi-data (let-values (((to-process from-process process-stderr process-id) (open-process-ports download-command 'block transcoder))) (read-all from-process))) (define mapping (map (lambda (srfi) (list (cadr (assoc 'number srfi)) (cadr (assoc 'library-name srfi)))) (filter (lambda (srfi) (and (assoc 'library-name srfi) (member (cadr (assoc 'number srfi)) provided))) srfi-data))) (call-with-port (open-file-output-port output-file (file-options no-fail) 'block transcoder) (lambda (port) (parameterize ((current-output-port port) (pretty-line-length 20)) (display "#!r6rs\n") (display (format ";; Automatically generated by ~a\n" (car (command-line)))) (pretty-print `(library (srfi private registry-names) (export SRFIs) (import (rnrs)) (define SRFIs ',mapping)))))) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/registry-names.sls�����������������������������������0000664�0000000�0000000�00000003043�13751542066�0024070�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated by registry-names-update.sps (library (srfi private registry-names) (export SRFIs) (import (rnrs)) (define SRFIs '((0 cond-expand) (1 lists) (2 and-let*) (4 numeric-vectors) (5 let) (6 basic-string-ports) (8 receive) (9 records) (11 let-values) (13 strings) (14 char-sets) (16 case-lambda) (17 generalized-set!) (19 time) (23 error) (25 multi-dimensional-arrays) (26 cut) (27 random-bits) (28 basic-format-strings) (29 localization) (31 rec) (34 exception-handling) (35 conditions) (37 args-fold) (38 with-shared-structure) (39 parameters) (41 streams) (42 eager-comprehensions) (43 vectors) (45 lazy) (48 intermediate-format-strings) (51 rest-values) (54 cat) (60 integer-bits) (61 cond) (64 testing) (67 compare-procedures) (69 basic-hash-tables) (78 lightweight-testing) (98 os-environment-variables) (99 records) (115 regex) (117 list-queues) (125 hashtables) (126 r6rs-hashtables) (127 lazy-sequences) (128 comparators) (129 titlecase) (130 string-cursors) (131 records) (132 sorting) (133 vectors) (141 integer-division) (143 fixnums) (145 assumptions) (151 bitwise-operations) (152 strings) (156 predicate-combiners) (158 generators-and-accumulators) (175 ascii)))) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/registry-provided.scm��������������������������������0000664�0000000�0000000�00000000363�13751542066�0024564�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; List of all SRFI numbers provided by chez-srfi. 0 1 2 4 5 6 8 9 11 13 14 16 17 19 23 25 26 27 28 29 31 34 35 37 38 39 41 42 43 45 48 51 54 60 61 64 67 69 78 98 99 115 117 125 126 127 128 129 130 131 132 133 141 143 145 151 152 156 158 175 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/registry.sls�����������������������������������������0000664�0000000�0000000�00000003401�13751542066�0022765�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private registry) (export expand-time-features run-time-features available-features) (import (rnrs) (srfi private registry-names) (for (prefix (srfi private platform-features) platform-) run expand)) (define-syntax make-expand-time-features (lambda (_) (define (SRFI-names x) (define number car) (define mnemonic cdr) (define (make-symbol . args) (string->symbol (apply string-append (map (lambda (a) (if (symbol? a) (symbol->string a) a)) args)))) (let* ((n-str (number->string (number x))) (colon-n (make-symbol ":" n-str)) (srfi-n (make-symbol "srfi-" n-str)) (srfi-n-m (apply make-symbol srfi-n (map (lambda (m) (make-symbol "-" m)) (mnemonic x))))) ;; The first two are recommended by SRFI-97. ;; The last two are the two types of SRFI-97 library name. (list srfi-n srfi-n-m `(srfi ,colon-n) `(srfi ,colon-n . ,(mnemonic x))))) (let ((s (apply append (map SRFI-names SRFIs))) (h (platform-expand-time-features)) (o '(r6rs))) #`(quote #,(datum->syntax #'ignored (append s h o)))))) (define expand-time-features (make-expand-time-features)) (define run-time-features (platform-run-time-features)) (define available-features (append run-time-features expand-time-features)) ) ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/private/vanish.sls�������������������������������������������0000664�0000000�0000000�00000001722�13751542066�0022411�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (library (srfi private vanish) (export vanish-define) (import (rnrs) (for (only (rnrs base) begin) (meta -1))) (define-syntax vanish-define (lambda (stx) (syntax-case stx () ((_ def (vanish ...)) (for-all identifier? #'(def vanish ...)) #'(make-vanish-define (syntax def) (syntax vanish) ...))))) (define (make-vanish-define def . to-vanish) (lambda (stx) (define (vanish? id) (memp (lambda (x) (free-identifier=? id x)) to-vanish)) (syntax-case stx () ((_ name . _) (and (identifier? #'name) (vanish? #'name)) #'(begin)) ((_ (name . _) . _) (and (identifier? #'name) (vanish? #'name)) #'(begin)) ((_ . r) (cons def #'r))))) ) ����������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/�������������������������������������������������������0000775�0000000�0000000�00000000000�13751542066�0020064�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/and-let%2a.sps�����������������������������������������0000664�0000000�0000000�00000005456�13751542066�0022441�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (rnrs) (rnrs eval) (srfi :2 and-let*) (srfi :78 lightweight-testing)) (define-syntax expect (syntax-rules () ((_ expr result) (check expr => result)))) (define-syntax must-be-a-syntax-error (syntax-rules () ((_ expr) (check (guard (ex (#T (syntax-violation? ex))) (eval 'expr (environment '(rnrs) '(srfi :2 and-let*))) 'unexpected-return) => #T)))) ;; Taken from the reference implementation tests (expect (and-let* () 1) 1) (expect (and-let* () 1 2) 2) (expect (and-let* () ) #T) (expect (let ((x #F)) (and-let* (x))) #F) (expect (let ((x 1)) (and-let* (x))) 1) (expect (and-let* ((x #F)) ) #F) (expect (and-let* ((x 1)) ) 1) (must-be-a-syntax-error (and-let* ( #F (x 1))) ) (expect (and-let* ( (#F) (x 1)) ) #F) (must-be-a-syntax-error (and-let* (2 (x 1))) ) (expect (and-let* ( (2) (x 1)) ) 1) (expect (and-let* ( (x 1) (2)) ) 2) (expect (let ((x #F)) (and-let* (x) x)) #F) (expect (let ((x "")) (and-let* (x) x)) "") (expect (let ((x "")) (and-let* (x) )) "") (expect (let ((x 1)) (and-let* (x) (+ x 1))) 2) (expect (let ((x #F)) (and-let* (x) (+ x 1))) #F) (expect (let ((x 1)) (and-let* (((positive? x))) (+ x 1))) 2) (expect (let ((x 1)) (and-let* (((positive? x))) )) #T) (expect (let ((x 0)) (and-let* (((positive? x))) (+ x 1))) #F) (expect (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))) 3) ;; Derick thinks variable shadowing should be allowed, because it's a "let*". #;(must-be-a-syntax-error (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))) (expect (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))) 2) (expect (let ((x 1)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) 2) (expect (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))) #F) (expect (let ((x #F)) (and-let* (x ((positive? x))) (+ x 1))) #F) (expect (let ((x #F)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) #F) (expect (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #F) (expect (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #F) (expect (let ((x #F)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #F) (expect (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) 3/2) ;; Derick's additional tests (must-be-a-syntax-error (and-let* (("oops" 1)))) (must-be-a-syntax-error (and-let* ((x 1 2)))) (must-be-a-syntax-error (and-let* ((x 1) . oops))) (expect (let ((x 1)) (and-let* ((x (+ x 1)) (x (+ x 1)) (x (+ x 1))) (+ x 1))) 5) (expect (and-let* () (define x 1) (- x)) -1) (expect (and-let* ((x 2) (y (+ 1 x))) (define z (* x y)) (/ z)) 1/6) (check-report) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/ascii.sps����������������������������������������������0000664�0000000�0000000�00000020477�13751542066�0021715�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Automatically generated ;; Copyright 2019 Lassi Kortela ;; SPDX-License-Identifier: MIT (import (rnrs) (srfi :175)) (define-syntax want (syntax-rules () ((_ right-answer (proc args ...)) (unless (equal? right-answer (proc args ...)) (display "Failed: wanted ") (write right-answer) (display " but got ") (write (proc args ...)) (display " from ") (display '(proc args ...)) (newline))))) (want #f (ascii-codepoint? -1)) (want #t (ascii-codepoint? 0)) (want #t (ascii-codepoint? 127)) (want #f (ascii-codepoint? 128)) (want #t (ascii-char? (integer->char 0))) (want #t (ascii-char? (integer->char 127))) (want #f (ascii-char? (integer->char 128))) (want #t (ascii-string? "")) (want #t (ascii-string? "a")) (want #t (ascii-string? "a b c")) (want #f (ascii-string? "å b o")) (want #t (ascii-string? (make-string 1 (integer->char 127)))) (want #f (ascii-string? (make-string 1 (integer->char 128)))) (want #t (ascii-bytevector? (string->utf8 ""))) (want #t (ascii-bytevector? (string->utf8 "a"))) (want #t (ascii-bytevector? (string->utf8 "a b c"))) (want #f (ascii-bytevector? (string->utf8 "å b o"))) (want #t (ascii-bytevector? (string->utf8 (make-string 1 (integer->char 127))))) (want #f (ascii-bytevector? (string->utf8 (make-string 1 (integer->char 128))))) (want #t (ascii-non-control? #\ )) (want #f (ascii-non-control? #\ )) (want #f (ascii-non-control? #\ )) (want #f (ascii-non-control? (integer->char 13))) (want #t (ascii-space-or-tab? #\ )) (want #t (ascii-space-or-tab? #\ )) (want #f (ascii-space-or-tab? #\ )) (want #f (ascii-non-control? (integer->char 13))) (let ((lowers "abcdefghijklmnopqrstuvwxyz") (uppers "ABCDEFGHIJKLMNOPQRSTUVWXYZ")) (let loop ((i 0)) (when (fx<? i 26) (let ((lower (string-ref lowers i)) (upper (string-ref uppers i))) (want upper (ascii-upcase upper)) (want upper (ascii-upcase lower)) (want lower (ascii-downcase upper)) (want lower (ascii-downcase lower)) (loop (fx+ i 1)))))) (let loop ((cc 0)) (when (fx<? cc 128) (unless (ascii-alphabetic? cc) (want cc (ascii-upcase cc)) (want cc (ascii-downcase cc))) (loop (fx+ cc 1)))) (let loop ((cc 0)) (when (fx<? cc 128) (want #f (ascii-char? cc)) (want #t (ascii-char? (integer->char cc))) (cond ((ascii-alphabetic? cc) (want #t (ascii-upper-case? (ascii-upcase cc))) (want #t (ascii-lower-case? (ascii-downcase cc))) (want #f (ascii-lower-case? (ascii-upcase cc))) (want #f (ascii-upper-case? (ascii-downcase cc))) (want #t (ascii-alphanumeric? cc)) (want #t (ascii-non-control? cc)) (want #f (ascii-other-graphic? cc)) (want #f (ascii-control? cc)) (want #f (ascii-numeric? cc 10)) (want #f (ascii-whitespace? cc)) (want #f (ascii-space-or-tab? cc))) ((ascii-control? cc) (want #f (ascii-non-control? cc)) (want #f (ascii-other-graphic? cc)) (want cc (ascii-graphic->control (ascii-control->graphic cc))) (want (integer->char cc) (ascii-graphic->control (ascii-control->graphic (integer->char cc))))) ((member cc '(#\( #\) #\[ #\] #\{ #\} #\< #\>)) (want cc (ascii-mirror-bracket (ascii-mirror-bracket cc))))) (loop (fx+ cc 1)))) (let outer ((a 0)) (when (fx<? a 26) (let inner ((b 0)) (if (fx=? b 26) (outer (fx+ a 1)) (begin (want (fx=? a b) (ascii-ci=? (ascii-nth-lower-case a) (ascii-nth-upper-case b))) (want (fx<? a b) (ascii-ci<? (ascii-nth-lower-case a) (ascii-nth-upper-case b))) (want (fx<=? a b) (ascii-ci<=? (ascii-nth-lower-case a) (ascii-nth-upper-case b))) (want (fx>? a b) (ascii-ci>? (ascii-nth-lower-case a) (ascii-nth-upper-case b))) (want (fx>=? a b) (ascii-ci>=? (ascii-nth-lower-case a) (ascii-nth-upper-case b))) (inner (fx+ b 1))))))) (ascii-ci>? #\A #\_) (ascii-ci>? #\Z #\_) (want #f (ascii-char? -1)) (want #f (ascii-char? 128)) (want #f (ascii-char? (integer->char 128))) (want #f (ascii-control? -1)) (want #t (ascii-control? 0)) (want #t (ascii-control? 31)) (want #f (ascii-control? 32)) (want #f (ascii-control? 126)) (want #t (ascii-control? 127)) (want #f (ascii-control? 128)) (want 0 (ascii-digit-value #\0 10)) (want 0 (ascii-digit-value #\0 1)) (want #f (ascii-digit-value #\0 0)) (want #f (ascii-digit-value #\0 -1)) (want 7 (ascii-digit-value #\7 8)) (want #f (ascii-digit-value #\7 7)) (want #f (ascii-digit-value #\: 10)) (want 0 (ascii-upper-case-value #\A 0 26)) (want 25 (ascii-upper-case-value #\Z 0 26)) (want #f (ascii-upper-case-value #\Z 0 25)) (want 0 (ascii-lower-case-value #\a 0 26)) (want 25 (ascii-lower-case-value #\z 0 26)) (want #f (ascii-lower-case-value #\z 0 25)) (want 0 (ascii-lower-case-value #\a 0 1)) (want #f (ascii-lower-case-value #\a 0 0)) (want #f (ascii-lower-case-value #\a 0 -1)) (want 9001 (ascii-lower-case-value #\b 9000 2)) (want #f (ascii-nth-digit -1)) (want #\0 (ascii-nth-digit 0)) (want #\9 (ascii-nth-digit 9)) (want #f (ascii-nth-digit 10)) (want #\Z (ascii-nth-upper-case -1)) (want #\A (ascii-nth-upper-case 0)) (want #\Z (ascii-nth-upper-case 25)) (want #\A (ascii-nth-upper-case 26)) (want #\z (ascii-nth-lower-case -1)) (want #\a (ascii-nth-lower-case 0)) (want #\z (ascii-nth-lower-case 25)) (want #\a (ascii-nth-lower-case 26)) (define (count-matching predicates value) (let loop ((ps predicates) (n 0)) (if (null? ps) n (loop (cdr ps) (if ((car ps) value) (fx+ n 1) n))))) (define (union? whole . parts) (let check ((cc 0)) (or (fx=? cc 128) (if (and (whole cc) (not (fx=? 1 (count-matching parts cc)))) #f (check (fx+ cc 1)))))) (define (subset? small-set . bigger-sets) (let check ((cc 0)) (or (fx=? cc 128) (if (and (small-set cc) (fx=? 0 (count-matching bigger-sets cc))) #f (check (fx+ cc 1)))))) (define (disjoint? . predicates) (let check ((cc 0)) (or (fx=? cc 128) (and (fx<=? (count-matching predicates cc) 1) (check (fx+ cc 1)))))) (define (decimal-numeric? x) (ascii-numeric? x 10)) (want #t (union? ascii-alphanumeric? ascii-alphabetic? decimal-numeric?)) (want #t (union? ascii-alphabetic? ascii-upper-case? ascii-lower-case?)) (want #t (subset? ascii-space-or-tab? ascii-whitespace?)) (want #t (subset? ascii-other-graphic? ascii-non-control?)) (want #t (subset? ascii-upper-case? ascii-alphabetic? ascii-non-control?)) (want #t (subset? ascii-lower-case? ascii-alphabetic? ascii-non-control?)) (want #t (subset? ascii-alphabetic? ascii-alphanumeric? ascii-non-control?)) (want #t (subset? decimal-numeric? ascii-alphanumeric? ascii-non-control?)) (want #t (subset? ascii-alphanumeric? ascii-non-control?)) (want #t (disjoint? ascii-control? ascii-non-control?)) (want #t (disjoint? ascii-whitespace? ascii-other-graphic? ascii-upper-case? ascii-lower-case? decimal-numeric?)) (want #t (disjoint? ascii-control? ascii-other-graphic? ascii-upper-case? ascii-lower-case? decimal-numeric?)) (define (check-string-ci a b cmp) (want (fx=? cmp 0) (ascii-string-ci=? a b)) (want (fx<? cmp 0) (ascii-string-ci<? a b)) (want (fx>? cmp 0) (ascii-string-ci>? a b)) (want (fx<=? cmp 0) (ascii-string-ci<=? a b)) (want (fx>=? cmp 0) (ascii-string-ci>=? a b))) (check-string-ci "" "" 0) (check-string-ci "a" "a" 0) (check-string-ci "A" "a" 0) (check-string-ci "a" "A" 0) (check-string-ci "a" "b" -1) (check-string-ci "b" "a" 1) (check-string-ci "a" "B" -1) (check-string-ci "B" "a" 1) (check-string-ci "aa" "aa" 0) (check-string-ci "aa" "ab" -1) (check-string-ci "ab" "aa" 1) (check-string-ci "aa" "aaa" -1) (check-string-ci "aaa" "aa" 1) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/bitwise-operations.sps���������������������������������0000664�0000000�0000000�00000052727�13751542066�0024457�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Copyright © 2017 John Cowan ;; Copyright © 2020 Amirouche Boubekki ;; SPDX-License-Identifier: MIT #!r6rs ;; Tests for SRFI 151 (import (rnrs) (srfi :151 bitwise-operations) (srfi :64 testing)) (test-begin "bitwise-operations") (define check-001 (test-equal -1 (bitwise-not 0))) (define check-002 (test-equal 0 (bitwise-not -1))) (define check-003 (test-equal -11 (bitwise-not 10))) (define check-004 (test-equal 36 (bitwise-not -37))) (define check-005 (test-equal 0 (bitwise-and #b0 #b1))) (define check-006 (test-equal 1680869008 (bitwise-and -193073517 1689392892))) (define check-007 (test-equal 3769478 (bitwise-and 1694076839 -4290775858))) (define check-008 (test-equal 6 (bitwise-and 14 6))) (define check-009 (test-equal 10 (bitwise-and 11 26))) (define check-010 (test-equal 4 (bitwise-and 37 12))) (define check-011 (test-equal 1 (bitwise-and #b1 #b1))) (define check-012 (test-equal 0 (bitwise-and #b1 #b10))) (define check-013 (test-equal #b10 (bitwise-and #b11 #b10))) (define check-014 (test-equal #b101 (bitwise-and #b101 #b111))) (define check-015 (test-equal #b111 (bitwise-and -1 #b111))) (define check-016 (test-equal #b110 (bitwise-and -2 #b111))) (define check-017 (test-equal 3769478 (bitwise-and -4290775858 1694076839))) (define check-018 (test-equal -4294967295 (bitwise-ior 1 (- -1 #xffffffff)))) (define check-019 (test-equal -18446744073709551615 (bitwise-ior 1 (- -1 #xffffffffffffffff)))) (define check-020 (test-equal 14 (bitwise-ior 10 12))) (define check-021 (test-equal 11 (bitwise-ior 3 10))) (define check-022 (test-equal -4294967126 (bitwise-xor #b10101010 (- -1 #xffffffff)))) (define check-023 (test-equal -18446744073709551446 (bitwise-xor #b10101010 (- -1 #xffffffffffffffff)))) (define check-024 (test-equal -2600468497 (bitwise-ior 1694076839 -4290775858))) (define check-025 (test-equal -184549633 (bitwise-ior -193073517 1689392892))) (define check-026 (test-equal -2604237975 (bitwise-xor 1694076839 -4290775858))) (define check-027 (test-equal -1865418641 (bitwise-xor -193073517 1689392892))) (define check-028 (test-equal 6 (bitwise-xor 10 12))) (define check-029 (test-equal 9 (bitwise-xor 3 10))) (define check-030 (test-equal (bitwise-not -4294967126) (bitwise-eqv #b10101010 (- -1 #xffffffff)))) (define check-031 (test-equal -42 (bitwise-eqv 37 12))) (define check-032 (test-equal -1 (bitwise-nand 0 0))) (define check-033 (test-equal -1 (bitwise-nand 0 -1))) (define check-034 (test-equal -124 (bitwise-nand -1 123))) (define check-035 (test-equal -11 (bitwise-nand 11 26))) (define check-036 (test-equal -28 (bitwise-nor 11 26))) (define check-037 (test-equal 0 (bitwise-nor -1 123))) (define check-038 (test-equal 16 (bitwise-andc1 11 26))) (define check-039 (test-equal 1 (bitwise-andc2 11 26))) (define check-040 (test-equal -2 (bitwise-orc1 11 26))) (define check-041 (test-equal -1 (bitwise-nor 0 0))) (define check-042 (test-equal 0 (bitwise-nor 0 -1))) (define check-043 (test-equal 0 (bitwise-andc1 0 0))) (define check-044 (test-equal -1 (bitwise-andc1 0 -1))) (define check-045 (test-equal 123 (bitwise-andc1 0 123))) (define check-046 (test-equal 0 (bitwise-andc2 0 0))) (define check-047 (test-equal -1 (bitwise-andc2 -1 0))) (define check-048 (test-equal -1 (bitwise-orc1 0 0))) (define check-049 (test-equal -1 (bitwise-orc1 0 -1))) (define check-050 (test-equal 0 (bitwise-orc1 -1 0))) (define check-051 (test-equal -124 (bitwise-orc1 123 0))) (define check-052 (test-equal -1 (bitwise-orc2 0 0))) (define check-053 (test-equal -1 (bitwise-orc2 -1 0))) (define check-054 (test-equal 0 (bitwise-orc2 0 -1))) (define check-055 (test-equal -124 (bitwise-orc2 0 123))) ;; bitwise/integer (define check-056 (test-equal #x1000000000000000100000000000000000000000000000000 (arithmetic-shift #x100000000000000010000000000000000 64))) (define check-057 (test-equal #x8e73b0f7da0e6452c810f32b809079e5 (arithmetic-shift #x8e73b0f7da0e6452c810f32b809079e562f8ead2522c6b7b -64))) (define check-058 (test-equal 2 (arithmetic-shift 1 1))) (define check-059 (test-equal 0 (arithmetic-shift 1 -1))) (define check-060 (test-equal 1 (arithmetic-shift 1 0))) (define check-061 (test-equal 4 (arithmetic-shift 1 2))) (define check-062 (test-equal 8 (arithmetic-shift 1 3))) (define check-063 (test-equal 16 (arithmetic-shift 1 4))) (define check-064 (test-equal (expt 2 31) (arithmetic-shift 1 31))) (define check-065 (test-equal (expt 2 32) (arithmetic-shift 1 32))) (define check-066 (test-equal (expt 2 33) (arithmetic-shift 1 33))) (define check-067 (test-equal (expt 2 63) (arithmetic-shift 1 63))) (define check-068 (test-equal (expt 2 64) (arithmetic-shift 1 64))) (define check-069 (test-equal (expt 2 65) (arithmetic-shift 1 65))) (define check-070 (test-equal (expt 2 127) (arithmetic-shift 1 127))) (define check-071 (test-equal (expt 2 128) (arithmetic-shift 1 128))) (define check-072 (test-equal (expt 2 129) (arithmetic-shift 1 129))) (define check-073 (test-equal 3028397001194014464 (arithmetic-shift 11829675785914119 8))) (define check-074 (test-equal -1 (arithmetic-shift -1 0))) (define check-075 (test-equal -2 (arithmetic-shift -1 1))) (define check-076 (test-equal -4 (arithmetic-shift -1 2))) (define check-077 (test-equal -8 (arithmetic-shift -1 3))) (define check-078 (test-equal -16 (arithmetic-shift -1 4))) (define check-079 (test-equal (- (expt 2 31)) (arithmetic-shift -1 31))) (define check-080 (test-equal (- (expt 2 32)) (arithmetic-shift -1 32))) (define check-081 (test-equal (- (expt 2 33)) (arithmetic-shift -1 33))) (define check-082 (test-equal (- (expt 2 63)) (arithmetic-shift -1 63))) (define check-083 (test-equal (- (expt 2 64)) (arithmetic-shift -1 64))) (define check-084 (test-equal (- (expt 2 65)) (arithmetic-shift -1 65))) (define check-085 (test-equal (- (expt 2 127)) (arithmetic-shift -1 127))) (define check-086 (test-equal (- (expt 2 128)) (arithmetic-shift -1 128))) (define check-087 (test-equal (- (expt 2 129)) (arithmetic-shift -1 129))) (define check-088 (test-equal 0 (arithmetic-shift 1 -63))) (define check-089 (test-equal 0 (arithmetic-shift 1 -64))) (define check-090 (test-equal 0 (arithmetic-shift 1 -65))) (define check-091 (test-equal 32 (arithmetic-shift 8 2))) (define check-092 (test-equal 4 (arithmetic-shift 4 0))) (define check-093 (test-equal 4 (arithmetic-shift 8 -1))) (define check-094 (test-equal -79 (arithmetic-shift -100000000000000000000000000000000 -100))) (define check-095 (test-equal 2 (bit-count 12))) (define check-096 (test-equal 0 (integer-length 0))) (define check-097 (test-equal 1 (integer-length 1))) (define check-098 (test-equal 0 (integer-length -1))) (define check-099 (test-equal 3 (integer-length 7))) (define check-100 (test-equal 3 (integer-length -7))) (define check-101 (test-equal 4 (integer-length 8))) (define check-102 (test-equal 3 (integer-length -8))) (define check-103 (test-equal 9 (bitwise-if 3 1 8))) (define check-104 (test-equal 0 (bitwise-if 3 8 1))) (define check-105 (test-equal 3 (bitwise-if 1 1 2))) (define check-106 (test-equal #b00110011 (bitwise-if #b00111100 #b11110000 #b00001111))) ;; bitwise/single (define check-107 (test-equal #t (bit-set? 0 1))) (define check-108 (test-equal #f (bit-set? 1 1))) (define check-109 (test-equal #f (bit-set? 1 8))) (define check-110 (test-equal #t (bit-set? 10000 -1))) (define check-111 (test-equal #t (bit-set? 1000 -1))) (define check-112 (test-equal #t (bit-set? 64 #x10000000000000000))) (define check-113 (test-equal #f (bit-set? 64 1))) (define check-114 (test-equal #t (bit-set? 3 10))) (define check-115 (test-equal #t (bit-set? 2 6))) (define check-116 (test-equal #f (bit-set? 0 6))) (define check-117 (test-equal 0 (copy-bit 0 0 #f))) (define check-118 (test-equal 0 (copy-bit 30 0 #f))) (define check-119 (test-equal 0 (copy-bit 31 0 #f))) (define check-120 (test-equal 0 (copy-bit 62 0 #f))) (define check-121 (test-equal 0 (copy-bit 63 0 #f))) (define check-122 (test-equal 0 (copy-bit 128 0 #f))) (define check-123 (test-equal -1 (copy-bit 0 -1 #t))) (define check-124 (test-equal -1 (copy-bit 30 -1 #t))) (define check-125 (test-equal -1 (copy-bit 31 -1 #t))) (define check-126 (test-equal -1 (copy-bit 62 -1 #t))) (define check-127 (test-equal -1 (copy-bit 63 -1 #t))) (define check-128 (test-equal -1 (copy-bit 128 -1 #t))) (define check-129 (test-equal 1 (copy-bit 0 0 #t))) (define check-130 (test-equal #x106 (copy-bit 8 6 #t))) (define check-131 (test-equal 6 (copy-bit 8 6 #f))) (define check-132 (test-equal -2 (copy-bit 0 -1 #f))) (define check-133 (test-equal 0 (copy-bit 128 #x100000000000000000000000000000000 #f))) (define check-134 (test-equal #x100000000000000000000000000000000 (copy-bit 128 #x100000000000000000000000000000000 #t))) (define check-135 (test-equal #x100000000000000000000000000000000 (copy-bit 64 #x100000000000000000000000000000000 #f))) (define check-136 (test-equal #x-100000000000000000000000000000000 (copy-bit 64 #x-100000000000000000000000000000000 #f))) (define check-137 (test-equal #x-100000000000000000000000000000000 (copy-bit 256 #x-100000000000000000000000000000000 #t))) (define check-138 (test-equal #b100 (copy-bit 2 0 #t))) (define check-139 (test-equal #b1011 (copy-bit 2 #b1111 #f))) (define check-140 (test-equal #b1 (copy-bit 0 0 #t))) (define check-141 (test-equal #b1011 (bit-swap 1 2 #b1101))) (define check-142 (test-equal #b1011 (bit-swap 2 1 #b1101))) (define check-143 (test-equal #b1110 (bit-swap 0 1 #b1101))) (define check-144 (test-equal #b10000000101 (bit-swap 3 10 #b1101))) (define check-145 (test-equal 1 (bit-swap 0 2 4))) (define check-146 (test-equal #t (any-bit-set? 3 6))) (define check-147 (test-equal #f (any-bit-set? 3 12))) (define check-148 (test-equal #t (every-bit-set? 4 6))) (define check-149 (test-equal #f (every-bit-set? 7 6))) (define check-150 (test-equal -1 (first-set-bit 0))) (define check-151 (test-equal 0 (first-set-bit 1))) (define check-152 (test-equal 0 (first-set-bit 3))) (define check-153 (test-equal 2 (first-set-bit 4))) (define check-154 (test-equal 1 (first-set-bit 6))) (define check-155 (test-equal 0 (first-set-bit -1))) (define check-156 (test-equal 1 (first-set-bit -2))) (define check-157 (test-equal 0 (first-set-bit -3))) (define check-158 (test-equal 2 (first-set-bit -4))) (define check-159 (test-equal 128 (first-set-bit #x100000000000000000000000000000000))) (define check-160 (test-equal 1 (first-set-bit 2))) (define check-161 (test-equal 3 (first-set-bit 40))) (define check-162 (test-equal 2 (first-set-bit -28))) (define check-163 (test-equal 99 (first-set-bit (expt 2 99)))) (define check-164 (test-equal 99 (first-set-bit (expt -2 99)))) ;; bitwise/field (define check-165 (test-equal 0 (bit-field 6 0 1))) (define check-166 (test-equal 3 (bit-field 6 1 3))) (define check-167 (test-equal 1 (bit-field 6 2 999))) (define check-168 (test-equal 1 (bit-field #x100000000000000000000000000000000 128 129))) (define check-169 (test-equal #b1010 (bit-field #b1101101010 0 4))) (define check-170 (test-equal #b101101 (bit-field #b1101101010 3 9))) (define check-171 (test-equal #b10110 (bit-field #b1101101010 4 9))) (define check-172 (test-equal #b110110 (bit-field #b1101101010 4 10))) (define check-173 (test-equal #t (bit-field-any? #b101101 0 2))) (define check-174 (test-equal #t (bit-field-any? #b101101 2 4))) (define check-175 (test-equal #f (bit-field-any? #b101101 1 2))) (define check-176 (test-equal #f (bit-field-every? #b101101 0 2))) (define check-177 (test-equal #t (bit-field-every? #b101101 2 4))) (define check-178 (test-equal #t (bit-field-every? #b101101 0 1))) (define check-179 (test-equal #b100000 (bit-field-clear #b101010 1 4))) (define check-180 (test-equal #b101110 (bit-field-set #b101010 1 4))) (define check-181 (test-equal #b111 (bit-field-replace #b110 1 0 1))) (define check-182 (test-equal #b110 (bit-field-replace #b110 1 1 2))) (define check-183 (test-equal #b010 (bit-field-replace #b110 1 1 3))) (define check-184 (test-equal #b100100 (bit-field-replace #b101010 #b010 1 4))) (define check-185 (test-equal #b1001 (bit-field-replace-same #b1111 #b0000 1 3))) (define check-186 (test-equal #b110 (bit-field-rotate #b110 1 1 2))) (define check-187 (test-equal #b1010 (bit-field-rotate #b110 1 2 4))) (define check-188 (test-equal #b1011 (bit-field-rotate #b0111 -1 1 4))) (define check-188-bis (test-equal #b1011 (bit-field-rotate #b1101 -1 1 3))) (define check-188-ter (test-equal #b1011 (bit-field-rotate #b1101 1 1 3))) (define check-189 (test-equal #b0 (bit-field-rotate #b0 128 0 256))) (define check-190 (test-equal #b1 (bit-field-rotate #b1 128 1 256))) (define check-191 (test-equal #x100000000000000000000000000000000 (bit-field-rotate #x100000000000000000000000000000000 128 0 64))) (define check-192 (test-equal #x100000000000000000000000000000008 (bit-field-rotate #x100000000000000000000000000000001 3 0 64))) (define check-193 (test-equal #x100000000000000002000000000000000 (bit-field-rotate #x100000000000000000000000000000001 -3 0 64))) (define check-194 (test-equal #b110 (bit-field-rotate #b110 0 0 10))) (define check-195 (test-equal #b110 (bit-field-rotate #b110 0 0 256))) (define check-196 (test-equal 1 (bit-field-rotate #x100000000000000000000000000000000 1 0 129))) (define check-197 (test-equal 6 (bit-field-reverse 6 1 3))) (define check-198 (test-equal 12 (bit-field-reverse 6 1 4))) (define check-199 (test-equal #x80000000 (bit-field-reverse 1 0 32))) (define check-200 (test-equal #x40000000 (bit-field-reverse 1 0 31))) (define check-201 (test-equal #x20000000 (bit-field-reverse 1 0 30))) (define check-202 (test-equal (bitwise-ior (arithmetic-shift -1 32) #xFBFFFFFF) (bit-field-reverse -2 0 27))) (define check-203 (test-equal (bitwise-ior (arithmetic-shift -1 32) #xF7FFFFFF) (bit-field-reverse -2 0 28))) (define check-204 (test-equal (bitwise-ior (arithmetic-shift -1 32) #xEFFFFFFF) (bit-field-reverse -2 0 29))) (define check-205 (test-equal (bitwise-ior (arithmetic-shift -1 32) #xDFFFFFFF) (bit-field-reverse -2 0 30))) (define check-206 (test-equal (bitwise-ior (arithmetic-shift -1 32) #xBFFFFFFF) (bit-field-reverse -2 0 31))) (define check-207 (test-equal (bitwise-ior (arithmetic-shift -1 32) #x7FFFFFFF) (bit-field-reverse -2 0 32))) (define check-208 (test-equal 5 (bit-field-reverse #x140000000000000000000000000000000 0 129))) ;; bitwise/conversion (define check-209 (test-equal '(#t #f #t #f #t #t #t) (bits->list #b1110101))) (define check-210 (test-equal '(#f #t #f #t) (bits->list #b111010 4))) (define check-211 (test-equal #b1110101 (list->bits '(#t #f #t #f #t #t #t)))) (define check-212 (test-equal #b111010100 (list->bits '(#f #f #t #f #t #f #t #t #t)))) (define check-213 (test-equal '(#t #t) (bits->list 3))) (define check-214 (test-equal '(#f #t #t #f) (bits->list 6 4))) (define check-215 (test-equal '(#f #t) (bits->list 6 2))) (define check-216 (test-equal '(#t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f) (bits->list 1 128))) (define check-217 (test-equal '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t) (bits->list #x100000000000000000000000000000000))) (define check-218 (test-equal 6 (list->bits '(#f #t #t)))) (define check-219 (test-equal 12 (list->bits '(#f #f #t #t)))) (define check-220 (test-equal 6 (list->bits '(#f #t #t #f)))) (define check-221 (test-equal 2 (list->bits '(#f #t)))) (define check-222 (test-equal 1 (list->bits '(#t #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f)))) (define check-223 (test-equal #x100000000000000000000000000000000 (list->bits '(#f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #f #t)))) (define check-224 (test-equal #x03FFFFFF (list->bits '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)))) (define check-225 (test-equal #x07FFFFFF (list->bits '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)))) (define check-226 (test-equal #x0FFFFFFF (list->bits '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)))) (define check-227 (test-equal #x1FFFFFFF (list->bits '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)))) (define check-228 (test-equal #x3FFFFFFF (list->bits '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)))) (define check-229 (test-equal #x7FFFFFFF (list->bits '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)))) (define check-230 (test-equal #xFFFFFFFF (list->bits '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)))) (define check-231 (test-equal #x1FFFFFFFF (list->bits '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #t)))) (define check-232 (test-equal 1 (list->bits '(#t #f)))) (define check-233 (test-equal #b1110101 (vector->bits '#(#t #f #t #f #t #t #t)))) (define check-234 (test-equal #b00011010100 (vector->bits '#(#f #f #t #f #t #f #t #t)))) (define check-235 (test-equal '#(#t #t #t #f #t #f #t #f #f) (bits->vector #b1010111 9))) (define check-236 (test-equal '#(#t #t #t #f #t #f #t #f #f) (bits->vector #b1010111 9))) (define check-237 (test-equal #b1110101 (bits #t #f #t #f #t #t #t))) (define check-238 (test-equal 0 (bits))) (define check-239 (test-equal #b111010100 (bits #f #f #t #f #t #f #t #t #t))) ;; bitwise/fold (define check-240 (test-equal '(#t #f #t #f #t #t #t) (bitwise-fold cons '() #b1010111))) (define check-241 (test-equal 5 (let ((count 0)) (bitwise-for-each (lambda (b) (if b (set! count (+ count 1)))) #b1010111) count))) (define check-242 (test-equal #b101010101 (bitwise-unfold (lambda (i) (= i 10)) even? (lambda (i) (+ i 1)) 0))) (define check-243 (test-equal #t (let ((g (make-bitwise-generator #b110))) (and (equal? #f (g)) (equal? #t (g)) (equal? #t (g)) (equal? #f (g)))))) (test-end "bitwise-operations") �����������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/boxes.sps����������������������������������������������0000664�0000000�0000000�00000000554�13751542066�0021737�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Copyright © 2020 Amirouche Boubekki ;; SPDX-License-Identifier: MIT #!r6rs ;; Tests for SRFI 111 (import (rnrs) (srfi :111 boxes) (srfi :64 testing)) (test-begin "boxes") (test-equal #t (box? (box 42))) (test-equal 42 (unbox (box 42))) (test-equal 42 (let ((b (box 0))) (set-box! b 42) (unbox b))) (test-end "boxes") ����������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/char-sets.sps������������������������������������������0000664�0000000�0000000�00000003203�13751542066�0022502�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; -*- mode: scheme; coding: utf-8 -*- ;; Copyright © 2018 Göran Weinholt <goran@weinholt.se> ;; SPDX-License-Identifier: (MIT OR BSD-3-Clause OR LicenseRef-LICENSE) #!r6rs (import (rnrs) (srfi :14 char-sets inversion-list) (srfi :14 char-sets) (srfi :48 intermediate-format-strings) (srfi private include)) ;; Compatibility for Scheme 48 test suites (define-syntax define-test-suite (syntax-rules () ((_ suite) (define dummy 'suite)))) (define-syntax define-test-case (syntax-rules () ((_ test-case suite checks ...) (begin checks ...)))) (define (is-true) (lambda (x) x)) (define (is-false) not) (define-syntax check (syntax-rules (=>) ((_ expr) (check-that expr (is-true))) ((_ expr => expect) (check-that expr (lambda (x) (equal? x expect)))) ((_ expr (=> equal?) expect) (check-that expr (lambda (x) (equal? x expect)))))) (define-syntax check-that (syntax-rules () ((_ expr ok?) (let ((v expr)) (format #t "~s~%=>~%~s~%" 'expr v) (cond ((ok? v) (format #t ";; correct~%~%")) (else (format #t ";; *** failed ***~%test: ~s~%~%" 'ok?))))))) (define is (case-lambda ((= x) (lambda (y) (= x y))) ((x) (if (procedure? x) x (lambda (y) (equal? x y)))))) (define (opposite f) (lambda (x) (not (f x)))) (define (all-of . fs) (lambda (x) (for-all (lambda (f) (f x)) fs))) (define x->char-set ->char-set) (define char->scalar-value char->integer) (define scalar-value->char integer->char) (include/resolve ("srfi" "%3a14" "char-sets") "inversion-list-check.scm") (include/resolve ("srfi" "%3a14") "srfi-14-check.scm") ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/compare-procedures.sps���������������������������������0000664�0000000�0000000�00000000642�13751542066�0024414�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (except (rnrs) error) (rnrs r5rs) (rename (only (rnrs) write) (write pretty-write)) (srfi :23 error) (srfi :42 eager-comprehensions) (srfi private include) (srfi :67 compare-procedures)) (include/resolve ("srfi" "%3a67") "examples.scm") ����������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/cut.sps������������������������������������������������0000664�0000000�0000000�00000002224�13751542066�0021406�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (except (rnrs) display newline) (srfi :78 lightweight-testing) (srfi private include) (srfi :26 cut)) (define (ignore . _) (values)) (define display ignore) (define newline ignore) (define check-all ignore) (let-syntax ((define (syntax-rules (check check-all for-each quote equal?) ((_ (check _) . _) (begin)) ((_ (check-all) (for-each check '((equal? expr val) ...))) (begin (check expr => val) ...))))) (include/resolve ("srfi" "%3a26") "check.scm")) ;;;; free-identifier=? of <> and <...> (check (let* ((<> 'wrong) (f (cut list <> <...>))) (set! <> 'ok) (f 1 2)) => '(ok 1 2)) (check (let* ((<...> 'wrong) (f (cut list <> <...>))) (set! <...> 'ok) (f 1)) => '(1 ok)) (check (let* ((<> 'ok) (f (cute list <> <...>))) (set! <> 'wrong) (f 1 2)) => '(ok 1 2)) (check (let* ((<...> 'ok) (f (cute list <> <...>))) (set! <...> 'wrong) (f 1)) => '(1 ok)) (check-report) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/eager-comprehensions.sps�������������������������������0000664�0000000�0000000�00000001175�13751542066�0024734�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (except (rnrs) error) (rnrs mutable-strings) (srfi :23 error) (srfi private include) (srfi :42 eager-comprehensions)) (define (my-open-output-file filename) (open-file-output-port filename (file-options no-fail) 'block (native-transcoder))) (define (my-call-with-input-file filename thunk) (call-with-input-file filename thunk)) (include/resolve ("srfi" "%3a42") "examples.scm") ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/intermediate-format-strings.sps������������������������0000664�0000000�0000000�00000012562�13751542066�0026250�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs (import (rnrs) (rnrs mutable-pairs) (srfi :48 intermediate-format-strings) (srfi :78 lightweight-testing)) #;(define (format-lots n f fmt-str . args) (let loop ([i 0] [r #f]) (if (= i n) r (loop (+ 1 i) (apply f fmt-str args))))) (define-syntax expect (syntax-rules () [(_ expected expr) (check expr => expected)])) ;;;=================================================== (expect (format "test ~s" 'me) (format #f "test ~a" "me")) (check (format "~6,3F" 1/3) (=> member) '(" 0.333" " .333")) (expect " 12" (format "~4F" 12)) (expect " 12.346" (format "~8,3F" 12.3456)) (expect "123.346" (format "~6,3F" 123.3456)) (expect "123.346" (format "~4,3F" 123.3456)) (expect "0.000+1.949i" (format "~8,3F" (sqrt -3.8))) (expect " 32.00" (format "~6,2F" 32)) (expect " 32" (format "~6F" 32)) (check (format "~6F" 32.) ;; NB: (not (and (exact? 32.) (integer? 32.))) (=> member) '(" 32.0" " 32.")) (check (format "~8F" 32e45) (=> member) '(" 3.2e46" " 3.2e+46")) (expect " 3.2e-44" (format "~8,1F" 32e-45)) (check (format "~8F" 32e20) (=> member) '(" 3.2e21" " 3.2e+21")) (check (format "~8F" 32e5) (=> member) '("3200000.0" " 3.2e6" " 3.2e+6")) (check (format "~8F" 32e2) (=> member) '(" 3200.0" " 3200.")) (check (format "~8,2F" 32e10) (=> member) '(" 3.20e11" "3.20e+11" "320000000000.00")) (check (format "~0,3F" 20263/2813) (=> member) '( "7.203" )) (check (format "~0,2F" 20263/2813) (=> member) '( "7.20" )) (expect " 1.2345" (format "~12F" 1.2345)) (expect " 1.23" (format "~12,2F" 1.2345)) (expect " 1.234" (format "~12,3F" 1.2345)) ;; "round to even" (expect " 0.000+1.949i" (format "~20,3F" (sqrt -3.8))) (expect "0.000+1.949i" (format "~8,3F" (sqrt -3.8))) (check (format "~8,2F" 3.4567e11) (=> member) '(" 3.46e11" "3.46e+11" "345670000000.00")) (check (format "~w" (let ( (c (list 'a 'b 'c)) ) (set-cdr! (cddr c) c) c)) (=> member) '("#0=(a b c . #0#)" "#1=(a b c . #1#)")) (expect " " (format "~A~A~&" (list->string (list #\newline)) "")) (expect "a new test" (format "~a ~? ~a" 'a "~a" '(new) 'test)) (expect "a \"new\" test" (format "~a ~? ~a" 'a "~s" '("new") 'test)) ;; from SLIB (define-syntax test (syntax-rules () [(test <format-args> <expected>) (check (apply format <format-args>) => <expected>)])) (test '("abc") "abc") (test '("~a" 10) "10") (test '("~a" -1.2) "-1.2") (test '("~a" a) "a") (test '("~a" #t) "#t") (test '("~a" #f) "#f") (test '("~a" "abc") "abc") (test '("~a" #(1 2 3)) "#(1 2 3)") (test '("~a" ()) "()") (test '("~a" (a)) "(a)") (test '("~a" (a b)) "(a b)") (test '("~a" (a (b c) d)) "(a (b c) d)") (test '("~a" (a . b)) "(a . b)") (test '("~a" (a (b c . d))) "(a (b c . d))") ; # argument test (test '("~a ~a" 10 20) "10 20") (test '("~a abc ~a def" 10 20) "10 abc 20 def") ; numerical test (test '("~d" 100) "100") (test '("~x" 100) "64") (test '("~o" 100) "144") (test '("~b" 100) "1100100") ; character test (test '("~c" #\a) "a") ; tilde test (test '("~~~~") "~~") ; whitespace character test (test '("~%") " ") (test '("~&") " ") (test '("abc~&") "abc ") (test '("abc~&def") "abc def") (test '("~&") " ") (test '("~_~_~_") " ") ; indirection test (test '("~a ~? ~a" 10 "~a ~a" (20 30) 40) "10 20 30 40") ; slashify test (test '("~s" "abc") "\"abc\"") (test '("~s" "abc \\ abc") "\"abc \\\\ abc\"") (test '("~a" "abc \\ abc") "abc \\ abc") (test '("~s" "abc \" abc") "\"abc \\\" abc\"") (test '("~a" "abc \" abc") "abc \" abc") (test '("~s" #\space) "#\\space") ;(test '("~s" #\newline) "#\\newline") (test '("~s" #\a) "#\\a") (test '("~s" (a "b" c)) "(a \"b\" c)") (test '("~a" (a "b" c)) "(a b c)") ; fixed floating points (test '("~6,2f" 3.14159) " 3.14") (test '("~6,1f" 3.14159) " 3.1") (test '("~6,0f" 3.14159) " 3.") (test '("~5,1f" 0) " 0.0") (test '("~10,7f" 3.14159) " 3.1415900") (test '("~10,7f" -3.14159) "-3.1415900") (test '("~6,3f" 0.0) " 0.000") (check (format "~6,4f" 0.007) (=> member) '(" 7e-3" "0.0070" ".0070")) (check (format "~6,3f" 0.007) (=> member) '(" 7e-3" " 0.007")) (check (format "~6,2f" 0.007) (=> member) '(" 7e-3" " 0.01")) (check (format "~3,2f" 0.007) (=> member) '("7e-3" ".01" "0.01")) (check (format "~3,2f" -0.007) (=> member) '("-7e-3" "-.01" "-0.01")) (test '("~6,3f" 12345.6789) "12345.679") (test '("~6f" 23.4) " 23.4") (test '("~6f" 1234.5) "1234.5") (test '("~6f" 12345678) "12345678") (test '("~6,2f" 123.56789) "123.57") (test '("~6f" 123.0) " 123.0") (test '("~6f" -123.0) "-123.0") (test '("~6f" 0.0) " 0.0") (test '("~3,1f" 3.141) "3.1") (test '("~2,0f" 3.141) "3.") (test '("~1f" 3.141) "3.141") (test '("~f" 123.56789) "123.56789") (test '("~f" -314.0) "-314.0") (check (format "~f" 1e4) (=> member) '("1e4" "10000.0")) (check (format "~f" -1.23e10) (=> member) '("-1.23e10" "-1.23e+10" "-12300000000.0" "-12300000000.")) (check (format "~f" 1e-4) (=> member) '("1e-4" "0.0001" ".0001")) (check (format "~f" -1.23e-10) (=> member) '("-0.000000000123" "-1.23e-10")) (check-report) ;; #!eof ����������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/lazy.sps�����������������������������������������������0000664�0000000�0000000�00000017514�13751542066�0021602�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright André van Tonder. All Rights Reserved. ;; ;; Permission is hereby granted, free of charge, to any person ;; obtaining a copy of this software and associated documentation ;; files (the "Software"), to deal in the Software without ;; restriction, including without limitation the rights to use, copy, ;; modify, merge, publish, distribute, sublicense, and/or sell copies ;; of the Software, and to permit persons to whom the Software is ;; furnished to do so, subject to the following conditions: ;; ;; The above copyright notice and this permission notice shall be ;; included in all copies or substantial portions of the Software. ;; ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS ;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN ;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ;; SOFTWARE. ;; Modified by Andreas Rottmann to be an R6RS program. (import (rnrs) (only (rnrs r5rs) modulo) (srfi :64 testing) (srfi :45 lazy)) (define-syntax test-output (syntax-rules () ((_ expected proc) (test-equal expected (call-with-string-output-port proc))))) (define-syntax test-leak (syntax-rules () ((_ expr) (begin (display "Leak test, please watch memory consumption; press C-c when satisfied.\n") (guard (c (#t 'aborted)) expr))))) (test-begin "lazy-tests") ;========================================================================= ; TESTS AND BENCHMARKS: ;========================================================================= ;========================================================================= ; Memoization test 1: (test-output "hello" (lambda (port) (define s (delay (begin (display 'hello port) 1))) (test-equal 1 (force s)) (test-equal 1 (force s)))) ;========================================================================= ; Memoization test 2: (test-output "bonjour" (lambda (port) (let ((s (delay (begin (display 'bonjour port) 2)))) (test-equal 4 (+ (force s) (force s)))))) ;========================================================================= ; Memoization test 3: (pointed out by Alejandro Forero Cuervo) (test-output "hi" (lambda (port) (define r (delay (begin (display 'hi port) 1))) (define s (lazy r)) (define t (lazy s)) (test-equal 1 (force t)) (test-equal 1 (force r)))) ;========================================================================= ; Memoization test 4: Stream memoization (define (stream-drop s index) (lazy (if (zero? index) s (stream-drop (cdr (force s)) (- index 1))))) (define (ones port) (delay (begin (display 'ho port) (cons 1 (ones port))))) (test-output "hohohohoho" (lambda (port) (define s (ones port)) (test-equal 1 (car (force (stream-drop s 4)))) (test-equal 1 (car (force (stream-drop s 4)))))) ;========================================================================= ; Reentrancy test 1: from R5RS (letrec ((count 0) (p (delay (begin (set! count (+ count 1)) (if (> count x) count (force p))))) (x 5)) (test-equal 6 (force p)) (set! x 10) (test-equal 6 (force p))) ;========================================================================= ; Reentrancy test 2: from SRFI 40 (letrec ((f (let ((first? #t)) (delay (if first? (begin (set! first? #f) (force f)) 'second))))) (test-equal 'second (force f))) ;========================================================================= ; Reentrancy test 3: due to John Shutt (let* ((q (let ((count 5)) (define (get-count) count) (define p (delay (if (<= count 0) count (begin (set! count (- count 1)) (force p) (set! count (+ count 2)) count)))) (list get-count p))) (get-count (car q)) (p (cadr q))) (test-equal 5 (get-count)) (test-equal 0 (force p)) (test-equal 10 (get-count))) ;========================================================================= ; Test leaks: All the leak tests should run in bounded space. ;========================================================================= ; Leak test 1: Infinite loop in bounded space. (define (loop) (lazy (loop))) (test-leak (force (loop))) ;==> bounded space ;========================================================================= ; Leak test 2: Pending memos should not accumulate ; in shared structures. (let () (define s (loop)) (test-leak (force s))) ;==> bounded space ;========================================================================= ; Leak test 3: Safely traversing infinite stream. (define (from n) (delay (cons n (from (+ n 1))))) (define (traverse s) (lazy (traverse (cdr (force s))))) (test-leak (force (traverse (from 0)))) ;==> bounded space ;========================================================================= ; Leak test 4: Safely traversing infinite stream ; while pointer to head of result exists. (let () (define s (traverse (from 0))) (test-leak (force s))) ;==> bounded space ;========================================================================= ; Convenient list deconstructor used below. (define-syntax match (syntax-rules () ((match exp (() exp1) ((h . t) exp2)) (let ((lst exp)) (cond ((null? lst) exp1) ((pair? lst) (let ((h (car lst)) (t (cdr lst))) exp2)) (else 'match-error)))))) ;======================================================================== ; Leak test 5: Naive stream-filter should run in bounded space. ; Simplest case. (define (stream-filter p? s) (lazy (match (force s) (() (delay '())) ((h . t) (if (p? h) (delay (cons h (stream-filter p? t))) (stream-filter p? t)))))) (test-leak (force (stream-filter (lambda (n) (= n 10000000000)) (from 0)))) ;==> bounded space ;======================================================================== ; Leak test 6: Another long traversal should run in bounded space. ; The stream-ref procedure below does not strictly need to be lazy. ; It is defined lazy for the purpose of testing safe compostion of ; lazy procedures in the times3 benchmark below (previous ; candidate solutions had failed this). (define (stream-ref s index) (lazy (match (force s) (() 'error) ((h . t) (if (zero? index) (delay h) (stream-ref t (- index 1))))))) ; Check that evenness is correctly implemented - should terminate: (test-equal 0 (force (stream-ref (stream-filter zero? (from 0)) 0))) (let () (define s (stream-ref (from 0) 100000000)) (test-equal 100000000 (force s))) ;==> bounded space ;====================================================================== ; Leak test 7: Infamous example from SRFI 40. (define (times3 n) (stream-ref (stream-filter (lambda (x) (zero? (modulo x n))) (from 0)) 3)) (test-equal 21 (force (times3 7))) (test-equal 300000000 (force (times3 100000000))) ;==> bounded space (test-end "lazy-tests") ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/let.sps������������������������������������������������0000664�0000000�0000000�00000003702�13751542066�0021401�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;; Copyright © 2020 Göran Weinholt ;; SPDX-License-Identifier: MIT #!r6rs ;; Tests for SRFI 5 (import (except (rnrs) let) (rnrs eval) (srfi :5 let) (srfi :64 testing)) (test-begin "let") (test-equal (let () '()) '()) (test-equal (let ((a 0) (b 1) (c 2)) (list a b c)) '(0 1 2)) (test-equal (let ((a 0) (b 1) . (c* 2 3)) (list a b c*)) '(0 1 (2 3))) (test-end "let") (test-begin "named-let") (test-equal (let lp () '()) '()) (test-equal (let lp ((a 0) (b 1) (c 2)) (if (= a 10) (list a b c) (lp (+ a 1) (+ b 1) (+ c 1)))) '(10 11 12)) (test-equal (let lp ((a 0) (b 1) . (c* 2 3)) (if (= a 10) (list a b c*) (lp (+ a 1) (+ b 1) (+ (car c*) 1) (+ (cadr c*) 1)))) '(10 11 (12 13))) (test-equal (let lp ((a 0) . (x)) (if (= a 3) (list a x) (apply lp (+ a 1) (cons a x)))) '(3 (2 1 0))) (test-end "named-let") (test-begin "named-let-styled") (test-equal (let (lp) '()) '()) (test-equal (let (lp (a 0) (b 1) (c 2)) (if (= a 10) (list a b c) (lp (+ a 1) (+ b 1) (+ c 1)))) '(10 11 12)) (test-equal (let (lp (a 0) (b 1) . (c* 2 3)) (if (= a 10) (list a b c*) (lp (+ a 1) (+ b 1) (+ (car c*) 1) (+ (cadr c*) 1)))) '(10 11 (12 13))) (test-end "named-let-styled") ;; Check if the loop variable is visible to the arguments (test-begin "let-pitfall") (define env (environment '(srfi :5 let))) (test-equal (eval '(let lp (x 0) x) env) '(0)) ;check that eval works (test-error #t (eval '(let lp (x lp) x) env)) (test-error #t (eval '(let lp ((x 0) . (y lp)) y) env)) (test-end "let-pitfall") ��������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/lightweight-testing.sps��������������������������������0000664�0000000�0000000�00000000515�13751542066�0024606�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (rnrs) (rnrs r5rs) (srfi :42 eager-comprehensions) (srfi private include) (srfi :78 lightweight-testing)) (include/resolve ("srfi" "%3a78") "examples.scm") �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/list-queues.sps����������������������������������������0000664�0000000�0000000�00000007014�13751542066�0023075�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������; Reference SRFI-117 tests ported from (chibi test) to (srfi :64 testing). ; Using SRFI-64 test-group gave some trouble hence using test-begin/test-end. (import (rnrs) (srfi private define-values) (srfi :64 testing) (srfi :117 list-queues)) (test-begin "list-queues/simple") (test-equal '(1 1 1) (list-queue-list (make-list-queue '(1 1 1)))) (define x (list-queue 1 2 3)) (test-equal '(1 2 3) (list-queue-list x)) (define x1 (list 1 2 3)) (define x2 (make-list-queue x1 (cddr x1))) (test-equal 3 (list-queue-back x2)) (define y (list-queue 4 5)) (test-assert (list-queue? y)) (define z (list-queue-append x y)) (test-equal '(1 2 3 4 5) (list-queue-list z)) (define z2 (list-queue-append! x (list-queue-copy y))) (test-equal '(1 2 3 4 5) (list-queue-list z2)) (test-equal 1 (list-queue-front z)) (test-equal 5 (list-queue-back z)) (list-queue-remove-front! y) (test-equal '(5) (list-queue-list y)) (list-queue-remove-back! y) (test-assert (list-queue-empty? y)) (test-error (list-queue-remove-front! y)) (test-error (list-queue-remove-back! y)) (test-equal '(1 2 3 4 5) (list-queue-list z)) (test-equal '(1 2 3 4 5) (list-queue-remove-all! z2)) (test-assert (list-queue-empty? z2)) (list-queue-remove-all! z) (list-queue-add-front! z 1) (list-queue-add-front! z 0) (list-queue-add-back! z 2) (list-queue-add-back! z 3) (test-equal '(0 1 2 3) (list-queue-list z)) (test-end "list-queues/simple") (test-begin "list-queues/whole") (define a (list-queue 1 2 3)) (define b (list-queue-copy a)) (test-equal '(1 2 3) (list-queue-list b)) (list-queue-add-front! b 0) (test-equal '(1 2 3) (list-queue-list a)) (test-equal 4 (length (list-queue-list b))) (define c (list-queue-concatenate (list a b))) (test-equal '(1 2 3 0 1 2 3) (list-queue-list c)) (test-end "list-queues/whole") (test-begin "list-queues/map") (define r (list-queue 1 2 3)) (define s (list-queue-map (lambda (x) (* x 10)) r)) (test-equal '(10 20 30) (list-queue-list s)) (list-queue-map! (lambda (x) (+ x 1)) r) (test-equal '(2 3 4) (list-queue-list r)) (define sum 0) (list-queue-for-each (lambda (x) (set! sum (+ sum x))) s) (test-equal 60 sum) (test-end "list-queues/map") (test-begin "list-queues/conversion") (define n (list-queue 5 6)) (list-queue-set-list! n (list 1 2)) (test-equal '(1 2) (list-queue-list n)) (define d (list 1 2 3)) (define e (cddr d)) (define f (make-list-queue d e)) (define-values (dx ex) (list-queue-first-last f)) (test-assert (eq? d dx)) (test-assert (eq? e ex)) (test-equal '(1 2 3) (list-queue-list f)) (list-queue-add-front! f 0) (list-queue-add-back! f 4) (test-equal '(0 1 2 3 4) (list-queue-list f)) (define g (make-list-queue d e)) (test-equal '(1 2 3 4) (list-queue-list g)) (define h (list-queue 5 6)) (list-queue-set-list! h d e) (test-equal '(1 2 3 4) (list-queue-list h)) (test-end "list-queues/conversion") (test-begin "list-queues/unfold") (define (double x) (* x 2)) (define (done? x) (> x 3)) (define (add1 x) (+ x 1)) (define xx (list-queue-unfold done? double add1 0)) (test-equal '(0 2 4 6) (list-queue-list xx)) (define yy (list-queue-unfold-right done? double add1 0)) (test-equal '(6 4 2 0) (list-queue-list yy)) (define xx0 (list-queue 8)) (define xx1 (list-queue-unfold done? double add1 0 xx0)) (test-equal '(0 2 4 6 8) (list-queue-list xx1)) (define yy0 (list-queue 8)) (define yy1 (list-queue-unfold-right done? double add1 0 yy0)) (test-equal '(8 6 4 2 0) (list-queue-list yy1)) (test-end "list-queues/unfold") ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/lists.sps����������������������������������������������0000664�0000000�0000000�00000045457�13751542066�0021770�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ; Test suite for SRFI-1 ; 2003-12-29 / lth ; ; $Id: srfi-1-test.sps 5842 2008-12-11 23:04:51Z will $ ; ; Note: In Larceny, we require that the procedures designated as ; "linear update" variants in the spec (eg append!) side-effect their ; arguments, and there are tests here that check that side-effecting ; occurs. ; ; For linear update we only require that the cells of the result are ; taken from the cells of the input. We could be stricter and require ; that the cells of the results are the cells of the input with only ; the CDR changed, ie, values are never moved from one cell to another. (import (except (rnrs base) error map for-each) (rnrs io simple) (rnrs r5rs) (srfi :1 lists) (srfi :23 error)) (define (writeln . xs) (for-each display xs) (newline)) (define (fail token . more) (writeln "Error: test failed: " token) #f) ; Test cases are ordered as in the spec. R5RS procedures are left out. (or (equal? (xcons 1 2) '(2 . 1)) (fail 'xcons:1)) (or (equal? (cons* 1) 1) (fail 'cons*:1)) (or (equal? (cons* 1 2 3 4 5) '(1 2 3 4 . 5)) (fail 'cons*:2)) (or (equal? (make-list 5 #t) '(#t #t #t #t #t)) (fail 'make-list:1)) (or (equal? (make-list 0 #f) '()) (fail 'make-list:2)) (or (equal? (length (make-list 3)) 3) (fail 'make-list:3)) (or (equal? (list-tabulate 5 (lambda (x) x)) '(0 1 2 3 4)) (fail 'list-tabulate:1)) (or (equal? (list-tabulate 0 (lambda (x) (error "FOO!"))) '()) (fail 'list-tabluate:2)) (or (call-with-current-continuation (lambda (abort) (let* ((c (list 1 2 3 4 5)) (cp (list-copy c))) (or (equal? c cp) (abort #f)) (let loop ((c c) (cp cp)) (if (not (null? c)) (begin (or (not (eq? c cp)) (abort #f)) (loop (cdr c) (cdr cp))))) #t))) (fail 'list-copy:1)) (or (equal? (list-copy '(1 2 3 . 4)) '(1 2 3 . 4)) (fail 'list-copy:2)) (or (not (list? (circular-list 1 2 3))) (fail 'circular-list:1)) (or (let* ((a (list 'a)) (b (list 'b)) (c (list 'c)) (x (circular-list a b c))) (and (eq? a (car x)) (eq? b (cadr x)) (eq? c (caddr x)) (eq? a (cadddr x)))) (fail 'circular-list:2)) (or (equal? (iota 0) '()) (fail 'iota:1)) (or (equal? (iota 5 2 3) '(2 5 8 11 14)) (fail 'iota:2)) (or (equal? (iota 5 2) '(2 3 4 5 6)) (fail 'iota:3)) (or (proper-list? '(1 2 3 4 5)) (fail 'proper-list?:1)) (or (proper-list? '()) (fail 'proper-list?:2)) (or (not (proper-list? '(1 2 . 3))) (fail 'proper-list?:3)) (or (not (proper-list? (circular-list 1 2 3))) (fail 'proper-list:4)) (or (not (circular-list? '(1 2 3 4 5))) (fail 'circular-list?:1)) (or (not (circular-list? '())) (fail 'circular-list?:2)) (or (not (circular-list? '(1 2 . 3))) (fail 'circular-list?:3)) (or (circular-list? (circular-list 1 2 3)) (fail 'circular-list:4)) (or (not (dotted-list? '(1 2 3 4 5))) (fail 'dotted-list?:1)) (or (not (dotted-list? '())) (fail 'dotted-list?:2)) (or (dotted-list? '(1 2 . 3)) (fail 'dotted-list?:3)) (or (not (dotted-list? (circular-list 1 2 3))) (fail 'dotted-list:4)) (or (null-list? '()) (fail 'null-list?:1)) (or (not (null-list? '(1 2))) (fail 'null-list?:2)) (or (not (null-list? (circular-list 1 2))) (fail 'null-list?:3)) (or (not-pair? 1) (fail 'not-pair:1)) (or (not (not-pair? (cons 1 2))) (fail 'not-pair:2)) (or (list= = '(1 2 3) '(1 2 3) '(1 2 3)) (fail 'list=:1)) (or (not (list= = '(1 2 3) '(1 2 3) '(1 4 3))) (fail 'list=:2)) ; Checks that l0 is not being used when testing l2, cf spec (or (list= (lambda (a b) (not (eq? a b))) '(#f #f #f) '(#t #t #t) '(#f #f #f)) (fail 'list=:3)) (or (list= =) (fail 'list=:4)) (or (= (first '(1 2 3 4 5 6 7 8 9 10)) 1) (fail 'first)) (or (= (second '(1 2 3 4 5 6 7 8 9 10)) 2) (fail 'second)) (or (= (third '(1 2 3 4 5 6 7 8 9 10)) 3) (fail 'third)) (or (= (fourth '(1 2 3 4 5 6 7 8 9 10)) 4) (fail 'fourth)) (or (= (fifth '(1 2 3 4 5 6 7 8 9 10)) 5) (fail 'fifth)) (or (= (sixth '(1 2 3 4 5 6 7 8 9 10)) 6) (fail 'sixth)) (or (= (seventh '(1 2 3 4 5 6 7 8 9 10)) 7) (fail 'seventh)) (or (= (eighth '(1 2 3 4 5 6 7 8 9 10)) 8) (fail 'eighth)) (or (= (ninth '(1 2 3 4 5 6 7 8 9 10)) 9) (fail 'ninth)) (or (= (tenth '(1 2 3 4 5 6 7 8 9 10)) 10) (fail 'tenth)) (let-values (((a b) (car+cdr '(1 . 2)))) (or (and (= a 1) (= b 2)) (fail 'car+cdr:1))) (or (equal? '(1 2 3) (take '(1 2 3 4 5 6) 3)) (fail 'take:1)) (or (equal? '(1) (take '(1) 1)) (fail 'take:2)) (or (let ((x (list 1 2 3 4 5 6))) (eq? (cdddr x) (drop x 3))) (fail 'drop:1)) (or (let ((x (list 1 2 3))) (eq? x (drop x 0))) (fail 'drop:2)) (or (equal? '(4 5 6) (take-right '(1 2 3 4 5 6) 3)) (fail 'take-right:1)) (or (null? (take-right '(1 2 3 4 5 6) 0)) (fail 'take-right:2)) (or (equal? '(2 3 . 4) (take-right '(1 2 3 . 4) 2)) (fail 'take-right:3)) (or (equal? 4 (take-right '(1 2 3 . 4) 0)) (fail 'take-right:4)) (or (equal? '(1 2 3) (drop-right '(1 2 3 4 5 6) 3)) (fail 'drop-right:1)) (or (equal? '(1 2 3) (drop-right '(1 2 3) 0)) (fail 'drop-right:2)) (or (equal? '(1 2 3) (drop-right '(1 2 3 . 4) 0)) (fail 'drop-right:3)) (or (let ((x (list 1 2 3 4 5 6))) (let ((y (take! x 3))) (and (eq? x y) (eq? (cdr x) (cdr y)) (eq? (cddr x) (cddr y)) (equal? y '(1 2 3))))) (fail 'take!:1)) (or (let ((x (list 1 2 3 4 5 6))) (let ((y (drop-right! x 3))) (and (eq? x y) (eq? (cdr x) (cdr y)) (eq? (cddr x) (cddr y)) (equal? y '(1 2 3))))) (fail 'drop-right!:1)) (or (let-values (((a b) (split-at '(1 2 3 4 5 6) 2))) (and (equal? a '(1 2)) (equal? b '(3 4 5 6)))) (fail 'split-at:1)) (or (let* ((x (list 1 2 3 4 5 6)) (y (cddr x))) (let-values (((a b) (split-at! x 2))) (and (equal? a '(1 2)) (eq? a x) (equal? b '(3 4 5 6)) (eq? b y)))) (fail 'split-at!:1)) (or (eqv? 37 (last '(1 2 3 37))) (fail 'last:1)) (or (not (length+ (circular-list 1 2 3))) (fail 'length+:1)) (or (equal? 4 (length+ '(1 2 3 4))) (fail 'length+:2)) (or (let ((x (list 1 2)) (y (list 3 4)) (z (list 5 6))) (let ((r (append! x y '() z))) (and (equal? r '(1 2 3 4 5 6)) (eq? r x) (eq? (cdr r) (cdr x)) (eq? (cddr r) y) (eq? (cdddr r) (cdr y)) (eq? (cddddr r) z) (eq? (cdr (cddddr r)) (cdr z))))) (fail 'append!:1)) (or (equal? (concatenate '((1 2 3) (4 5 6) () (7 8 9))) '(1 2 3 4 5 6 7 8 9)) (fail 'concatenate:1)) (or (equal? (concatenate! `(,(list 1 2 3) ,(list 4 5 6) () ,(list 7 8 9))) '(1 2 3 4 5 6 7 8 9)) (fail 'concatenate!:1)) (or (equal? (append-reverse '(3 2 1) '(4 5 6)) '(1 2 3 4 5 6)) (fail 'append-reverse:1)) (or (equal? (append-reverse! (list 3 2 1) (list 4 5 6)) '(1 2 3 4 5 6)) (fail 'append-reverse!:1)) (or (equal? (zip '(1 2 3) '(4 5 6)) '((1 4) (2 5) (3 6))) (fail 'zip:1)) (or (equal? (zip '() '() '() '()) '()) (fail 'zip:2)) (or (equal? (zip '(1) (circular-list 1 2)) '((1 1))) (fail 'zip:3)) (or (equal? '(1 2 3 4 5) (unzip1 '((1) (2) (3) (4) (5)))) (fail 'unzip1:1)) (or (let-values (((a b) (unzip2 '((10 11) (20 21) (30 31))))) (and (equal? a '(10 20 30)) (equal? b '(11 21 31)))) (fail 'unzip2:1)) (or (let-values (((a b c) (unzip3 '((10 11 12) (20 21 22) (30 31 32))))) (and (equal? a '(10 20 30)) (equal? b '(11 21 31)) (equal? c '(12 22 32)))) (fail 'unzip3:1)) (or (let-values (((a b c d) (unzip4 '((10 11 12 13) (20 21 22 23) (30 31 32 33))))) (and (equal? a '(10 20 30)) (equal? b '(11 21 31)) (equal? c '(12 22 32)) (equal? d '(13 23 33)))) (fail 'unzip4:1)) (or (let-values (((a b c d e) (unzip5 '((10 11 12 13 14) (20 21 22 23 24) (30 31 32 33 34))))) (and (equal? a '(10 20 30)) (equal? b '(11 21 31)) (equal? c '(12 22 32)) (equal? d '(13 23 33)) (equal? e '(14 24 34)))) (fail 'unzip5:1)) (or (equal? 3 (count even? '(3 1 4 1 5 9 2 5 6))) (fail 'count:1)) (or (equal? 3 (count < '(1 2 4 8) '(2 4 6 8 10 12 14 16))) (fail 'count:2)) (or (equal? 2 (count < '(3 1 4 1) (circular-list 1 10))) (fail 'count:3)) (or (equal? '(c 3 b 2 a 1) (fold cons* '() '(a b c) '(1 2 3 4 5))) (fail 'fold:1)) (or (equal? '(a 1 b 2 c 3) (fold-right cons* '() '(a b c) '(1 2 3 4 5))) (fail 'fold-right:1)) (or (let* ((x (list 1 2 3)) (r (list x (cdr x) (cddr x))) (y (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() x))) (and (equal? y '(3 2 1)) (every (lambda (c) (memq c r)) (list y (cdr y) (cddr y))))) (fail 'pair-fold:1)) (or (equal? '((a b c) (b c) (c)) (pair-fold-right cons '() '(a b c))) (fail 'pair-fold-right:1)) (or (equal? 5 (reduce max 'illegal '(1 2 3 4 5))) (fail 'reduce:1)) (or (equal? 0 (reduce max 0 '())) (fail 'reduce:2)) (or (equal? '(1 2 3 4 5) (reduce-right append 'illegal '((1 2) () (3 4 5)))) (fail 'reduce-right:1)) (or (equal? '(1 4 9 16 25 36 49 64 81 100) (unfold (lambda (x) (> x 10)) (lambda (x) (* x x)) (lambda (x) (+ x 1)) 1)) (fail 'unfold:1)) (or (equal? '(1 4 9 16 25 36 49 64 81 100) (unfold-right zero? (lambda (x) (* x x)) (lambda (x) (- x 1)) 10)) (fail 'unfold-right:1)) (or (equal? '(4 1 5 1) (map + '(3 1 4 1) (circular-list 1 0))) (fail 'map:1)) (or (equal? '(5 4 3 2 1) (let ((v 1) (l '())) (for-each (lambda (x y) (let ((n v)) (set! v (+ v 1)) (set! l (cons n l)))) '(0 0 0 0 0) (circular-list 1 2)) l)) (fail 'for-each:1)) (or (equal? '(1 -1 3 -3 8 -8) (append-map (lambda (x) (list x (- x))) '(1 3 8))) (fail 'append-map:1)) (or (equal? '(1 -1 3 -3 8 -8) (append-map! (lambda (x) (list x (- x))) '(1 3 8))) (fail 'append-map!:1)) (or (let* ((l (list 1 2 3)) (m (map! (lambda (x) (* x x)) l))) (and (equal? m '(1 4 9)) (equal? l '(1 4 9)))) (fail 'map!:1)) (or (equal? '(1 2 3 4 5) (let ((v 1)) (map-in-order (lambda (x) (let ((n v)) (set! v (+ v 1)) n)) '(0 0 0 0 0)))) (fail 'map-in-order:1)) (or (equal? '((3) (2 3) (1 2 3)) (let ((xs (list 1 2 3)) (l '())) (pair-for-each (lambda (x) (set! l (cons x l))) xs) l)) (fail 'pair-for-each:1)) (or (equal? '(1 9 49) (filter-map (lambda (x y) (and (number? x) (* x x))) '(a 1 b 3 c 7) (circular-list 1 2))) (fail 'filter-map:1)) (or (equal? '(0 8 8 -4) (filter even? '(0 7 8 8 43 -4))) (fail 'filter:1)) (or (let-values (((a b) (partition symbol? '(one 2 3 four five 6)))) (and (equal? a '(one four five)) (equal? b '(2 3 6)))) (fail 'partition:1)) (or (equal? '(7 43) (remove even? '(0 7 8 8 43 -4))) (fail 'remove:1)) (or (let* ((x (list 0 7 8 8 43 -4)) (y (pair-fold cons '() x)) (r (filter! even? x))) (and (equal? '(0 8 8 -4) r) (every (lambda (c) (memq c y)) (pair-fold cons '() r)))) (fail 'filter!:1)) (or (let* ((x (list 'one 2 3 'four 'five 6)) (y (pair-fold cons '() x))) (let-values (((a b) (partition! symbol? x))) (and (equal? a '(one four five)) (equal? b '(2 3 6)) (every (lambda (c) (memq c y)) (pair-fold cons '() a)) (every (lambda (c) (memq c y)) (pair-fold cons '() b))))) (fail 'partition!:1)) (or (let* ((x (list 0 7 8 8 43 -4)) (y (pair-fold cons '() x)) (r (remove! even? x))) (and (equal? '(7 43) r) (every (lambda (c) (memq c y)) (pair-fold cons '() r)))) (fail 'remove!:1)) (or (equal? 4 (find even? '(3 1 4 1 5 9 8))) (fail 'find:1)) (or (equal? '(4 1 5 9 8) (find-tail even? '(3 1 4 1 5 9 8))) (fail 'find-tail:1)) (or (equal? '#f (find-tail even? '(1 3 5 7))) (fail 'find-tail:2)) (or (equal? '(2 18) (take-while even? '(2 18 3 10 22 9))) (fail 'take-while:1)) (or (let* ((x (list 2 18 3 10 22 9)) (r (take-while! even? x))) (and (equal? r '(2 18)) (eq? r x) (eq? (cdr r) (cdr x)))) (fail 'take-while!:1)) (or (equal? '(3 10 22 9) (drop-while even? '(2 18 3 10 22 9))) (fail 'drop-while:1)) (or (let-values (((a b) (span even? '(2 18 3 10 22 9)))) (and (equal? a '(2 18)) (equal? b '(3 10 22 9)))) (fail 'span:1)) (or (let-values (((a b) (break even? '(3 1 4 1 5 9)))) (and (equal? a '(3 1)) (equal? b '(4 1 5 9)))) (fail 'break:1)) (or (let* ((x (list 2 18 3 10 22 9)) (cells (pair-fold cons '() x))) (let-values (((a b) (span! even? x))) (and (equal? a '(2 18)) (equal? b '(3 10 22 9)) (every (lambda (x) (memq x cells)) (pair-fold cons '() a)) (every (lambda (x) (memq x cells)) (pair-fold cons '() b))))) (fail 'span!:1)) (or (let* ((x (list 3 1 4 1 5 9)) (cells (pair-fold cons '() x))) (let-values (((a b) (break! even? x))) (and (equal? a '(3 1)) (equal? b '(4 1 5 9)) (every (lambda (x) (memq x cells)) (pair-fold cons '() a)) (every (lambda (x) (memq x cells)) (pair-fold cons '() b))))) (fail 'break!:1)) (or (any integer? '(a 3 b 2.7)) (fail 'any:1)) (or (not (any integer? '(a 3.1 b 2.7))) (fail 'any:2)) (or (any < '(3 1 4 1 5) (circular-list 2 7 1 8 2)) (fail 'any:3)) (or (equal? 'yes (any (lambda (a b) (if (< a b) 'yes #f)) '(1 2 3) '(0 1 4))) (fail 'any:4)) (or (every integer? '(1 2 3)) (fail 'every:1)) (or (not (every integer? '(3 4 5.1))) (fail 'every:2)) (or (every < '(1 2 3) (circular-list 2 3 4)) (fail 'every:3)) (or (equal? 2 (list-index even? '(3 1 4 1 5 9))) (fail 'list-index:1)) (or (equal? 1 (list-index < '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2))) (fail 'list-index:2)) (or (not (list-index = '(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2))) (fail 'list-index:3)) (or (equal? '(37 48) (member 5 '(1 2 5 37 48) <)) (fail 'member:1)) (or (equal? '(1 2 5) (delete 5 '(1 48 2 5 37) <)) (fail 'delete:1)) (or (equal? '(1 2 7) (delete 5 '(1 5 2 5 7))) (fail 'delete:2)) (or (let* ((x (list 1 48 2 5 37)) (cells (pair-fold cons '() x)) (r (delete! 5 x <))) (and (equal? r '(1 2 5)) (every (lambda (x) (memq x cells)) (pair-fold cons '() r)))) (fail 'delete!:1)) (or (equal? '((a . 3) (b . 7) (c . 1)) (delete-duplicates '((a . 3) (b . 7) (a . 9) (c . 1)) (lambda (x y) (eq? (car x) (car y))))) (fail 'delete-duplicates:1)) (or (equal? '(a b c z) (delete-duplicates '(a b a c a b c z) eq?)) (fail 'delete-duplicates:2)) (or (let* ((x (list 'a 'b 'a 'c 'a 'b 'c 'z)) (cells (pair-fold cons '() x)) (r (delete-duplicates! x))) (and (equal? '(a b c z) r) (every (lambda (x) (memq x cells)) (pair-fold cons '() r)))) (fail 'delete-duplicates!:1)) (or (equal? '(3 . #t) (assoc 6 '((4 . #t) (3 . #t) (5 . #t)) (lambda (x y) (zero? (remainder x y))))) (fail 'assoc:1)) (or (equal? '((1 . #t) (2 . #f)) (alist-cons 1 #t '((2 . #f)))) (fail 'alist-cons:1)) (or (let* ((a (list (cons 1 2) (cons 3 4))) (b (alist-copy a))) (and (equal? a b) (every (lambda (x) (not (memq x b))) a) (every (lambda (x) (not (memq x a))) b))) (fail 'alist-copy:1)) (or (equal? '((1 . #t) (2 . #t) (4 . #t)) (alist-delete 5 '((1 . #t) (2 . #t) (37 . #t) (4 . #t) (48 #t)) <)) (fail 'alist-delete:1)) (or (equal? '((1 . #t) (2 . #t) (4 . #t)) (alist-delete 7 '((1 . #t) (2 . #t) (7 . #t) (4 . #t) (7 #t)))) (fail 'alist-delete:2)) (or (let* ((x (list-copy '((1 . #t) (2 . #t) (7 . #t) (4 . #t) (7 #t)))) (y (list-copy x)) (cells (pair-fold cons '() x)) (r (alist-delete! 7 x))) (and (equal? r '((1 . #t) (2 . #t) (4 . #t))) (every (lambda (x) (memq x cells)) (pair-fold cons '() r)) (every (lambda (x) (memq x y)) r))) (fail 'alist-delete!:1)) (or (lset<= eq? '(a) '(a b a) '(a b c c)) (fail 'lset<=:1)) (or (not (lset<= eq? '(a) '(a b a) '(a))) (fail 'lset<=:2)) (or (lset<= eq?) (fail 'lset<=:3)) (or (lset<= eq? '(a)) (fail 'lset<=:4)) (or (lset= eq? '(b e a) '(a e b) '(e e b a)) (fail 'lset=:1)) (or (not (lset= eq? '(b e a) '(a e b) '(e e b a c))) (fail 'lset=:2)) (or (lset= eq?) (fail 'lset=:3)) (or (lset= eq? '(a)) (fail 'lset=:4)) (or (equal? '(u o i a b c d c e) (lset-adjoin eq? '(a b c d c e) 'a 'e 'i 'o 'u)) (fail 'lset-adjoin:1)) (or (equal? '(u o i a b c d e) (lset-union eq? '(a b c d e) '(a e i o u))) (fail 'lset-union:1)) (or (equal? '(x a a c) (lset-union eq? '(a a c) '(x a x))) (fail 'lset-union:2)) (or (null? (lset-union eq?)) (fail 'lset-union:3)) (or (equal? '(a b c) (lset-union eq? '(a b c))) (fail 'lset-union:4)) (or (equal? '(a e) (lset-intersection eq? '(a b c d e) '(a e i o u))) (fail 'lset-intersection:1)) (or (equal? '(a x a) (lset-intersection eq? '(a x y a) '(x a x z))) (fail 'lset-intersection:2)) (or (equal? '(a b c) (lset-intersection eq? '(a b c))) (fail 'lset-intersection:3)) (or (equal? '(b c d) (lset-difference eq? '(a b c d e) '(a e i o u))) (fail 'lset-difference:1)) (or (equal? '(a b c) (lset-difference eq? '(a b c))) (fail 'lset-difference:2)) (or (lset= eq? '(d c b i o u) (lset-xor eq? '(a b c d e) '(a e i o u))) (fail 'lset-xor:1)) (or (lset= eq? '() (lset-xor eq?)) (fail 'lset-xor:2)) (or (lset= eq? '(a b c d e) (lset-xor eq? '(a b c d e))) (fail 'lset-xor:3)) (or (let-values (((d i) (lset-diff+intersection eq? '(a b c d e) '(c d f)))) (and (equal? d '(a b e)) (equal? i '(c d)))) (fail 'lset-diff+intersection:1)) ; FIXME: For the following five procedures, need to check that cells ; returned are from the arguments. (or (equal? '(u o i a b c d e) (lset-union! eq? (list 'a 'b 'c 'd 'e) (list 'a 'e 'i 'o 'u))) (fail 'lset-union!:1)) (or (equal? '(x a a c) (lset-union! eq? (list 'a 'a 'c) (list 'x 'a 'x))) (fail 'lset-union!:2)) (or (null? (lset-union! eq?)) (fail 'lset-union!:3)) (or (equal? '(a b c) (lset-union! eq? (list 'a 'b 'c))) (fail 'lset-union!:4)) (or (equal? '(a e) (lset-intersection! eq? (list 'a 'b 'c 'd 'e) (list 'a 'e 'i 'o 'u))) (fail 'lset-intersection!:1)) (or (equal? '(a x a) (lset-intersection! eq? (list 'a 'x 'y 'a) (list 'x 'a 'x 'z))) (fail 'lset-intersection!:2)) (or (equal? '(a b c) (lset-intersection! eq? (list 'a 'b 'c))) (fail 'lset-intersection!:3)) (or (equal? '(b c d) (lset-difference! eq? (list 'a 'b 'c 'd 'e) (list 'a 'e 'i 'o 'u))) (fail 'lset-difference!:1)) (or (equal? '(a b c) (lset-difference! eq? (list 'a 'b 'c))) (fail 'lset-difference!:2)) (or (lset= eq? '(d c b i o u) (lset-xor! eq? (list 'a 'b 'c 'd 'e) (list 'a 'e 'i 'o 'u))) (fail 'lset-xor!:1)) (or (lset= eq? '() (lset-xor! eq?)) (fail 'lset-xor!:2)) (or (lset= eq? '(a b c d e) (lset-xor! eq? (list 'a 'b 'c 'd 'e))) (fail 'lset-xor!:3)) (or (let-values (((d i) (lset-diff+intersection! eq? (list 'a 'b 'c 'd 'e) (list 'c 'd 'f)))) (and (equal? d '(a b e)) (equal? i '(c d)))) (fail 'lset-diff+intersection!:1)) (writeln "Done.") �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/multi-dimensional-arrays--arlib.sps��������������������0000664�0000000�0000000�00000001136�13751542066�0026711�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (rnrs) (srfi :25 multi-dimensional-arrays) (srfi :25 multi-dimensional-arrays arlib) (srfi :78 lightweight-testing) (srfi private include)) (define-syntax past (syntax-rules () ((_ . r) (begin)))) (let-syntax ((or (syntax-rules (error) ((_ expr (error msg)) (check expr => #T)) ((_ . r) (or . r))))) (include/resolve ("srfi" "%3a25") "list.scm")) (check-report) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/multi-dimensional-arrays.sps���������������������������0000664�0000000�0000000�00000001130�13751542066�0025537�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (rnrs) (srfi :25 multi-dimensional-arrays) (srfi :78 lightweight-testing) (srfi private include)) (let-syntax ((or (syntax-rules (error) ((_ expr (error msg)) (check (and expr #T) => #T)) ((_ . r) (or . r)))) (past (syntax-rules () ((_ . r) (values))))) (include/resolve ("srfi" "%3a25") "test.scm")) (check-report) ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/os-environment-variables.sps���������������������������0000664�0000000�0000000�00000001665�13751542066�0025554�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (rename (rnrs) (for-all andmap)) (srfi :78 lightweight-testing) (srfi :98 os-environment-variables)) (check (list? (get-environment-variables)) => #T) (check (andmap (lambda (a) (and (pair? a) (string? (car a)) (positive? (string-length (car a))) (string? (cdr a)))) (get-environment-variables)) => #T) (check (andmap (lambda (a) (let ((v (get-environment-variable (car a)))) (and (string? v) (string=? v (cdr a))))) (get-environment-variables)) => #T) (assert (not (assoc "BLAH" (get-environment-variables)))) (check (get-environment-variable "BLAH") => #F) (check-report) ���������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/r6rs-hashtables.ikarus.sps�����������������������������0000664�0000000�0000000�00000027533�13751542066�0025132�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;-*- mode: scheme -*- (import (rnrs base) (rnrs control) (rnrs io simple) (only (srfi :1) lset= lset-adjoin) (srfi :64) (srfi :126)) (define (exact-integer? obj) (and (integer? obj) (exact? obj))) ;; INCLUDE test-suite.body.scm ;;; This doesn't test weakness, external representation, and quasiquote. (test-begin "SRFI-126") (test-group "constructors & inspection" (test-group "eq" (let ((tables (list (make-eq-hashtable) (make-eq-hashtable 10) (make-eq-hashtable #f #f) (make-hashtable #f eq?) (alist->eq-hashtable '((a . b) (c . d))) (alist->eq-hashtable 10 '((a . b) (c . d))) (alist->eq-hashtable #f #f '((a . b) (c . d)))))) (do ((tables tables (cdr tables)) (i 0 (+ i 1))) ((null? tables)) (let ((table (car tables)) (label (number->string i))) (test-assert label (hashtable? table)) (test-eq label #f (hashtable-hash-function table)) (test-eq label eq? (hashtable-equivalence-function table)) (test-eq label #f (hashtable-weakness table)) (test-assert label (hashtable-mutable? table)))))) (test-group "eqv" (let ((tables (list (make-eqv-hashtable) (make-eqv-hashtable 10) (make-eqv-hashtable #f #f) (make-hashtable #f eqv?) (alist->eqv-hashtable '((a . b) (c . d))) (alist->eqv-hashtable 10 '((a . b) (c . d))) (alist->eqv-hashtable #f #f '((a . b) (c . d)))))) (do ((tables tables (cdr tables)) (i 0 (+ i 1))) ((null? tables)) (let ((table (car tables)) (label (number->string i))) (test-assert label (hashtable? table)) (test-eq label #f (hashtable-hash-function table)) (test-eq label eqv? (hashtable-equivalence-function table)) (test-eq label #f (hashtable-weakness table)) (test-assert label (hashtable-mutable? table)))))) #; (test-group "equal" (let ((tables (list (make-hashtable equal-hash equal?) (make-hashtable equal-hash equal? 10) (make-hashtable equal-hash equal? #f #f) (alist->hashtable equal-hash equal? '((a . b) (c . d))) (alist->hashtable equal-hash equal? 10 '((a . b) (c . d))) (alist->hashtable equal-hash equal? #f #f '((a . b) (c . d)))))) (do ((tables tables (cdr tables)) (i 0 (+ i 1))) ((null? tables)) (let ((table (car tables)) (label (number->string i))) (test-assert label (hashtable? table)) (test-eq label equal-hash (hashtable-hash-function table)) (test-eq label equal? (hashtable-equivalence-function table)) (test-eq label #f (hashtable-weakness table)) (test-assert label (hashtable-mutable? table)))) (let ((table (make-hashtable (cons equal-hash equal-hash) equal?))) (let ((hash (hashtable-hash-function table))) (test-assert (or (eq? equal-hash hash) (and (eq? equal-hash (car hash)) (eq? equal-hash (cdr hash))))))))) (test-group "alist" (let ((tables (list (alist->eq-hashtable '((a . b) (a . c))) (alist->eqv-hashtable '((a . b) (a . c))) #; (alist->hashtable equal-hash equal? '((a . b) (a . c)))))) (do ((tables tables (cdr tables)) (i 0 (+ i 1))) ((null? tables)) (let ((table (car tables)) (label (number->string i))) (test-eq label 'b (hashtable-ref table 'a))))))) (test-group "procedures" (test-group "basics" (let ((table (make-eq-hashtable))) (test-group "ref" (test-error (hashtable-ref table 'a)) (test-eq 'b (hashtable-ref table 'a 'b)) (test-assert (not (hashtable-contains? table 'a))) (test-eqv 0 (hashtable-size table))) (test-group "set" (hashtable-set! table 'a 'c) (test-eq 'c (hashtable-ref table 'a)) (test-eq 'c (hashtable-ref table 'a 'b)) (test-assert (hashtable-contains? table 'a)) (test-eqv 1 (hashtable-size table))) (test-group "delete" (hashtable-delete! table 'a) (test-error (hashtable-ref table 'a)) (test-eq 'b (hashtable-ref table 'a 'b)) (test-assert (not (hashtable-contains? table 'a))) (test-eqv 0 (hashtable-size table))))) (test-group "advanced" (let ((table (make-eq-hashtable))) (test-group "lookup" (let-values (((x found?) (hashtable-lookup table 'a))) (test-assert (not found?)))) (test-group "update" (test-error (hashtable-update! table 'a (lambda (x) (+ x 1)))) (hashtable-update! table 'a (lambda (x) (+ x 1)) 0) (let-values (((x found?) (hashtable-lookup table 'a))) (test-eqv 1 x) (test-assert found?)) (hashtable-update! table 'a (lambda (x) (+ x 1))) (let-values (((x found?) (hashtable-lookup table 'a))) (test-eqv x 2) (test-assert found?)) (hashtable-update! table 'a (lambda (x) (+ x 1)) 0) (let-values (((x found?) (hashtable-lookup table 'a))) (test-eqv x 3) (test-assert found?))) (test-group "intern" (test-eqv 0 (hashtable-intern! table 'b (lambda () 0))) (test-eqv 0 (hashtable-intern! table 'b (lambda () 1)))))) (test-group "copy/clear" (let ((table (alist->hashtable #f eq? '((a . b))))) (test-group "copy" (let ((table2 (hashtable-copy table))) (test-eq eq? (hashtable-equivalence-function table2)) (test-eq 'b (hashtable-ref table2 'a)) (test-error (hashtable-set! table2 'a 'c))) (let ((table2 (hashtable-copy table #f))) (test-eq eq? (hashtable-equivalence-function table2)) (test-eq 'b (hashtable-ref table2 'a)) (test-error (hashtable-set! table2 'a 'c))) (let ((table2 (hashtable-copy table #t))) (test-eq eq? (hashtable-equivalence-function table2)) (test-eq 'b (hashtable-ref table2 'a)) (hashtable-set! table2 'a 'c) (test-eq 'c (hashtable-ref table2 'a))) (let ((table2 (hashtable-copy table #f #f))) (test-eq eq? (hashtable-equivalence-function table2)) (test-eq #f (hashtable-weakness table2)))) (test-group "clear" (let ((table2 (hashtable-copy table #t))) (hashtable-clear! table2) (test-eqv 0 (hashtable-size table2))) (let ((table2 (hashtable-copy table #t))) (hashtable-clear! table2 10) (test-eqv 0 (hashtable-size table2)))) (test-group "empty-copy" (let ((table2 (hashtable-empty-copy table))) (test-eq eq? (hashtable-equivalence-function table2)) (test-eqv 0 (hashtable-size table2))) (let ((table2 (hashtable-empty-copy table 10))) (test-eq eq? (hashtable-equivalence-function table2)) (test-eqv 0 (hashtable-size table2)))))) (test-group "keys/values" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (test-assert (lset= eq? '(a c) (vector->list (hashtable-keys table)))) (test-assert (lset= eq? '(b d) (vector->list (hashtable-values table)))) (let-values (((keys values) (hashtable-entries table))) (test-assert (lset= eq? '(a c) (vector->list keys))) (test-assert (lset= eq? '(b d) (vector->list values)))) (test-assert (lset= eq? '(a c) (hashtable-key-list table))) (test-assert (lset= eq? '(b d) (hashtable-value-list table))) (let-values (((keys values) (hashtable-entry-lists table))) (test-assert (lset= eq? '(a c) keys)) (test-assert (lset= eq? '(b d) values))))) (test-group "iteration" (test-group "walk" (let ((keys '()) (values '())) (hashtable-walk (alist->eq-hashtable '((a . b) (c . d))) (lambda (k v) (set! keys (cons k keys)) (set! values (cons v values)))) (test-assert (lset= eq? '(a c) keys)) (test-assert (lset= eq? '(b d) values)))) (test-group "update-all" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (hashtable-update-all! table (lambda (k v) (string->symbol (string-append (symbol->string v) "x")))) (test-assert (lset= eq? '(a c) (hashtable-key-list table))) (test-assert (lset= eq? '(bx dx) (hashtable-value-list table))))) (test-group "prune" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (hashtable-prune! table (lambda (k v) (eq? k 'a))) (test-assert (not (hashtable-contains? table 'a))) (test-assert (hashtable-contains? table 'c)))) (test-group "merge" (let ((table (alist->eq-hashtable '((a . b) (c . d)))) (table2 (alist->eq-hashtable '((a . x) (e . f))))) (hashtable-merge! table table2) (test-assert (lset= eq? '(a c e) (hashtable-key-list table))) (test-assert (lset= eq? '(x d f) (hashtable-value-list table))))) (test-group "sum" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (test-assert (lset= eq? '(a b c d) (hashtable-sum table '() (lambda (k v acc) (lset-adjoin eq? acc k v))))))) (test-group "map->lset" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (test-assert (lset= equal? '((a . b) (c . d)) (hashtable-map->lset table cons))))) (test-group "find" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (let-values (((k v f?) (hashtable-find table (lambda (k v) (eq? k 'a))))) (test-assert (and f? (eq? k 'a) (eq? v 'b)))) (let-values (((k v f?) (hashtable-find table (lambda (k v) #f)))) (test-assert (not f?))))) (test-group "misc" (test-group "empty?" (test-assert (hashtable-empty? (alist->eq-hashtable '()))) (test-assert (not (hashtable-empty? (alist->eq-hashtable '((a . b))))))) (test-group "pop!" (test-error (hashtable-pop! (make-eq-hashtable))) (let ((table (alist->eq-hashtable '((a . b))))) (let-values (((k v) (hashtable-pop! table))) (test-eq 'a k) (test-eq 'b v) (test-assert (hashtable-empty? table))))) (test-group "inc!" (let ((table (alist->eq-hashtable '((a . 0))))) (hashtable-inc! table 'a) (test-eqv 1 (hashtable-ref table 'a)) (hashtable-inc! table 'a 2) (test-eqv 3 (hashtable-ref table 'a)))) (test-group "dec!" (let ((table (alist->eq-hashtable '((a . 0))))) (hashtable-dec! table 'a) (test-eqv -1 (hashtable-ref table 'a)) (hashtable-dec! table 'a 2) (test-eqv -3 (hashtable-ref table 'a))))))) (test-group "hashing" (test-assert (exact-integer? (hash-salt))) (test-assert (not (negative? (hash-salt)))) (test-assert (= (hash-salt) (hash-salt))) #; (test-assert (= (equal-hash (list "foo" 'bar 42)) (equal-hash (list "foo" 'bar 42)))) (test-assert (= (string-hash (string-copy "foo")) (string-hash (string-copy "foo")))) (test-assert (= (string-ci-hash (string-copy "foo")) (string-ci-hash (string-copy "FOO")))) (test-assert (= (symbol-hash (string->symbol "foo")) (symbol-hash (string->symbol "foo"))))) (test-end "SRFI-126") ���������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/r6rs-hashtables.sps������������������������������������0000664�0000000�0000000�00000031327�13751542066�0023631�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;-*- mode: scheme -*- (import (rnrs base) (rnrs control) (rnrs io simple) (only (srfi :1) lset= lset-adjoin) (srfi :64) (srfi :126)) (define (exact-integer? obj) (and (integer? obj) (exact? obj))) ;; INCLUDE test-suite.body.scm ;;; This doesn't test weakness, external representation, and quasiquote. (test-begin "SRFI-126") (test-group "constructors & inspection" (test-group "eq" (let ((tables (list (make-eq-hashtable) (make-eq-hashtable 10) (make-eq-hashtable #f #f) (make-hashtable #f eq?) (alist->eq-hashtable '((a . b) (c . d))) (alist->eq-hashtable 10 '((a . b) (c . d))) (alist->eq-hashtable #f #f '((a . b) (c . d)))))) (do ((tables tables (cdr tables)) (i 0 (+ i 1))) ((null? tables)) (let ((table (car tables)) (label (number->string i))) (test-assert label (hashtable? table)) (test-eq label #f (hashtable-hash-function table)) (test-eq label eq? (hashtable-equivalence-function table)) (test-eq label #f (hashtable-weakness table)) (test-assert label (hashtable-mutable? table)))))) (test-group "eqv" (let ((tables (list (make-eqv-hashtable) (make-eqv-hashtable 10) (make-eqv-hashtable #f #f) (make-hashtable #f eqv?) (alist->eqv-hashtable '((a . b) (c . d))) (alist->eqv-hashtable 10 '((a . b) (c . d))) (alist->eqv-hashtable #f #f '((a . b) (c . d)))))) (do ((tables tables (cdr tables)) (i 0 (+ i 1))) ((null? tables)) (let ((table (car tables)) (label (number->string i))) (test-assert label (hashtable? table)) (test-eq label #f (hashtable-hash-function table)) (test-eq label eqv? (hashtable-equivalence-function table)) (test-eq label #f (hashtable-weakness table)) (test-assert label (hashtable-mutable? table)))))) (test-group "equal" (let ((tables (list (make-hashtable equal-hash equal?) (make-hashtable equal-hash equal? 10) (make-hashtable equal-hash equal? #f #f) (alist->hashtable equal-hash equal? '((a . b) (c . d))) (alist->hashtable equal-hash equal? 10 '((a . b) (c . d))) (alist->hashtable equal-hash equal? #f #f '((a . b) (c . d)))))) (do ((tables tables (cdr tables)) (i 0 (+ i 1))) ((null? tables)) (let ((table (car tables)) (label (number->string i))) (test-assert label (hashtable? table)) (test-eq label equal-hash (hashtable-hash-function table)) (test-eq label equal? (hashtable-equivalence-function table)) (test-eq label #f (hashtable-weakness table)) (test-assert label (hashtable-mutable? table)))) (let ((table (make-hashtable (cons equal-hash equal-hash) equal?))) (let ((hash (hashtable-hash-function table))) (test-assert (or (eq? equal-hash hash) (and (eq? equal-hash (car hash)) (eq? equal-hash (cdr hash))))))))) (test-group "alist" (let ((tables (list (alist->eq-hashtable '((a . b) (a . c))) (alist->eqv-hashtable '((a . b) (a . c))) (alist->hashtable equal-hash equal? '((a . b) (a . c)))))) (do ((tables tables (cdr tables)) (i 0 (+ i 1))) ((null? tables)) (let ((table (car tables)) (label (number->string i))) (test-eq label 'b (hashtable-ref table 'a))))))) (test-group "procedures" (test-group "basics" (let ((table (make-eq-hashtable))) (test-group "ref" (test-error (hashtable-ref table 'a)) (test-eq 'b (hashtable-ref table 'a 'b)) (test-assert (not (hashtable-contains? table 'a))) (test-eqv 0 (hashtable-size table))) (test-group "set" (hashtable-set! table 'a 'c) (test-eq 'c (hashtable-ref table 'a)) (test-eq 'c (hashtable-ref table 'a 'b)) (test-assert (hashtable-contains? table 'a)) (test-eqv 1 (hashtable-size table))) (test-group "delete" (hashtable-delete! table 'a) (test-error (hashtable-ref table 'a)) (test-eq 'b (hashtable-ref table 'a 'b)) (test-assert (not (hashtable-contains? table 'a))) (test-eqv 0 (hashtable-size table))))) (test-group "advanced" (let ((table (make-eq-hashtable))) (test-group "lookup" (let-values (((x found?) (hashtable-lookup table 'a))) (test-assert (not found?)))) (test-group "update" (test-error (hashtable-update! table 'a (lambda (x) (+ x 1)))) (hashtable-update! table 'a (lambda (x) (+ x 1)) 0) (let-values (((x found?) (hashtable-lookup table 'a))) (test-eqv 1 x) (test-assert found?)) (hashtable-update! table 'a (lambda (x) (+ x 1))) (let-values (((x found?) (hashtable-lookup table 'a))) (test-eqv x 2) (test-assert found?)) (hashtable-update! table 'a (lambda (x) (+ x 1)) 0) (let-values (((x found?) (hashtable-lookup table 'a))) (test-eqv x 3) (test-assert found?))) (test-group "intern" (test-eqv 0 (hashtable-intern! table 'b (lambda () 0))) (test-eqv 0 (hashtable-intern! table 'b (lambda () 1)))))) (test-group "copy/clear" (let ((table (alist->hashtable equal-hash equal? '((a . b))))) (test-group "copy" (let ((table2 (hashtable-copy table))) (test-eq equal-hash (hashtable-hash-function table2)) (test-eq equal? (hashtable-equivalence-function table2)) (test-eq 'b (hashtable-ref table2 'a)) (test-error (hashtable-set! table2 'a 'c))) (let ((table2 (hashtable-copy table #f))) (test-eq equal-hash (hashtable-hash-function table2)) (test-eq equal? (hashtable-equivalence-function table2)) (test-eq 'b (hashtable-ref table2 'a)) (test-error (hashtable-set! table2 'a 'c))) (let ((table2 (hashtable-copy table #t))) (test-eq equal-hash (hashtable-hash-function table2)) (test-eq equal? (hashtable-equivalence-function table2)) (test-eq 'b (hashtable-ref table2 'a)) (hashtable-set! table2 'a 'c) (test-eq 'c (hashtable-ref table2 'a))) (let ((table2 (hashtable-copy table #f #f))) (test-eq equal-hash (hashtable-hash-function table2)) (test-eq equal? (hashtable-equivalence-function table2)) (test-eq #f (hashtable-weakness table2)))) (test-group "clear" (let ((table2 (hashtable-copy table #t))) (hashtable-clear! table2) (test-eqv 0 (hashtable-size table2))) (let ((table2 (hashtable-copy table #t))) (hashtable-clear! table2 10) (test-eqv 0 (hashtable-size table2)))) (test-group "empty-copy" (let ((table2 (hashtable-empty-copy table))) (test-eq equal-hash (hashtable-hash-function table2)) (test-eq equal? (hashtable-equivalence-function table2)) (test-eqv 0 (hashtable-size table2))) (let ((table2 (hashtable-empty-copy table 10))) (test-eq equal-hash (hashtable-hash-function table2)) (test-eq equal? (hashtable-equivalence-function table2)) (test-eqv 0 (hashtable-size table2)))))) (test-group "keys/values" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (test-assert (lset= eq? '(a c) (vector->list (hashtable-keys table)))) (test-assert (lset= eq? '(b d) (vector->list (hashtable-values table)))) (let-values (((keys values) (hashtable-entries table))) (test-assert (lset= eq? '(a c) (vector->list keys))) (test-assert (lset= eq? '(b d) (vector->list values)))) (test-assert (lset= eq? '(a c) (hashtable-key-list table))) (test-assert (lset= eq? '(b d) (hashtable-value-list table))) (let-values (((keys values) (hashtable-entry-lists table))) (test-assert (lset= eq? '(a c) keys)) (test-assert (lset= eq? '(b d) values))))) (test-group "iteration" (test-group "walk" (let ((keys '()) (values '())) (hashtable-walk (alist->eq-hashtable '((a . b) (c . d))) (lambda (k v) (set! keys (cons k keys)) (set! values (cons v values)))) (test-assert (lset= eq? '(a c) keys)) (test-assert (lset= eq? '(b d) values)))) (test-group "update-all" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (hashtable-update-all! table (lambda (k v) (string->symbol (string-append (symbol->string v) "x")))) (test-assert (lset= eq? '(a c) (hashtable-key-list table))) (test-assert (lset= eq? '(bx dx) (hashtable-value-list table))))) (test-group "prune" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (hashtable-prune! table (lambda (k v) (eq? k 'a))) (test-assert (not (hashtable-contains? table 'a))) (test-assert (hashtable-contains? table 'c)))) (test-group "merge" (let ((table (alist->eq-hashtable '((a . b) (c . d)))) (table2 (alist->eq-hashtable '((a . x) (e . f))))) (hashtable-merge! table table2) (test-assert (lset= eq? '(a c e) (hashtable-key-list table))) (test-assert (lset= eq? '(x d f) (hashtable-value-list table))))) (test-group "sum" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (test-assert (lset= eq? '(a b c d) (hashtable-sum table '() (lambda (k v acc) (lset-adjoin eq? acc k v))))))) (test-group "map->lset" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (test-assert (lset= equal? '((a . b) (c . d)) (hashtable-map->lset table cons))))) (test-group "find" (let ((table (alist->eq-hashtable '((a . b) (c . d))))) (let-values (((k v f?) (hashtable-find table (lambda (k v) (eq? k 'a))))) (test-assert (and f? (eq? k 'a) (eq? v 'b)))) (let-values (((k v f?) (hashtable-find table (lambda (k v) #f)))) (test-assert (not f?))))) (test-group "misc" (test-group "empty?" (test-assert (hashtable-empty? (alist->eq-hashtable '()))) (test-assert (not (hashtable-empty? (alist->eq-hashtable '((a . b))))))) (test-group "pop!" (test-error (hashtable-pop! (make-eq-hashtable))) (let ((table (alist->eq-hashtable '((a . b))))) (let-values (((k v) (hashtable-pop! table))) (test-eq 'a k) (test-eq 'b v) (test-assert (hashtable-empty? table))))) (test-group "inc!" (let ((table (alist->eq-hashtable '((a . 0))))) (hashtable-inc! table 'a) (test-eqv 1 (hashtable-ref table 'a)) (hashtable-inc! table 'a 2) (test-eqv 3 (hashtable-ref table 'a)))) (test-group "dec!" (let ((table (alist->eq-hashtable '((a . 0))))) (hashtable-dec! table 'a) (test-eqv -1 (hashtable-ref table 'a)) (hashtable-dec! table 'a 2) (test-eqv -3 (hashtable-ref table 'a))))))) (test-group "hashing" (test-assert (exact-integer? (hash-salt))) (test-assert (not (negative? (hash-salt)))) (test-assert (= (hash-salt) (hash-salt))) (test-assert (= (equal-hash (list "foo" 'bar 42)) (equal-hash (list "foo" 'bar 42)))) (test-assert (= (string-hash (string-copy "foo")) (string-hash (string-copy "foo")))) (test-assert (= (string-ci-hash (string-copy "foo")) (string-ci-hash (string-copy "FOO")))) (test-assert (= (symbol-hash (string->symbol "foo")) (symbol-hash (string->symbol "foo"))))) (test-end "SRFI-126") (display (string-append "\n" "NOTE: On implementations using the (r6rs hashtables) library from Larceny,\n" " 14 tests are expected to fail in relation to make-eq-hashtable and\n" " make-eqv-hashtable returning hashtables whose hash functions are\n" " exposed instead of being #f. We have no obvious way to detect this\n" " within this portable test suite, hence no XFAIL results.\n")) ;; Local Variables: ;; eval: (put (quote test-group) (quote scheme-indent-function) 1) ;; End: ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/random-bits.sps����������������������������������������0000664�0000000�0000000�00000000741�13751542066�0023034�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (except (rnrs) error) (rnrs r5rs) (srfi :23 error) (srfi private include) (srfi :27 random-bits)) (define eval 'ignore) (define interaction-environment 'ignore) (define ascii->char integer->char) (include/resolve ("srfi" "%3a27") "conftest.scm") (check-mrg32k3a) (display "passed (check-mrg32k3a)\n") �������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/rec.sps������������������������������������������������0000664�0000000�0000000�00000000426�13751542066�0021366�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2009 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (rnrs) (srfi :31 rec)) (display ((rec (F N) (if (zero? N) 1 (* N (F (- N 1))))) 10)) (newline) ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/records.sps��������������������������������������������0000664�0000000�0000000�00000001603�13751542066�0022254�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (rnrs base) ; no R6RS records (srfi :78 lightweight-testing) (srfi :9 records) #;(srfi :99 records)) (define unspec) (define-record-type T0 (make-T0) T0?) (check (T0? (make-T0)) => #T) (define-record-type T1 (make-T1) T1? (x T1-x)) (check (T1? (make-T1)) => #T) (check (T1-x (make-T1)) => unspec) (define-record-type T2 (make-T2 y x) T2? (x T2-x) (y T2-y)) (let ((o (make-T2 1 2))) (check (T2? o) => #T) (check (T2-x o) => 2) (check (T2-y o) => 1)) (define-record-type T3 (make-T3 z) T3? (x T3-x set-T3-x!) (y T3-y) (z T3-z)) (let ((o (make-T3 1))) (check (T3? o) => #T) (check (T3-x o) => unspec) (check (T3-y o) => unspec) (check (T3-z o) => 1) (set-T3-x! o 2) (check (T3-x o) => 2)) (check-report) �����������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/regexp.sps���������������������������������������������0000664�0000000�0000000�00000032103�13751542066�0022104�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs (import (rename (rnrs) (get-line read-line) (call-with-string-output-port call-with-output-string)) (srfi :78 lightweight-testing) (srfi :115 regexp)) ;;; Shims to run the tests (define (test-begin name) #f) (define-syntax test (lambda (x) (syntax-case x () ((_ x y) #'(guard (exn (else (display "Failed with exception: ") (write 'x) (newline) (write (list (and (message-condition? exn) (condition-message exn)) (and (irritants-condition? exn) (condition-irritants exn)))) (newline))) (check x => y)))))) (define (test-end) #f) ;;; From regexp-test.sld. Replaced #u8( with #vu8(. ;; Copyright (c) 2009-2015 Alex Shinn ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions ;; are met: ;; 1. Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; 2. Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in the ;; documentation and/or other materials provided with the distribution. ;; 3. The name of the author may not be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. ;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT ;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. (define (run-tests) (define (maybe-match->sexp rx str . o) (let ((res (apply regexp-matches rx str o))) (and res (regexp-match->sexp res)))) (define-syntax test-re (syntax-rules () ((test-re res rx str start end) (test res (maybe-match->sexp rx str start end))) ((test-re res rx str start) (test-re res rx str start (string-length str))) ((test-re res rx str) (test-re res rx str 0)))) (define (maybe-search->sexp rx str . o) (let ((res (apply regexp-search rx str o))) (and res (regexp-match->sexp res)))) (define-syntax test-re-search (syntax-rules () ((test-re-search res rx str start end) (test res (maybe-search->sexp rx str start end))) ((test-re-search res rx str start) (test-re-search res rx str start (string-length str))) ((test-re-search res rx str) (test-re-search res rx str 0)))) (test-begin "regexp") (test-re '("ababc" "abab") '(: ($ (* "ab")) "c") "ababc") (test-re '("ababc" "abab") '(: ($ (* "ab")) "c") "xababc" 1) (test-re-search '("y") '(: "y") "xy") (test-re-search '("ababc" "abab") '(: ($ (* "ab")) "c") "xababc") (test-re #f '(: (* any) ($ "foo" (* any)) ($ "bar" (* any))) "fooxbafba") (test-re '("fooxbarfbar" "fooxbarf" "bar") '(: (* any) ($ "foo" (* any)) ($ "bar" (* any))) "fooxbarfbar") (test-re '("abcd" "abcd") '($ (* (or "ab" "cd"))) "abcd") ;; first match is a list of ab's, second match is the last (temporary) cd (test-re '("abcdc" (("ab") ("cd")) "cd") '(: (* (*$ (or "ab" "cd"))) "c") "abcdc") (test "ab" (regexp-match-submatch (regexp-matches '(or (-> foo "ab") (-> foo "cd")) "ab") 'foo)) (test "cd" (regexp-match-submatch (regexp-matches '(or (-> foo "ab") (-> foo "cd")) "cd") 'foo)) ;; non-deterministic case from issue #229 (let* ((elapsed '(: (** 1 2 num) ":" num num (? ":" num num))) (span (rx ,elapsed "-" ,elapsed))) (test-re-search '("1:45:02-2:06:13") span " 1:45:02-2:06:13 ")) (test-re '("ababc" "abab") '(: bos ($ (* "ab")) "c") "ababc") (test-re '("ababc" "abab") '(: ($ (* "ab")) "c" eos) "ababc") (test-re '("ababc" "abab") '(: bos ($ (* "ab")) "c" eos) "ababc") (test-re #f '(: bos ($ (* "ab")) eos "c") "ababc") (test-re #f '(: ($ (* "ab")) bos "c" eos) "ababc") (test-re '("ababc" "abab") '(: bol ($ (* "ab")) "c") "ababc") (test-re '("ababc" "abab") '(: ($ (* "ab")) "c" eol) "ababc") (test-re '("ababc" "abab") '(: bol ($ (* "ab")) "c" eol) "ababc") (test-re #f '(: bol ($ (* "ab")) eol "c") "ababc") (test-re #f '(: ($ (* "ab")) bol "c" eol) "ababc") (test-re '("\nabc\n" "abc") '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline)) "\nabc\n") (test-re #f '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline)) "\n'abc\n") (test-re #f '(: (* #\newline) bol ($ (* alpha)) eol (* #\newline)) "\nabc.\n") (test-re '("ababc" "abab") '(: bow ($ (* "ab")) "c") "ababc") (test-re '("ababc" "abab") '(: ($ (* "ab")) "c" eow) "ababc") (test-re '("ababc" "abab") '(: bow ($ (* "ab")) "c" eow) "ababc") (test-re #f '(: bow ($ (* "ab")) eow "c") "ababc") (test-re #f '(: ($ (* "ab")) bow "c" eow) "ababc") (test-re '(" abc " "abc") '(: (* space) bow ($ (* alpha)) eow (* space)) " abc ") (test-re #f '(: (* space) bow ($ (* alpha)) eow (* space)) " 'abc ") (test-re #f '(: (* space) bow ($ (* alpha)) eow (* space)) " abc. ") (test-re '("abc " "abc") '(: ($ (* alpha)) (* any)) "abc ") (test-re '("abc " "") '(: ($ (*? alpha)) (* any)) "abc ") (test-re '("<em>Hello World</em>" "em>Hello World</em") '(: "<" ($ (* any)) ">" (* any)) "<em>Hello World</em>") (test-re '("<em>Hello World</em>" "em") '(: "<" ($ (*? any)) ">" (* any)) "<em>Hello World</em>") (test-re-search '("foo") '(: "foo") " foo ") (test-re-search #f '(: nwb "foo" nwb) " foo ") (test-re-search '("foo") '(: nwb "foo" nwb) "xfoox") (test-re '("beef") '(* (/"af")) "beef") (test-re '("12345beef" "beef") '(: (* digit) ($ (* (/"af")))) "12345beef") (let ((number '($ (+ digit)))) (test '("555" "867" "5309") (cdr (regexp-match->list (regexp-search `(: ,number "-" ,number "-" ,number) "555-867-5309")))) (test '("555" "5309") (cdr (regexp-match->list (regexp-search `(: ,number "-" (w/nocapture ,number) "-" ,number) "555-867-5309"))))) (test-re '("12345BeeF" "BeeF") '(: (* digit) (w/nocase ($ (* (/"af"))))) "12345BeeF") (test-re #f '(* lower) "abcD") (test-re '("abcD") '(w/nocase (* lower)) "abcD") (test-re '("σζ") '(* lower) "σζ") (test-re '("Σ") '(* upper) "Σ") (test-re '("\x01C5;") '(* title) "\x01C5;") (test-re '("σζ\x01C5;") '(w/nocase (* lower)) "σζ\x01C5;") (test-re '("кириллица") '(* alpha) "кириллица") (test-re #f '(w/ascii (* alpha)) "кириллица") (test-re '("кириллица") '(w/nocase "КИРИЛЛИЦА") "кириллица") (test-re '("１２３４５") '(* digit) "１２３４５") (test-re #f '(w/ascii (* digit)) "１２３４５") (test-re '("한") 'grapheme "한") (test-re '("글") 'grapheme "글") (test-re '("한") '(: bog grapheme eog) "한") (test-re #f '(: "ᄒ" bog grapheme eog "ᆫ") "한") (test '("123" "456" "789") (regexp-extract '(+ digit) "abc123def456ghi789")) (test '("123" "456" "789") (regexp-extract '(* digit) "abc123def456ghi789")) (test '("abc" "def" "ghi" "") (regexp-split '(+ digit) "abc123def456ghi789")) (test '("abc" "def" "ghi" "") (regexp-split '(* digit) "abc123def456ghi789")) (test '("a" "b") (regexp-split '(+ whitespace) "a b")) (test '("a" "" "b") (regexp-split '(",;") "a,,b")) (test '("a" "" "b" "") (regexp-split '(",;") "a,,b,")) (test '("") (regexp-partition '(* digit) "")) (test '("abc" "123" "def" "456" "ghi") (regexp-partition '(* digit) "abc123def456ghi")) (test '("abc" "123" "def" "456" "ghi" "789") (regexp-partition '(* digit) "abc123def456ghi789")) (test '("한" "글") (regexp-extract 'grapheme (utf8->string '#vu8(#xe1 #x84 #x92 #xe1 #x85 #xa1 #xe1 #x86 #xab #xe1 #x84 #x80 #xe1 #x85 #xb3 #xe1 #x86 #xaf)))) (test "abc def" (regexp-replace '(+ space) "abc \t\n def" " ")) (test " abc-abc" (regexp-replace '(: ($ (+ alpha)) ":" (* space)) " abc: " '(1 "-" 1))) (test " abc- abc" (regexp-replace '(: ($ (+ alpha)) ":" (* space)) " abc: " '(1 "-" pre 1))) (test "-abc \t\n d ef " (regexp-replace '(+ space) " abc \t\n d ef " "-" 0)) (test "-abc \t\n d ef " (regexp-replace '(+ space) " abc \t\n d ef " "-" 0 #f 0)) (test " abc-d ef " (regexp-replace '(+ space) " abc \t\n d ef " "-" 0 #f 1)) (test " abc \t\n d-ef " (regexp-replace '(+ space) " abc \t\n d ef " "-" 0 #f 2)) (test " abc \t\n d ef-" (regexp-replace '(+ space) " abc \t\n d ef " "-" 0 #f 3)) (test " abc \t\n d ef " (regexp-replace '(+ space) " abc \t\n d ef " "-" 0 #f 4)) (test " abc d ef " (regexp-replace-all '(+ space) " abc \t\n d ef " " ")) ;; Disabled pcre tests. #; (let () (define (subst-matches matches input subst) (define (submatch n) (regexp-match-submatch matches n)) (and matches (call-with-output-string (lambda (out) (call-with-input-string subst (lambda (in) (let lp () (let ((c (read-char in))) (cond ((not (eof-object? c)) (case c ((#\&) (display (or (submatch 0) "") out)) ((#\\) (let ((c (read-char in))) (if (char-numeric? c) (let lp ((res (list c))) (if (and (char? (peek-char in)) (char-numeric? (peek-char in))) (lp (cons (read-char in) res)) (display (or (submatch (string->number (list->string (reverse res)))) "") out))) (write-char c out)))) (else (write-char c out))) (lp))))))))))) (define (test-pcre line) (match (string-split line #\tab) ((pattern input result subst output) (let ((name (string-append pattern " " input " " result " " subst))) (cond ((equal? "c" result) (test-error name (regexp-search (pcre->sre pattern) input))) ((equal? "n" result) (test-assert name (not (regexp-search (pcre->sre pattern) input)))) (else (test name output (subst-matches (regexp-search (pcre->sre pattern) input) input subst)))))) (else (error "invalid regex test line" line)))) (test-group "pcre" (let ((in (open-input-file "tests/re-tests.txt"))) (let lp () (let ((line (read-line in))) (unless (eof-object? line) (test-pcre line) (lp))))))) (test-end)) (run-tests) �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/tables-test.ikarus.sps���������������������������������0000664�0000000�0000000�00000064611�13751542066�0024347�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;; Copyright (C) William D Clinger 2015. All Rights Reserved. ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without restriction, ;;; including without limitation the rights to use, copy, modify, merge, ;;; publish, distribute, sublicense, and/or sell copies of the Software, ;;; and to permit persons to whom the Software is furnished to do so, ;;; subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;; This is a very shallow sanity test for hash tables. ;;; ;;; Tests marked by a "FIXME: glass-box" comment test behavior of the ;;; reference implementation that is not required by the specification. (import (rnrs) (srfi :128) (srfi :125)) (define (writeln . xs) (for-each write xs) (newline)) (define (displayln . xs) (for-each display xs) (newline)) (define (exact-integer? x) (and (integer? x) (exact? x))) (define (bytevector . args) (u8-list->bytevector args)) (define (fail token . more) (displayln "Error: test failed: ") (writeln token) (if (not (null? more)) (for-each writeln more)) (newline) #f) (define (success token) ;; (displayln "Test succeded: ") ;; (writeln token) #f) ;;; FIXME: when debugging catastrophic failures, printing every expression ;;; before it's executed may help. (define-syntax test (syntax-rules () ((_ expr expected) (let () ;; (write 'expr) (newline) (let ((actual expr)) (if (equal? actual expected) (success 'expr) (fail 'expr actual expected))))))) (define-syntax test-assert (syntax-rules () ((_ expr) (or expr (fail 'expr))))) (define-syntax test-deny (syntax-rules () ((_ expr) (or (not expr) (fail 'expr))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Transition from SRFI 114 to SRFI 128. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define default-comparator (make-default-comparator)) ;;; SRFI 128 says the following definition will work, but that's ;;; an error in SRFI 128; the hash function produce non-integers. #; (define number-comparator (make-comparator real? = < (lambda (x) (exact (abs x))))) (define number-comparator (make-comparator real? = < (lambda (x) (exact (abs (round x)))))) (define string-comparator (make-comparator string? string=? string<? string-hash)) (define string-ci-comparator (make-comparator string? string-ci=? string-ci<? string-ci-hash)) (define eq-comparator (make-eq-comparator)) (define eqv-comparator (make-eqv-comparator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Transition from earlier draft of SRFI 125 to this draft. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Returns an immutable hash table. (define (hash-table-tabulate comparator n proc) (let ((ht (make-hash-table comparator))) (do ((i 0 (+ i 1))) ((= i n) (hash-table-copy ht)) (call-with-values (lambda () (proc i)) (lambda (key val) (hash-table-set! ht key val)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Constructors. (define ht-default (make-hash-table default-comparator)) (define ht-eq (make-hash-table eq-comparator 'random-argument "another")) (define ht-eqv (make-hash-table eqv-comparator)) (define ht-eq2 (make-hash-table eq?)) (define ht-eqv2 (make-hash-table eqv?)) (define ht-equal (make-hash-table default-comparator)) (define ht-string (make-hash-table string=?)) (define ht-string-ci (make-hash-table string-ci=?)) (define ht-symbol (make-hash-table symbol=?)) ; FIXME: glass-box (define ht-fixnum (make-hash-table = abs)) (define ht-default2 (hash-table default-comparator 'foo 'bar 101.3 "fever" '(x y z) '#())) (define ht-fixnum2 (hash-table-tabulate number-comparator 10 (lambda (i) (values (* i i) i)))) (define ht-string2 (hash-table-unfold (lambda (s) (= 0 (string-length s))) (lambda (s) (values s (string-length s))) (lambda (s) (substring s 0 (- (string-length s) 1))) "prefixes" string-comparator 'ignored1 'ignored2 "ignored3" '#(ignored 4 5))) (define ht-string-ci2 (alist->hash-table '(("" . 0) ("Mary" . 4) ("Paul" . 4) ("Peter" . 5)) string-ci-comparator "ignored1" 'ignored2)) (define ht-symbol2 (alist->hash-table '((mary . travers) (noel . stookey) (peter . yarrow)) eq?)) (define ht-equal2 (alist->hash-table '(((edward) . abbey) ((dashiell) . hammett) ((edward) . teach) ((mark) . twain)) equal? (comparator-hash-function default-comparator))) (define test-tables (list ht-default ht-default2 ; initial keys: foo, 101.3, (x y z) ht-eq ht-eq2 ; initially empty ht-eqv ht-eqv2 ; initially empty ht-equal ht-equal2 ; initial keys: (edward), (dashiell), (mark) ht-string ht-string2 ; initial keys: "p, "pr", ..., "prefixes" ht-string-ci ht-string-ci2 ; initial keys: "", "Mary", "Paul", "Peter" ht-symbol ht-symbol2 ; initial keys: mary, noel, peter ht-fixnum ht-fixnum2)) ; initial keys: 0, 1, 4, 9, ..., 81 ;;; Predicates (test (map hash-table? (cons '#() (cons default-comparator test-tables))) (append '(#f #f) (map (lambda (x) #t) test-tables))) (test (map hash-table-contains? test-tables '(foo 101.3 x "y" (14 15) #\newline (edward) (mark) "p" "pref" "mike" "PAUL" jane noel 0 4)) '(#f #t #f #f #f #f #f #t #f #t #f #t #f #t #f #t)) (test (map hash-table-contains? test-tables `(,(bytevector) 47.9 '#() '() foo bar 19 (henry) "p" "perp" "mike" "Noel" jane paul 0 5)) (map (lambda (x) #f) test-tables)) (test (map hash-table-empty? test-tables) '(#t #f #t #t #t #t #t #f #t #f #t #f #t #f #t #f)) (test (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2)) test-tables test-tables) (map (lambda (x) #t) test-tables)) (test (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2)) test-tables (do ((tables (reverse test-tables) (cddr tables)) (rev '() (cons (car tables) (cons (cadr tables) rev)))) ((null? tables) rev))) '(#f #f #t #t #t #t #f #f #f #f #f #f #f #f #f #f)) (test (map hash-table-mutable? test-tables) '(#t #t #t #t #t #t #t #t #t #t #t #t #t #t #t #f)) ;;; FIXME: glass-box (test (map hash-table-mutable? (map hash-table-copy test-tables)) (map (lambda (x) #f) test-tables)) (test (hash-table-mutable? (hash-table-copy ht-fixnum2 #t)) #t) ;;; Accessors. ;;; FIXME: glass-box (implementations not required to raise an exception here) (test (map (lambda (ht) (guard (exn (else 'err)) (hash-table-ref ht 'not-a-key))) test-tables) (map (lambda (ht) 'err) test-tables)) ;;; FIXME: glass-box (implementations not required to raise an exception here) (test (map (lambda (ht) (guard (exn (else 'err)) (hash-table-ref ht 'not-a-key (lambda () 'err)))) test-tables) (map (lambda (ht) 'err) test-tables)) ;;; FIXME: glass-box (implementations not required to raise an exception here) (test (map (lambda (ht) (guard (exn (else 'err)) (hash-table-ref ht 'not-a-key (lambda () 'err) values))) test-tables) (map (lambda (ht) 'err) test-tables)) (test (map (lambda (ht key) (guard (exn (else 'err)) (hash-table-ref ht key))) test-tables '(foo 101.3 x "y" (14 15) #\newline (edward) (mark) "p" "pref" "mike" "PAUL" jane noel 0 4)) '(err "fever" err err err err err twain err 4 err 4 err stookey err 2)) (test (map (lambda (ht key) (guard (exn (else 'err)) (hash-table-ref ht key (lambda () 'eh)))) test-tables '(foo 101.3 x "y" (14 15) #\newline (edward) (mark) "p" "pref" "mike" "PAUL" jane noel 0 4)) '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)) (test (map (lambda (ht key) (guard (exn (else 'err)) (hash-table-ref ht key (lambda () 'eh) list))) test-tables '(foo 101.3 x "y" (14 15) #\newline (edward) (mark) "p" "pref" "mike" "PAUL" jane noel 0 4)) '(eh ("fever") eh eh eh eh eh (twain) eh (4) eh (4) eh (stookey) eh (2))) ;;; FIXME: glass-box (implementations not required to raise an exception here) (test (map (lambda (ht) (guard (exn (else 'eh)) (hash-table-ref/default ht 'not-a-key 'eh))) test-tables) (map (lambda (ht) 'eh) test-tables)) (test (map (lambda (ht key) (guard (exn (else 'err)) (hash-table-ref/default ht key 'eh))) test-tables '(foo 101.3 x "y" (14 15) #\newline (edward) (mark) "p" "pref" "mike" "PAUL" jane noel 0 4)) '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)) (test (begin (hash-table-set! ht-fixnum) (list-sort < (hash-table-keys ht-fixnum))) '()) (test (begin (hash-table-set! ht-fixnum 121 11 144 12 169 13) (list-sort < (hash-table-keys ht-fixnum))) '(121 144 169)) (test (begin (hash-table-set! ht-fixnum 0 0 1 1 4 2 9 3 16 4 25 5 36 6 49 7 64 8 81 9) (list-sort < (hash-table-keys ht-fixnum))) '(0 1 4 9 16 25 36 49 64 81 121 144 169)) (test (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error)) '(169 144 121 0 1 4 9 16 25 36 49 64 81)) '(13 12 11 0 1 2 3 4 5 6 7 8 9)) (test (begin (hash-table-delete! ht-fixnum) (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 5 6 7 8 9)) (test (begin (hash-table-delete! ht-fixnum 1 9 25 49 81 200 121 169 81 1) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(-1 12 -1 0 -1 2 -1 4 -1 6 -1 8 -1)) (test (begin (hash-table-delete! ht-fixnum 200 100 0 81 36) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(-1 12 -1 -1 -1 2 -1 4 -1 -1 -1 8 -1)) (test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13)) (hash-table-intern! ht-fixnum 121 (lambda () 11)) (hash-table-intern! ht-fixnum 0 (lambda () 0)) (hash-table-intern! ht-fixnum 1 (lambda () 1)) (hash-table-intern! ht-fixnum 1 (lambda () 99)) (hash-table-intern! ht-fixnum 121 (lambda () 66)) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 -1 4 -1 -1 -1 8 -1)) (test (list-sort (lambda (v1 v2) (< (vector-ref v1 0) (vector-ref v2 0))) (hash-table-map->list vector ht-fixnum)) '(#(0 0) #(1 1) #(4 2) #(16 4) #(64 8) #(121 11) #(144 12) #(169 13))) (test (begin (hash-table-prune! (lambda (key val) (and (odd? key) (> val 10))) ht-fixnum) (list-sort (lambda (l1 l2) (< (car l1) (car l2))) (hash-table-map->list list ht-fixnum))) '((0 0) (1 1) (4 2) (16 4) (64 8) #;(121 11) (144 12) #;(169 13))) (test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13)) (hash-table-intern! ht-fixnum 144 (lambda () 9999)) (hash-table-intern! ht-fixnum 121 (lambda () 11)) (list-sort (lambda (l1 l2) (< (car l1) (car l2))) (hash-table-map->list list ht-fixnum))) '((0 0) (1 1) (4 2) (16 4) (64 8) (121 11) (144 12) (169 13))) (test (begin (hash-table-update! ht-fixnum 9 length (lambda () '(a b c))) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1)) (test (begin (hash-table-update! ht-fixnum 16 -) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 -4 -1 -1 -1 8 -1)) (test (begin (hash-table-update! ht-fixnum 16 - abs) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1)) (test (begin (hash-table-update!/default ht-fixnum 25 - 5) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 -5 -1 -1 8 -1)) (test (begin (hash-table-update!/default ht-fixnum 25 - 999) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1)) (test (let* ((n0 (hash-table-size ht-fixnum)) (ht (hash-table-copy ht-fixnum #t))) (call-with-values (lambda () (hash-table-pop! ht)) (lambda (key val) (list (= key (* val val)) (= (- n0 1) (hash-table-size ht)))))) '(#t #t)) (test (begin (hash-table-delete! ht-fixnum 75) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 75 81))) '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1 -1)) (let ((ht-eg (hash-table number-comparator 1 1 4 2 9 3 16 4 25 5 64 8))) (test (hash-table-delete! ht-eg) 0) (test (hash-table-delete! ht-eg 2 7 2000) 0) (test (hash-table-delete! ht-eg 1 2 4 7 64 2000) 3) (test-assert (= 3 (length (hash-table-keys ht-eg))))) (test (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81)) '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1)) (test (begin (hash-table-set! ht-fixnum 36 6) (hash-table-set! ht-fixnum 81 9) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 5 6 -1 8 9)) (test (begin (hash-table-clear! ht-eq) (hash-table-size ht-eq)) 0) ;;; The whole hash table. (test (begin (hash-table-set! ht-eq 'foo 13 'bar 14 'baz 18) (hash-table-size ht-eq)) 3) (test (let* ((ht (hash-table-empty-copy ht-eq)) (n0 (hash-table-size ht)) (ignored (hash-table-set! ht 'foo 13 'bar 14 'baz 18)) (n1 (hash-table-size ht))) (list n0 n1 (hash-table=? default-comparator ht ht-eq))) '(0 3 #t)) (test (begin (hash-table-clear! ht-eq) (hash-table-size ht-eq)) 0) (test (hash-table-find (lambda (key val) (if (= 144 key (* val val)) (list key val) #f)) ht-fixnum (lambda () 99)) '(144 12)) (test (hash-table-find (lambda (key val) (if (= 144 key val) (list key val) #f)) ht-fixnum (lambda () 99)) 99) (test (hash-table-count <= ht-fixnum) 2) ;;; Mapping and folding. (test (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196)) '(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1)) (test (let ((ht (hash-table-map (lambda (val) (* val val)) eqv-comparator ht-fixnum))) (map (lambda (i) (hash-table-ref/default ht i -1)) '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))) '(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)) (test (let ((keys (make-vector 15 -1)) (vals (make-vector 15 -1))) (hash-table-for-each (lambda (key val) (vector-set! keys val key) (vector-set! vals val val)) ht-fixnum) (list keys vals)) '(#(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1) #(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1))) (test (begin (hash-table-map! (lambda (key val) (if (<= 10 key) (- val) val)) ht-fixnum) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))) '(0 1 2 3 -4 -5 -6 -1 -8 -9 -1 -11 -12 -13 -1)) (test (hash-table-fold (lambda (key val acc) (+ val acc)) 0 ht-string-ci2) 13) (test (list-sort < (hash-table-fold (lambda (key val acc) (cons key acc)) '() ht-fixnum)) '(0 1 4 9 16 25 36 64 81 121 144 169)) ;;; Copying and conversion. (test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum)) #t) (test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #f)) #t) (test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #t)) #t) (test (hash-table-mutable? (hash-table-copy ht-fixnum)) #f) (test (hash-table-mutable? (hash-table-copy ht-fixnum #f)) #f) (test (hash-table-mutable? (hash-table-copy ht-fixnum #t)) #t) (test (hash-table->alist ht-eq) '()) (test (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht-fixnum)) '((0 . 0) (1 . 1) (4 . 2) (9 . 3) (16 . -4) (25 . -5) (36 . -6) (64 . -8) (81 . -9) (121 . -11) (144 . -12) (169 . -13))) ;;; Hash tables as sets. (test (begin (hash-table-union! ht-fixnum ht-fixnum2) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht-fixnum))) '((0 . 0) (1 . 1) (4 . 2) (9 . 3) (16 . -4) (25 . -5) (36 . -6) (49 . 7) (64 . -8) (81 . -9) (121 . -11) (144 . -12) (169 . -13))) (test (let ((ht (hash-table-copy ht-fixnum2 #t))) (hash-table-union! ht ht-fixnum) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht))) '((0 . 0) (1 . 1) (4 . 2) (9 . 3) (16 . 4) (25 . 5) (36 . 6) (49 . 7) (64 . 8) (81 . 9) (121 . -11) (144 . -12) (169 . -13))) (test (begin (hash-table-union! ht-eqv2 ht-fixnum) (hash-table=? default-comparator ht-eqv2 ht-fixnum)) #t) (test (begin (hash-table-intersection! ht-eqv2 ht-fixnum) (hash-table=? default-comparator ht-eqv2 ht-fixnum)) #t) (test (begin (hash-table-intersection! ht-eqv2 ht-eqv) (hash-table-empty? ht-eqv2)) #t) (test (begin (hash-table-intersection! ht-fixnum ht-fixnum2) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht-fixnum))) '((0 . 0) (1 . 1) (4 . 2) (9 . 3) (16 . -4) (25 . -5) (36 . -6) (49 . 7) (64 . -8) (81 . -9))) (test (begin (hash-table-intersection! ht-fixnum (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10)) number-comparator)) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht-fixnum))) '((4 . 2) (25 . -5))) (test (let ((ht (hash-table-copy ht-fixnum2 #t))) (hash-table-difference! ht (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10)) number-comparator)) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht))) '((0 . 0) (1 . 1) (9 . 3) (16 . 4) (36 . 6) (49 . 7) (64 . 8) (81 . 9))) (test (let ((ht (hash-table-copy ht-fixnum2 #t))) (hash-table-xor! ht (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10)) number-comparator)) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht))) '((-1 . -1) (0 . 0) (1 . 1) (9 . 3) (16 . 4) (36 . 6) (49 . 7) (64 . 8) (81 . 9) (100 . 10))) (test (guard (exn (else 'key-not-found)) (hash-table-ref ht-default "this key won't be present")) 'key-not-found) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Desultory tests of deprecated procedures and usages. ;;; Deprecated usage of make-hash-table and alist->hash-table ;;; has already been tested above. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test (let* ((x (list 1 2 3)) (y (cons 1 (cdr x))) (h1 (deprecated:hash x)) (h2 (deprecated:hash y))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x "abcd") (y (string-append "ab" "cd")) (h1 (deprecated:string-hash x)) (h2 (deprecated:string-hash y))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x "Hello There!") (y "hello THERE!") (h1 (deprecated:string-ci-hash x)) (h2 (deprecated:string-ci-hash y))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x (vector 'a "bcD" #\c '(d 2.718) -42 (bytevector) '#() (bytevector 9 20))) (y x) (h1 (deprecated:hash-by-identity x)) (h2 (deprecated:hash-by-identity y))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x (list 1 2 3)) (y (cons 1 (cdr x))) (h1 (deprecated:hash x 60)) (h2 (deprecated:hash y 60))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x "abcd") (y (string-append "ab" "cd")) (h1 (deprecated:string-hash x 97)) (h2 (deprecated:string-hash y 97))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x "Hello There!") (y "hello THERE!") (h1 (deprecated:string-ci-hash x 101)) (h2 (deprecated:string-ci-hash y 101))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x (vector 'a "bcD" #\c '(d 2.718) -42 (bytevector) '#() (bytevector 19 20))) (y x) (h1 (deprecated:hash-by-identity x 102)) (h2 (deprecated:hash-by-identity y 102))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let ((f (deprecated:hash-table-equivalence-function ht-fixnum))) (if (procedure? f) (f 34 34) #t)) #t) (test (let ((f (deprecated:hash-table-hash-function ht-fixnum))) (if (procedure? f) (= (f 34) (f 34)) #t)) #t) (test (map (lambda (key) (deprecated:hash-table-exists? ht-fixnum2 key)) '(0 1 2 3 4 5 6 7 8 9 10)) '(#t #t #f #f #t #f #f #f #f #t #f)) (test (let ((n 0)) (deprecated:hash-table-walk ht-fixnum2 (lambda (key val) (set! n (+ n key)))) n) (apply + (map (lambda (x) (* x x)) '(0 1 2 3 4 5 6 7 8 9)))) (test (list-sort < (hash-table-fold ht-fixnum2 (lambda (key val acc) (cons key acc)) '())) '(0 1 4 9 16 25 36 49 64 81)) (test (let ((ht (hash-table-copy ht-fixnum2 #t)) (ht2 (hash-table number-comparator .25 .5 64 9999 81 9998 121 -11 144 -12))) (deprecated:hash-table-merge! ht ht2) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht))) '((0 . 0) (.25 . .5) (1 . 1) (4 . 2) (9 . 3) (16 . 4) (25 . 5) (36 . 6) (49 . 7) (64 . 8) (81 . 9) (121 . -11) (144 . -12))) (displayln "Done.") ;; eof �����������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/tables-test.sps����������������������������������������0000664�0000000�0000000�00000064537�13751542066�0023061�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������;;; Copyright (C) William D Clinger 2015. All Rights Reserved. ;;; ;;; Permission is hereby granted, free of charge, to any person ;;; obtaining a copy of this software and associated documentation ;;; files (the "Software"), to deal in the Software without restriction, ;;; including without limitation the rights to use, copy, modify, merge, ;;; publish, distribute, sublicense, and/or sell copies of the Software, ;;; and to permit persons to whom the Software is furnished to do so, ;;; subject to the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;; This is a very shallow sanity test for hash tables. ;;; ;;; Tests marked by a "FIXME: glass-box" comment test behavior of the ;;; reference implementation that is not required by the specification. (import (rnrs) (srfi :128) (srfi :125)) (define (writeln . xs) (for-each write xs) (newline)) (define (displayln . xs) (for-each display xs) (newline)) (define (exact-integer? x) (and (integer? x) (exact? x))) (define (bytevector . args) (u8-list->bytevector args)) (define (fail token . more) (displayln "Error: test failed: ") (writeln token) (if (not (null? more)) (for-each writeln more)) (newline) #f) (define (success token) ;; (displayln "Test succeded: ") ;; (writeln token) #f) ;;; FIXME: when debugging catastrophic failures, printing every expression ;;; before it's executed may help. (define-syntax test (syntax-rules () ((_ expr expected) (let () ;; (write 'expr) (newline) (let ((actual expr)) (if (equal? actual expected) (success 'expr) (fail 'expr actual expected))))))) (define-syntax test-assert (syntax-rules () ((_ expr) (or expr (fail 'expr))))) (define-syntax test-deny (syntax-rules () ((_ expr) (or (not expr) (fail 'expr))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Transition from SRFI 114 to SRFI 128. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define default-comparator (make-default-comparator)) ;;; SRFI 128 says the following definition will work, but that's ;;; an error in SRFI 128; the hash function produce non-integers. #; (define number-comparator (make-comparator real? = < (lambda (x) (exact (abs x))))) (define number-comparator (make-comparator real? = < (lambda (x) (exact (abs (round x)))))) (define string-comparator (make-comparator string? string=? string<? string-hash)) (define string-ci-comparator (make-comparator string? string-ci=? string-ci<? string-ci-hash)) (define eq-comparator (make-eq-comparator)) (define eqv-comparator (make-eqv-comparator)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Transition from earlier draft of SRFI 125 to this draft. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Returns an immutable hash table. (define (hash-table-tabulate comparator n proc) (let ((ht (make-hash-table comparator))) (do ((i 0 (+ i 1))) ((= i n) (hash-table-copy ht)) (call-with-values (lambda () (proc i)) (lambda (key val) (hash-table-set! ht key val)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Constructors. (define ht-default (make-hash-table default-comparator)) (define ht-eq (make-hash-table eq-comparator 'random-argument "another")) (define ht-eqv (make-hash-table eqv-comparator)) (define ht-eq2 (make-hash-table eq?)) (define ht-eqv2 (make-hash-table eqv?)) (define ht-equal (make-hash-table equal?)) (define ht-string (make-hash-table string=?)) (define ht-string-ci (make-hash-table string-ci=?)) (define ht-symbol (make-hash-table symbol=?)) ; FIXME: glass-box (define ht-fixnum (make-hash-table = abs)) (define ht-default2 (hash-table default-comparator 'foo 'bar 101.3 "fever" '(x y z) '#())) (define ht-fixnum2 (hash-table-tabulate number-comparator 10 (lambda (i) (values (* i i) i)))) (define ht-string2 (hash-table-unfold (lambda (s) (= 0 (string-length s))) (lambda (s) (values s (string-length s))) (lambda (s) (substring s 0 (- (string-length s) 1))) "prefixes" string-comparator 'ignored1 'ignored2 "ignored3" '#(ignored 4 5))) (define ht-string-ci2 (alist->hash-table '(("" . 0) ("Mary" . 4) ("Paul" . 4) ("Peter" . 5)) string-ci-comparator "ignored1" 'ignored2)) (define ht-symbol2 (alist->hash-table '((mary . travers) (noel . stookey) (peter . yarrow)) eq?)) (define ht-equal2 (alist->hash-table '(((edward) . abbey) ((dashiell) . hammett) ((edward) . teach) ((mark) . twain)) equal? (comparator-hash-function default-comparator))) (define test-tables (list ht-default ht-default2 ; initial keys: foo, 101.3, (x y z) ht-eq ht-eq2 ; initially empty ht-eqv ht-eqv2 ; initially empty ht-equal ht-equal2 ; initial keys: (edward), (dashiell), (mark) ht-string ht-string2 ; initial keys: "p, "pr", ..., "prefixes" ht-string-ci ht-string-ci2 ; initial keys: "", "Mary", "Paul", "Peter" ht-symbol ht-symbol2 ; initial keys: mary, noel, peter ht-fixnum ht-fixnum2)) ; initial keys: 0, 1, 4, 9, ..., 81 ;;; Predicates (test (map hash-table? (cons '#() (cons default-comparator test-tables))) (append '(#f #f) (map (lambda (x) #t) test-tables))) (test (map hash-table-contains? test-tables '(foo 101.3 x "y" (14 15) #\newline (edward) (mark) "p" "pref" "mike" "PAUL" jane noel 0 4)) '(#f #t #f #f #f #f #f #t #f #t #f #t #f #t #f #t)) (test (map hash-table-contains? test-tables `(,(bytevector) 47.9 '#() '() foo bar 19 (henry) "p" "perp" "mike" "Noel" jane paul 0 5)) (map (lambda (x) #f) test-tables)) (test (map hash-table-empty? test-tables) '(#t #f #t #t #t #t #t #f #t #f #t #f #t #f #t #f)) (test (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2)) test-tables test-tables) (map (lambda (x) #t) test-tables)) (test (map (lambda (ht1 ht2) (hash-table=? default-comparator ht1 ht2)) test-tables (do ((tables (reverse test-tables) (cddr tables)) (rev '() (cons (car tables) (cons (cadr tables) rev)))) ((null? tables) rev))) '(#f #f #t #t #t #t #f #f #f #f #f #f #f #f #f #f)) (test (map hash-table-mutable? test-tables) '(#t #f #t #t #t #t #t #t #t #t #t #t #t #t #t #f)) ;;; FIXME: glass-box (test (map hash-table-mutable? (map hash-table-copy test-tables)) (map (lambda (x) #f) test-tables)) (test (hash-table-mutable? (hash-table-copy ht-fixnum2 #t)) #t) ;;; Accessors. ;;; FIXME: glass-box (implementations not required to raise an exception here) (test (map (lambda (ht) (guard (exn (else 'err)) (hash-table-ref ht 'not-a-key))) test-tables) (map (lambda (ht) 'err) test-tables)) ;;; FIXME: glass-box (implementations not required to raise an exception here) (test (map (lambda (ht) (guard (exn (else 'err)) (hash-table-ref ht 'not-a-key (lambda () 'err)))) test-tables) (map (lambda (ht) 'err) test-tables)) ;;; FIXME: glass-box (implementations not required to raise an exception here) (test (map (lambda (ht) (guard (exn (else 'err)) (hash-table-ref ht 'not-a-key (lambda () 'err) values))) test-tables) (map (lambda (ht) 'err) test-tables)) (test (map (lambda (ht key) (guard (exn (else 'err)) (hash-table-ref ht key))) test-tables '(foo 101.3 x "y" (14 15) #\newline (edward) (mark) "p" "pref" "mike" "PAUL" jane noel 0 4)) '(err "fever" err err err err err twain err 4 err 4 err stookey err 2)) (test (map (lambda (ht key) (guard (exn (else 'err)) (hash-table-ref ht key (lambda () 'eh)))) test-tables '(foo 101.3 x "y" (14 15) #\newline (edward) (mark) "p" "pref" "mike" "PAUL" jane noel 0 4)) '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)) (test (map (lambda (ht key) (guard (exn (else 'err)) (hash-table-ref ht key (lambda () 'eh) list))) test-tables '(foo 101.3 x "y" (14 15) #\newline (edward) (mark) "p" "pref" "mike" "PAUL" jane noel 0 4)) '(eh ("fever") eh eh eh eh eh (twain) eh (4) eh (4) eh (stookey) eh (2))) ;;; FIXME: glass-box (implementations not required to raise an exception here) (test (map (lambda (ht) (guard (exn (else 'eh)) (hash-table-ref/default ht 'not-a-key 'eh))) test-tables) (map (lambda (ht) 'eh) test-tables)) (test (map (lambda (ht key) (guard (exn (else 'err)) (hash-table-ref/default ht key 'eh))) test-tables '(foo 101.3 x "y" (14 15) #\newline (edward) (mark) "p" "pref" "mike" "PAUL" jane noel 0 4)) '(eh "fever" eh eh eh eh eh twain eh 4 eh 4 eh stookey eh 2)) (test (begin (hash-table-set! ht-fixnum) (list-sort < (hash-table-keys ht-fixnum))) '()) (test (begin (hash-table-set! ht-fixnum 121 11 144 12 169 13) (list-sort < (hash-table-keys ht-fixnum))) '(121 144 169)) (test (begin (hash-table-set! ht-fixnum 0 0 1 1 4 2 9 3 16 4 25 5 36 6 49 7 64 8 81 9) (list-sort < (hash-table-keys ht-fixnum))) '(0 1 4 9 16 25 36 49 64 81 121 144 169)) (test (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error)) '(169 144 121 0 1 4 9 16 25 36 49 64 81)) '(13 12 11 0 1 2 3 4 5 6 7 8 9)) (test (begin (hash-table-delete! ht-fixnum) (map (lambda (i) (hash-table-ref/default ht-fixnum i 'error)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 5 6 7 8 9)) (test (begin (hash-table-delete! ht-fixnum 1 9 25 49 81 200 121 169 81 1) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(-1 12 -1 0 -1 2 -1 4 -1 6 -1 8 -1)) (test (begin (hash-table-delete! ht-fixnum 200 100 0 81 36) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(-1 12 -1 -1 -1 2 -1 4 -1 -1 -1 8 -1)) (test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13)) (hash-table-intern! ht-fixnum 121 (lambda () 11)) (hash-table-intern! ht-fixnum 0 (lambda () 0)) (hash-table-intern! ht-fixnum 1 (lambda () 1)) (hash-table-intern! ht-fixnum 1 (lambda () 99)) (hash-table-intern! ht-fixnum 121 (lambda () 66)) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 -1 4 -1 -1 -1 8 -1)) (test (list-sort (lambda (v1 v2) (< (vector-ref v1 0) (vector-ref v2 0))) (hash-table-map->list vector ht-fixnum)) '(#(0 0) #(1 1) #(4 2) #(16 4) #(64 8) #(121 11) #(144 12) #(169 13))) (test (begin (hash-table-prune! (lambda (key val) (and (odd? key) (> val 10))) ht-fixnum) (list-sort (lambda (l1 l2) (< (car l1) (car l2))) (hash-table-map->list list ht-fixnum))) '((0 0) (1 1) (4 2) (16 4) (64 8) #;(121 11) (144 12) #;(169 13))) (test (begin (hash-table-intern! ht-fixnum 169 (lambda () 13)) (hash-table-intern! ht-fixnum 144 (lambda () 9999)) (hash-table-intern! ht-fixnum 121 (lambda () 11)) (list-sort (lambda (l1 l2) (< (car l1) (car l2))) (hash-table-map->list list ht-fixnum))) '((0 0) (1 1) (4 2) (16 4) (64 8) (121 11) (144 12) (169 13))) (test (begin (hash-table-update! ht-fixnum 9 length (lambda () '(a b c))) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1)) (test (begin (hash-table-update! ht-fixnum 16 -) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 -4 -1 -1 -1 8 -1)) (test (begin (hash-table-update! ht-fixnum 16 - abs) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 -1 -1 -1 8 -1)) (test (begin (hash-table-update!/default ht-fixnum 25 - 5) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 -5 -1 -1 8 -1)) (test (begin (hash-table-update!/default ht-fixnum 25 - 999) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1)) (test (let* ((n0 (hash-table-size ht-fixnum)) (ht (hash-table-copy ht-fixnum #t))) (call-with-values (lambda () (hash-table-pop! ht)) (lambda (key val) (list (= key (* val val)) (= (- n0 1) (hash-table-size ht)))))) '(#t #t)) (test (begin (hash-table-delete! ht-fixnum 75) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 75 81))) '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1 -1)) #;(let ((ht-eg (hash-table number-comparator 1 1 4 2 9 3 16 4 25 5 64 8))) (test (hash-table-delete! ht-eg) 0) (test (hash-table-delete! ht-eg 2 7 2000) 0) (test (hash-table-delete! ht-eg 1 2 4 7 64 2000) 3) (test-assert (= 3 (length (hash-table-keys ht-eg))))) (test (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81)) '(13 12 11 0 1 2 3 4 5 -1 -1 8 -1)) (test (begin (hash-table-set! ht-fixnum 36 6) (hash-table-set! ht-fixnum 81 9) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(169 144 121 0 1 4 9 16 25 36 49 64 81))) '(13 12 11 0 1 2 3 4 5 6 -1 8 9)) (test (begin (hash-table-clear! ht-eq) (hash-table-size ht-eq)) 0) ;;; The whole hash table. (test (begin (hash-table-set! ht-eq 'foo 13 'bar 14 'baz 18) (hash-table-size ht-eq)) 3) (test (let* ((ht (hash-table-empty-copy ht-eq)) (n0 (hash-table-size ht)) (ignored (hash-table-set! ht 'foo 13 'bar 14 'baz 18)) (n1 (hash-table-size ht))) (list n0 n1 (hash-table=? default-comparator ht ht-eq))) '(0 3 #t)) (test (begin (hash-table-clear! ht-eq) (hash-table-size ht-eq)) 0) (test (hash-table-find (lambda (key val) (if (= 144 key (* val val)) (list key val) #f)) ht-fixnum (lambda () 99)) '(144 12)) (test (hash-table-find (lambda (key val) (if (= 144 key val) (list key val) #f)) ht-fixnum (lambda () 99)) 99) (test (hash-table-count <= ht-fixnum) 2) ;;; Mapping and folding. (test (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196)) '(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1)) (test (let ((ht (hash-table-map (lambda (val) (* val val)) eqv-comparator ht-fixnum))) (map (lambda (i) (hash-table-ref/default ht i -1)) '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))) '(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1)) (test (let ((keys (make-vector 15 -1)) (vals (make-vector 15 -1))) (hash-table-for-each (lambda (key val) (vector-set! keys val key) (vector-set! vals val val)) ht-fixnum) (list keys vals)) '(#(0 1 4 9 16 25 36 -1 64 81 -1 121 144 169 -1) #(0 1 2 3 4 5 6 -1 8 9 -1 11 12 13 -1))) (test (begin (hash-table-map! (lambda (key val) (if (<= 10 key) (- val) val)) ht-fixnum) (map (lambda (i) (hash-table-ref/default ht-fixnum i -1)) '(0 1 4 9 16 25 36 49 64 81 100 121 144 169 196))) '(0 1 2 3 -4 -5 -6 -1 -8 -9 -1 -11 -12 -13 -1)) (test (hash-table-fold (lambda (key val acc) (+ val acc)) 0 ht-string-ci2) 13) (test (list-sort < (hash-table-fold (lambda (key val acc) (cons key acc)) '() ht-fixnum)) '(0 1 4 9 16 25 36 64 81 121 144 169)) ;;; Copying and conversion. (test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum)) #t) (test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #f)) #t) (test (hash-table=? number-comparator ht-fixnum (hash-table-copy ht-fixnum #t)) #t) (test (hash-table-mutable? (hash-table-copy ht-fixnum)) #f) (test (hash-table-mutable? (hash-table-copy ht-fixnum #f)) #f) (test (hash-table-mutable? (hash-table-copy ht-fixnum #t)) #t) (test (hash-table->alist ht-eq) '()) (test (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht-fixnum)) '((0 . 0) (1 . 1) (4 . 2) (9 . 3) (16 . -4) (25 . -5) (36 . -6) (64 . -8) (81 . -9) (121 . -11) (144 . -12) (169 . -13))) ;;; Hash tables as sets. (test (begin (hash-table-union! ht-fixnum ht-fixnum2) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht-fixnum))) '((0 . 0) (1 . 1) (4 . 2) (9 . 3) (16 . -4) (25 . -5) (36 . -6) (49 . 7) (64 . -8) (81 . -9) (121 . -11) (144 . -12) (169 . -13))) (test (let ((ht (hash-table-copy ht-fixnum2 #t))) (hash-table-union! ht ht-fixnum) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht))) '((0 . 0) (1 . 1) (4 . 2) (9 . 3) (16 . 4) (25 . 5) (36 . 6) (49 . 7) (64 . 8) (81 . 9) (121 . -11) (144 . -12) (169 . -13))) (test (begin (hash-table-union! ht-eqv2 ht-fixnum) (hash-table=? default-comparator ht-eqv2 ht-fixnum)) #f) (test (begin (hash-table-intersection! ht-eqv2 ht-fixnum) (hash-table=? default-comparator ht-eqv2 ht-fixnum)) #f) (test (begin (hash-table-intersection! ht-eqv2 ht-eqv) (hash-table-empty? ht-eqv2)) #t) (test (begin (hash-table-intersection! ht-fixnum ht-fixnum2) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht-fixnum))) '((0 . 0) (1 . 1) (4 . 2) (9 . 3) (16 . -4) (25 . -5) (36 . -6) (49 . 7) (64 . -8) (81 . -9))) (test (begin (hash-table-intersection! ht-fixnum (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10)) number-comparator)) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht-fixnum))) '((4 . 2) (25 . -5))) (test (let ((ht (hash-table-copy ht-fixnum2 #t))) (hash-table-difference! ht (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10)) number-comparator)) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht))) '((0 . 0) (1 . 1) (9 . 3) (16 . 4) (36 . 6) (49 . 7) (64 . 8) (81 . 9))) (test (let ((ht (hash-table-copy ht-fixnum2 #t))) (hash-table-xor! ht (alist->hash-table '((-1 . -1) (4 . 202) (25 . 205) (100 . 10)) number-comparator)) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht))) '((-1 . -1) (0 . 0) (1 . 1) (9 . 3) (16 . 4) (36 . 6) (49 . 7) (64 . 8) (81 . 9) (100 . 10))) (test (guard (exn (else 'key-not-found)) (hash-table-ref ht-default "this key won't be present")) 'key-not-found) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Desultory tests of deprecated procedures and usages. ;;; Deprecated usage of make-hash-table and alist->hash-table ;;; has already been tested above. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (test (let* ((x (list 1 2 3)) (y (cons 1 (cdr x))) (h1 (deprecated:hash x)) (h2 (deprecated:hash y))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x "abcd") (y (string-append "ab" "cd")) (h1 (deprecated:string-hash x)) (h2 (deprecated:string-hash y))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x "Hello There!") (y "hello THERE!") (h1 (deprecated:string-ci-hash x)) (h2 (deprecated:string-ci-hash y))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x (vector 'a "bcD" #\c '(d 2.718) -42 (bytevector) '#() (bytevector 9 20))) (y x) (h1 (deprecated:hash-by-identity x)) (h2 (deprecated:hash-by-identity y))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x (list 1 2 3)) (y (cons 1 (cdr x))) (h1 (deprecated:hash x 60)) (h2 (deprecated:hash y 60))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x "abcd") (y (string-append "ab" "cd")) (h1 (deprecated:string-hash x 97)) (h2 (deprecated:string-hash y 97))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x "Hello There!") (y "hello THERE!") (h1 (deprecated:string-ci-hash x 101)) (h2 (deprecated:string-ci-hash y 101))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let* ((x (vector 'a "bcD" #\c '(d 2.718) -42 (bytevector) '#() (bytevector 19 20))) (y x) (h1 (deprecated:hash-by-identity x 102)) (h2 (deprecated:hash-by-identity y 102))) (list (exact-integer? h1) (exact-integer? h2) (= h1 h2))) '(#t #t #t)) (test (let ((f (deprecated:hash-table-equivalence-function ht-fixnum))) (if (procedure? f) (f 34 34) #t)) #t) (test (let ((f (deprecated:hash-table-hash-function ht-fixnum))) (if (procedure? f) (= (f 34) (f 34)) #t)) #t) (test (map (lambda (key) (deprecated:hash-table-exists? ht-fixnum2 key)) '(0 1 2 3 4 5 6 7 8 9 10)) '(#t #t #f #f #t #f #f #f #f #t #f)) (test (let ((n 0)) (deprecated:hash-table-walk ht-fixnum2 (lambda (key val) (set! n (+ n key)))) n) (apply + (map (lambda (x) (* x x)) '(0 1 2 3 4 5 6 7 8 9)))) (test (list-sort < (hash-table-fold ht-fixnum2 (lambda (key val acc) (cons key acc)) '())) '(0 1 4 9 16 25 36 49 64 81)) (test (let ((ht (hash-table-copy ht-fixnum2 #t)) (ht2 (hash-table number-comparator .25 .5 64 9999 81 9998 121 -11 144 -12))) (deprecated:hash-table-merge! ht ht2) (list-sort (lambda (x y) (< (car x) (car y))) (hash-table->alist ht))) '((0 . 0) (.25 . .5) (1 . 1) (4 . 2) (9 . 3) (16 . 4) (25 . 5) (36 . 6) (49 . 7) (64 . 8) (81 . 9) (121 . -11) (144 . -12))) (displayln "Done.") ;; eof �����������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/test_all.sh��������������������������������������������0000775�0000000�0000000�00000002043�13751542066�0022231�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#! /bin/sh # Helper script to execute SRFI test programs. # # Written by Akce 2020. # SPDX-License-Identifier: Unlicense if [ -z "$1" ]; then echo "use: $0 <path-to-libdir>" echo "" echo "Note that <path-to-libdir> must be the containing directory of the installed srfi libs to test." echo "eg," echo " $ $0 /tmp/chezlibs" exit 1 fi set -o errexit set -o xtrace # Set libdirs to library under test only. export CHEZSCHEMELIBDIRS="$1" SCHEME=scheme-script tests=' testing.sps and-let%2a.sps char-sets.sps compare-procedures.sps cut.sps eager-comprehensions.sps intermediate-format-strings.sps let.sps lightweight-testing.sps list-queues.sps lists.sps multi-dimensional-arrays--arlib.sps os-environment-variables.sps r6rs-hashtables.sps random-bits.sps rec.sps records.sps regexp.sps tables-test.sps vectors.sps bitwise-operations.sps boxes.sps ' fails=' ascii.sps multi-dimensional-arrays.sps time.sps ' # Have to test this one some other way as it requires manual intervention. #lazy.sps # Execute tests. for t in $tests; do $SCHEME $t done ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/testing.sps��������������������������������������������0000664�0000000�0000000�00000000513�13751542066�0022267�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (except (rnrs base) error) (rnrs lists) (srfi :23 error) (srfi private include) (srfi :64 testing)) (include/resolve ("srfi" "%3a64") "srfi-64-test.scm") �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/time.sps�����������������������������������������������0000664�0000000�0000000�00000002311�13751542066�0021546�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named ;; LICENSE from the original collection this file is distributed with. (import (rnrs) (rnrs mutable-pairs) (srfi :48 intermediate-format-strings) (srfi private include) (srfi :19 time)) (include/resolve ("srfi" "%3a19") "srfi-19-test-suite.scm") (define (printf fmt-str . args) (display (apply format fmt-str args))) (define (date->string/all-formats) ;; NOTE: ~x and ~X aren't doing what the SRFI 19 document says they do. ;; I guess that's a bug in the reference implementation. (define fs '("~~" "~a" "~A" "~b" "~B" "~c" "~d" "~D" "~e" "~f" "~h" "~H" "~I" "~j" "~k" "~l" "~m" "~M" "~n" "~N" "~p" "~r" "~s" "~S" "~t" "~T" "~U" "~V" "~w" "~W" "~x" "~X" "~y" "~Y" "~z" "~Z" "~1" "~2" "~3" "~4" "~5")) (define cd (current-date)) (display "\n;;; Running date->string format exercise\n") (printf "(current-date)\n=>\n~s\n" cd) (for-each (lambda (f) (printf "\n--- Format: ~a ----------------------------------------\n" f) (display (date->string cd f)) (newline)) fs)) ;;TODO #;(define (string->date/all-formats) ) (date->string/all-formats) #;(string->date/all-formats) �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������chez-srfi-0.0+git20201107.bac6f29+dfsg/tests/vectors.sps��������������������������������������������0000664�0000000�0000000�00000033667�13751542066�0022317�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#!r6rs ; Test suite for SRFI 43 ; ; $Id: srfi-43-test.sps 6152 2009-03-19 22:30:05Z will $ (import (except (rnrs base) vector-fill! vector->list list->vector vector-map vector-for-each) (rnrs lists) (rnrs io simple) (srfi :6 basic-string-ports) (srfi :43 vectors)) (define (writeln . xs) (for-each display xs) (newline)) (define (fail token . more) (writeln "Error: test failed: " token) #f) (or (vector? (make-vector 0)) (fail 'make-vector:0)) (or (= 10 (vector-length (make-vector 10))) (fail 'vector-length:basic)) (or (= 97 (vector-ref (make-vector 500 97) 499)) (fail 'vector-ref:basic)) (or (equal? (vector) '#()) (fail 'vector:0)) (or (equal? (vector 'a 'b 97) '#(a b 97)) (fail 'vector)) (or (equal? (vector-unfold (lambda (i x) (values x (- x 1))) 10 0) '#(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)) ; but SRFI 43 says -8 -8 at end (fail 'vector-unfold:1)) (or (equal? (vector-unfold values 10) '#(0 1 2 3 4 5 6 7 8 9)) (fail 'vector-unfold:2)) (or (let ((vector '#(a b 97))) (equal? (vector-unfold (lambda (i) (vector-ref vector i)) (vector-length vector)) vector)) (fail 'vector-unfold:3)) (or (equal? (vector-unfold-right (lambda (i x) (values x (+ x 1))) 8 0) '#(7 6 5 4 3 2 1 0)) (fail 'vector-unfold-right:1)) (or (let ((vector '#(3 1 4 5 9))) (equal? (vector-unfold-right (lambda (i x) (values (vector-ref vector x) (+ x 1))) (vector-length vector) 0) '#(9 5 4 1 3))) (fail 'vector-unfold-right:2)) (or (equal? (vector-copy '#(a b c d e f g h i)) '#(a b c d e f g h i)) (fail 'vector-copy:1)) (or (equal? (vector-copy '#(a b c d e f g h i) 6) '#(g h i)) (fail 'vector-copy:2)) (or (equal? (vector-copy '#(a b c d e f g h i) 3 6) '#(d e f)) (fail 'vector-copy:3)) (or (equal? (vector-copy '#(a b c d e f g h i) 6 12 'x) '#(g h i x x x)) (fail 'vector-copy:4)) (or (equal? (vector-reverse-copy '#(5 4 3 2 1 0) 1 5) '#(1 2 3 4)) (fail 'vector-reverse-copy)) (or (equal? (vector-append '#(x) '#(y)) '#(x y)) (fail 'vector-append:1)) (or (equal? (vector-append '#(a) '#(b c d)) '#(a b c d)) (fail 'vector-append:2)) (or (equal? (vector-append '#(a #(b)) '#(#(c))) '#(a #(b) #(c))) (fail 'vector-append:3)) (or (equal? (vector-concatenate '(#(a b) #(c d))) '#(a b c d)) (fail 'vector-concatenate)) (or (and (eq? (vector? '#(a b c)) #t) (eq? (vector? '(a b c)) #f) (eq? (vector? #t) #f) (eq? (vector? '#()) #t) (eq? (vector? '()) #f)) (fail 'vector?)) (or (and (eq? (vector-empty? '#(a)) #f) (eq? (vector-empty? '#(())) #f) (eq? (vector-empty? '#(#())) #f) (eq? (vector-empty? '#()) #t)) (fail 'vector-empty?)) (or (and (eq? (vector= eq? '#(a b c d) '#(a b c d)) #t) (eq? (vector= eq? '#(a b c d) '#(a b d c)) #f) (eq? (vector= = '#(1 2 3 4 5) '#(1 2 3 4)) #f) (eq? (vector= = '#(1 2 3 4) '#(1 2 3 4)) #t) (eq? (vector= eq?) #t) (eq? (vector= eq? '#(a)) #t) (eq? (vector= eq? (vector (vector 'a)) (vector (vector 'a))) #f) (eq? (vector= equal? (vector (vector 'a)) (vector (vector 'a))) #t)) (fail 'vector=)) (or (eq? (vector-ref '#(a b c d) 2) 'c) (fail 'vector-ref)) (or (eq? (vector-length '#(a b c)) 3) (fail 'vector-length)) (or (equal? (vector-fold (lambda (index len str) (max (string-length str) len)) 0 '#("a" "b" "" "dd" "e")) 2) (fail 'vector-fold:1)) (or (equal? (vector-fold (lambda (index tail elt) (cons elt tail)) '() '#(0 1 2 3 4)) '(4 3 2 1 0)) (fail 'vector-fold:2)) (or (equal? (vector-fold (lambda (index counter n) (if (even? n) (+ counter 1) counter)) 0 '#(0 1 2 3 4 4 4 5 6 7)) 6) (fail 'vector-fold:3)) (or (equal? (vector-fold-right (lambda (index tail elt) (cons elt tail)) '() '#(a b c d)) '(a b c d)) (fail 'vector-fold-right)) (or (equal? (vector-map (lambda (i x) (* x x)) (vector-unfold (lambda (i x) (values x (+ x 1))) 4 1)) '#(1 4 9 16)) (fail 'vector-map:1)) (or (equal? (vector-map (lambda (i x y) (* x y)) (vector-unfold (lambda (i x) (values x (+ x 1))) 5 1) (vector-unfold (lambda (i x) (values x (- x 1))) 5 5)) '#(5 8 9 8 5)) (fail 'vector-map:2)) (or (member (let ((count 0)) (vector-map (lambda (ignored-index ignored-elt) (set! count (+ count 1)) count) '#(a b))) '(#(1 2) #(2 1))) (fail 'vector-map:3)) (or (equal? (let ((v (vector 1 2 3 4))) (vector-map! (lambda (i elt) (+ i elt)) v) v) '#(1 3 5 7)) (fail 'vector-map!)) (or (equal? (let ((p (open-output-string))) (vector-for-each (lambda (i x) (display x p) (newline p)) '#("foo" "bar" "baz" "quux" "zot")) (get-output-string p)) "foo\nbar\nbaz\nquux\nzot\n") (fail 'vector-for-each)) (or (equal? (vector-count (lambda (i elt) (even? elt)) '#(3 1 4 1 5 9 2 5 6)) 3) (fail 'vector-count:1)) (or (equal? (vector-count (lambda (i x y) (< x y)) '#(1 3 6 9) '#(2 4 6 8 10 12)) 2) (fail 'vector-count:2)) (or (equal? (vector-index even? '#(3 1 4 1 5 9)) 2) (fail 'vector-index:1)) (or (equal? (vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)) 1) (fail 'vector-index:2)) (or (equal? (vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)) #f) (fail 'vector-index:3)) (or (equal? (vector-index-right even? '#(3 1 4 1 5 9)) 2) (fail 'vector-index-right:1)) (or (equal? (vector-index-right < '#(3 1 4 1 5) '#(2 7 1 8 2)) 3) (fail 'vector-index-right:2)) (or (equal? (vector-index-right = '#(3 1 4 1 5) '#(2 7 1 8 2)) #f) (fail 'vector-index-right:3)) (or (equal? (vector-skip even? '#(3 1 4 1 5 9)) 0) (fail 'vector-skip:1)) (or (equal? (vector-skip < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)) 0) (fail 'vector-skip:2)) (or (equal? (vector-skip = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)) 0) (fail 'vector-skip:3)) (or (equal? (vector-skip > '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)) 1) (fail 'vector-skip:4)) (or (equal? (vector-skip-right even? '#(3 1 4 1 5 9)) 5) (fail 'vector-skip-right:1)) (or (equal? (vector-skip-right < '#(3 1 4 1 5) '#(2 7 1 8 2)) 4) (fail 'vector-skip-right:2)) (or (equal? (vector-skip-right = '#(3 1 4 1 5) '#(2 7 1 8 2)) 4) (fail 'vector-skip-right:3)) (or (equal? (vector-skip-right > '#(3 1 4 1 5) '#(2 7 1 8 2)) 3) (fail 'vector-skip-right:4)) (define (string-comparator s1 s2) (cond ((< (string-length s1) (string-length s2)) -1) ((> (string-length s1) (string-length s2)) +1) ((string<? s1 s2) -1) ((string>? s1 s2) +1) (else 0))) (or (equal? (vector-binary-search '#() "bad" string-comparator) #f) (fail 'vector-binary-search:0)) (or (equal? (vector-binary-search '#("ab" "cd" "ef" "bcd" "cde" "aaaa") "bad" string-comparator) #f) (fail 'vector-binary-search:1)) (or (equal? (vector-binary-search '#("ab" "cd" "ef" "bcd" "cde" "aaaa") "" string-comparator) #f) (fail 'vector-binary-search:2)) (or (equal? (vector-binary-search '#("ab" "cd" "ef" "bcd" "cde" "aaaa") "hello" string-comparator) #f) (fail 'vector-binary-search:3)) (or (equal? (vector-binary-search '#("ab" "cd" "ef" "bcd" "cde" "aaaa") "ab" string-comparator) 0) (fail 'vector-binary-search:4)) (or (equal? (vector-binary-search '#("ab" "cd" "ef" "bcd" "cde" "aaaa") "aaaa" string-comparator) 5) (fail 'vector-binary-search:5)) (or (equal? (vector-binary-search '#("ab" "cd" "ef" "bcd" "cde" "aaaa") "bcd" string-comparator) 3) (fail 'vector-binary-search:6)) (or (equal? (vector-any list '#() '#(a b c)) #f) (fail 'vector-any:0)) (or (equal? (vector-any list '#(a b c) '#()) #f) (fail 'vector-any:1)) (or (equal? (vector-any list '#(a b c) '#(d)) '(a d)) (fail 'vector-any:2)) (or (equal? (vector-any memq '#(a b c) '#(() (c d e) (b c 97))) '(c 97)) (fail 'vector-any:3)) (or (equal? (vector-every list '#() '#(a b c)) #t) (fail 'vector-every:0)) (or (equal? (vector-every list '#(a b c) '#()) #t) (fail 'vector-every:1)) (or (equal? (vector-every list '#(a b c) '#(d)) '(a d)) (fail 'vector-every:2)) (or (equal? (vector-every memq '#(a b c) '#(() (c d e) (b c 97))) #f) (fail 'vector-every:3)) (or (equal? (let ((v (vector 0 1 2 3))) (vector-set! v 1 11) v) '#(0 11 2 3)) (fail 'vector-set!)) (or (equal? (let ((v (vector 0 1 2 3))) (vector-swap! v 1 3) v) '#(0 3 2 1)) (fail 'vector-swap!)) (or (equal? (let ((v (vector))) (vector-fill! v 97) v) '#()) (fail 'vector-fill!:0)) (or (equal? (let ((v (vector 0 1 2 3))) (vector-fill! v 97) v) '#(97 97 97 97)) (fail 'vector-fill!:1)) (or (equal? (let ((v (vector 0 1 2 3))) (vector-fill! v 97 1) v) '#(0 97 97 97)) (fail 'vector-fill!:2)) (or (equal? (let ((v (vector 0 1 2 3))) (vector-fill! v 97 1 2) v) '#(0 97 2 3)) (fail 'vector-fill!:3)) (or (equal? (let ((v (vector))) (vector-reverse! v) v) '#()) (fail 'vector-reverse!:0)) (or (equal? (let ((v (vector 0 1 2 3))) (vector-reverse! v) v) '#(3 2 1 0)) (fail 'vector-reverse!:1)) (or (equal? (let ((v (vector 0 1 2 3))) (vector-reverse! v 1) v) '#(0 3 2 1)) (fail 'vector-reverse!:2)) (or (equal? (let ((v (vector 0 1 2 3))) (vector-reverse! v 1 3) v) '#(0 2 1 3)) (fail 'vector-reverse!:3)) (or (equal? (let ((v (vector)) (src '#(100 101 102 103 104 105))) (vector-copy! v 0 v) v) '#()) (fail 'vector-copy!:0)) (or (equal? (let ((v (vector 0 1 2 3 4 5)) (src '#(100 101 102 103 104 105))) (vector-copy! v 0 src) v) '#(100 101 102 103 104 105)) (fail 'vector-copy!:1)) (or (equal? (let ((v (vector 0 1 2 3)) (src '#(100 101 102 103 104 105))) (vector-copy! v 1 src 4) v) '#(0 104 105 3)) (fail 'vector-copy!:2)) (or (equal? (let ((v (vector 0 1 2 3)) (src '#(100 101 102 103 104 105))) (vector-copy! v 1 src 2 4) v) '#(0 102 103 3)) (fail 'vector-copy!:3)) (or (equal? (let ((v (vector)) (src '#(100 101 102 103 104 105))) (vector-reverse-copy! v 0 v) v) '#()) (fail 'vector-reverse-copy!:0)) (or (equal? (let ((v (vector 0 1 2 3 4 5)) (src '#(100 101 102 103 104 105))) (vector-reverse-copy! v 0 src) v) '#(105 104 103 102 101 100)) (fail 'vector-reverse-copy!:1)) (or (equal? (let ((v (vector 0 1 2 3)) (src '#(100 101 102 103 104 105))) (vector-reverse-copy! v 1 src 4) v) '#(0 105 104 3)) (fail 'vector-reverse-copy!:2)) (or (equal? (let ((v (vector 0 1 2 3)) (src '#(100 101 102 103 104 105))) (vector-reverse-copy! v 1 src 2 4) v) '#(0 103 102 3)) (fail 'vector-reverse-copy!:3)) (or (equal? (vector->list '#()) '()) (fail 'vector->list:0)) (or (equal? (vector->list '#(a b c)) '(a b c)) (fail 'vector->list:1)) (or (equal? (vector->list '#(a b c d e) 1) '(b c d e)) (fail 'vector->list:2)) (or (equal? (vector->list '#(a b c d e) 1 4) '(b c d)) (fail 'vector->list:3)) (or (equal? (reverse-vector->list '#()) '()) (fail 'reverse-vector->list:0)) (or (equal? (reverse-vector->list '#(a b c)) '(c b a)) (fail 'reverse-vector->list:1)) (or (equal? (reverse-vector->list '#(a b c d e) 1) '(e d c b)) (fail 'reverse-vector->list:2)) (or (equal? (reverse-vector->list '#(a b c d e) 1 3) '(c b)) (fail 'reverse-vector->list:3)) (or (equal? (list->vector '()) '#()) (fail 'list->vector:0)) (or (equal? (list->vector '(a b c)) '#(a b c)) (fail 'list->vector:1)) (or (equal? (reverse-list->vector '()) '#()) (fail 'reverse-list->vector:0)) (or (equal? (reverse-list->vector '(a b c)) '#(c b a)) (fail 'reverse-list->vector:1)) (writeln "Done.") �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������