Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Removed obsolete files

  • Loading branch information...
commit 602d48bb18ec90bcf4363318b6b77f1967d93ddd 1 parent 655d403
Per Eckerdal authored
103 misc/match.scm
View
@@ -1,103 +0,0 @@
-(import (only: (module) identifier?)) ;; TODO It might be good to
- ;; remove this dependency
-
-(export match)
-
-(define (pattern-match-helper pattern message)
- (cond
- ((identifier? pattern)
- (list message))
-
- ((and (or (string? pattern)
- (null? pattern)
- (boolean? pattern)
- (number? pattern))
- (equal? message pattern))
- '())
-
- ((and (pair? pattern)
- (eq? 'quote (car pattern))
- (eq? message (cadr pattern)))
- '())
-
- ((and (pair? pattern)
- (pair? message))
- (let loop ((p pattern) (m message))
- (cond
- ((and (null? p)
- (null? m))
- '())
-
- ((and (pair? p)
- (pair? m))
- (let ((res (pattern-match-helper
- (car p)
- (car m))))
- (and res
- (append
- res
- (loop (cdr p)
- (cdr m))))))
-
- ((and (not (pair? p))
- (not (pair? m)))
- (pattern-match-helper p m))
-
- (else
- #f))))
-
- (else
- #f)))
-
-
-(syntax-begin
-
- (define (pattern-match-param-list mac-env env pattern)
- (cond
- ((identifier? pattern)
- (list pattern))
-
- ((and (pair? pattern)
- (identifier=? mac-env 'quote env (car pattern)))
- '())
-
- ((pair? pattern)
- (append (pattern-match-param-list mac-env env (car pattern))
- (pattern-match-param-list mac-env env (cdr pattern))))
-
- (else
- '())))
-
- (define (pattern-match-make-lambda mac-env env pattern . body)
- `(,(make-syntactic-closure mac-env '() 'lambda)
- ,(pattern-match-param-list mac-env env pattern)
- ,@body)))
-
-(define-syntax match-lambda
- (sc-macro-transformer
- (lambda (form env)
- (capture-syntactic-environment
- (lambda (mac-env)
- (apply pattern-match-make-lambda
- (cons mac-env
- (cons env
- (cdr form)))))))))
-
-(define-syntax match-inner
- (syntax-rules ()
- ((match var)
- (error "Failed to match " var))
-
- ((match var (pattern body ...) rest ...)
- (let ((res (pattern-match-helper 'pattern var)))
- (if res
- (apply (match-lambda pattern body ...)
- res)
- (match var rest ...))))))
-
-(define-syntax match
- (syntax-rules ()
- ((match var rest ...)
- (let ((x var))
- (match-inner x rest ...)))))
-
63 misc/uuid.scm
View
@@ -1,63 +0,0 @@
-;;; UUID generation
-;;; See: http://www.ietf.org/rfc/rfc4122.txt
-;;;
-;;; Version 4 UUID, see section 4.4
-;;;
-;;; (taken from the termite distribution but modified by Per Eckerdal
-;;; to return a string instead of a symbol to avoid the memory leak of
-;;; an unbounded amount of interned symbols)
-
-(define (make-uuid)
- (define hex
- '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F))
- (let ((n1 (random-integer 65536))
- (n2 (random-integer 65536))
- (n3 (random-integer 65536))
- (n4 (random-integer 65536))
- (n5 (random-integer 65536))
- (n6 (random-integer 65536))
- (n7 (random-integer 65536))
- (n8 (random-integer 65536)))
- (string
- ;; time_lo
- (vector-ref hex (extract-bit-field 4 12 n1))
- (vector-ref hex (extract-bit-field 4 8 n1))
- (vector-ref hex (extract-bit-field 4 4 n1))
- (vector-ref hex (extract-bit-field 4 0 n1))
- (vector-ref hex (extract-bit-field 4 12 n2))
- (vector-ref hex (extract-bit-field 4 8 n2))
- (vector-ref hex (extract-bit-field 4 4 n2))
- (vector-ref hex (extract-bit-field 4 0 n2))
- #\-
- ;; time_mid
- (vector-ref hex (extract-bit-field 4 12 n3))
- (vector-ref hex (extract-bit-field 4 8 n3))
- (vector-ref hex (extract-bit-field 4 4 n3))
- (vector-ref hex (extract-bit-field 4 0 n3))
- #\-
- ;; time_hi_and_version
- (vector-ref hex #b0100)
- (vector-ref hex (extract-bit-field 4 8 n4))
- (vector-ref hex (extract-bit-field 4 4 n4))
- (vector-ref hex (extract-bit-field 4 0 n4))
- #\-
- ;; clock_seq_hi_and_reserved
- (vector-ref hex (bitwise-ior (extract-bit-field 2 12 n5) #b1000))
- (vector-ref hex (extract-bit-field 4 8 n5))
- ;; clock_seq_low
- (vector-ref hex (extract-bit-field 4 4 n5))
- (vector-ref hex (extract-bit-field 4 0 n5))
- #\-
- ;; node
- (vector-ref hex (extract-bit-field 4 12 n6))
- (vector-ref hex (extract-bit-field 4 8 n6))
- (vector-ref hex (extract-bit-field 4 4 n6))
- (vector-ref hex (extract-bit-field 4 0 n6))
- (vector-ref hex (extract-bit-field 4 12 n7))
- (vector-ref hex (extract-bit-field 4 8 n7))
- (vector-ref hex (extract-bit-field 4 4 n7))
- (vector-ref hex (extract-bit-field 4 0 n7))
- (vector-ref hex (extract-bit-field 4 12 n8))
- (vector-ref hex (extract-bit-field 4 8 n8))
- (vector-ref hex (extract-bit-field 4 4 n8))
- (vector-ref hex (extract-bit-field 4 0 n8)))))
1  srfi/.gitignore
View
@@ -1 +0,0 @@
-*.swp
1,724 srfi/1.scm
View
@@ -1,1724 +0,0 @@
-;;; SRFI-1 list-processing library -*- Scheme -*-
-;;; Reference implementation
-;;;
-;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
-;;; this code as long as you do not remove this copyright notice or
-;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
-;;; -Olin
-
-;;; 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)))))
-;;; A few uses of the LET-OPTIONAL and :OPTIONAL macros for parsing
-;;; optional arguments.
-;;;
-;;; 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.
-
-(declare
- (block)
- (standard-bindings)
- (extended-bindings)
- (fixnum)
- ;; (not safe) brauchts wirklich nicht mehr wenn ich manuell ## rein tue
- ;; diese bringen kaum mehr was: (eh ein?)
- ;;(inline)
- ;;(inlining-limit 1000)
- ;;(lambda-lift)
- )
-
-(compile-options no-global-state: #t)
-
-(export xcons tree-copy make-list list-tabulate cons* list-copy
- proper-list? circular-list? dotted-list? not-pair? null-list? list=
- circular-list length+
- iota
- first second third fourth fifth sixth seventh eighth ninth tenth
- car+cdr
- take drop
- take-right drop-right
- take! drop-right!
- split-at split-at!
- last last-pair
- zip unzip1 unzip2 unzip3 unzip4 unzip5
- count
- append! append-reverse append-reverse! concatenate concatenate!
- unfold fold pair-fold reduce
- unfold-right fold-right pair-fold-right reduce-right
- map 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!)
-
-;;; cj TO DO: do type checking & use unsafe compilation
-;; no: better manually use lowlevel functions. And: type errors
-; should be emitted in tail position, unlike the macros that were used here.
-(define-syntax check-arg
- (syntax-rules ()
- ((check-arg ignore ...) #f)))
-
-;;; 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.
-;cj warum war das auskommentiert? gibts schon was?
-(define (tree-copy x)
- (let recur ((x x))
- (if (not (##pair? x)) x
- (##cons (recur (##car x)) (recur (##cdr x))))))
-
-;;; Make a list of length LEN.
-
-; (define (make-list len . maybe-elt)
-; (check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list)
-; (let ((elt (cond ((null? maybe-elt) #f) ; Default value
-; ((null? (cdr maybe-elt)) (car maybe-elt))
-; (else (error "Too many arguments to MAKE-LIST"
-; (cons len maybe-elt))))))
-; (do ((i len (- i 1))
-; (ans '() (cons elt ans)))
-; ((<= i 0) ans))))
-
-;;cj:
-(define (make-list len #!optional elt)
- (if (##fixnum? len)
- ;;and (##fixnum.>= len 0) ? seems like the standard doesn't
- ;;prohibit negative lengths
- (let lp ((l '())
- (i len))
- (if (##fixnum.> i 0)
- (lp (##cons elt l) (##fixnum.- i 1))
- l))
- (error "make-list: len is not a fixnum:" len)))
-
-
-
-;(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 (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate)
- (check-arg procedure? proc list-tabulate)
- (do ((i (- len 1) (- i 1))
- (ans '() (cons (proc i) ans)))
- ((< i 0) ans)))
-
-;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
-;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
-;;;
-;;; (cons first (unfold not-pair? car cdr rest values))
-
-(define (cons* first . rest)
- (let recur ((x first) (rest rest))
- (if (##pair? rest)
- (##cons x (recur (##car rest) (##cdr rest)))
- x)))
-
-;;; (unfold not-pair? car cdr lis values)
-
-;(define (list-copy lis)
-; (let recur ((lis lis))
-; (if (pair? lis)
-; (cons (car lis) (recur (cdr lis)))
-; lis)))
-(define (list-copy lis)
- (let recur ((lis lis))
- (if (##pair? lis)
- (##cons (##car lis) (recur (##cdr lis)))
- lis)))
-
-;;; IOTA count [start step] (start start+step ... start+(count-1)*step)
-
-(define (iota count
- #!optional
- (start 0)
- (step 1))
- (check-arg integer? count iota)
- (if (< count 0) (error "Negative step count" iota count))
- (check-arg number? start iota)
- (check-arg number? step iota)
- (let ((last-val (+ start (* (- count 1) step))))
- (do ((count count (- count 1))
- (val last-val (- val step))
- (ans '() (cons val ans)))
- ((<= count 0) ans))))
-
-;;; I thought these were lovely, but the public at large did not share my
-;;; enthusiasm...
-;;; :IOTA to (0 ... to-1)
-;;; :IOTA from to (from ... to-1)
-;;; :IOTA from to step (from from+step ...)
-
-;;; IOTA: to (1 ... to)
-;;; IOTA: from to (from+1 ... to)
-;;; IOTA: from to step (from+step from+2step ...)
-
-;(define (%parse-iota-args arg1 rest-args proc)
-; (let ((check (lambda (n) (check-arg integer? n proc))))
-; (check arg1)
-; (if (pair? rest-args)
-; (let ((arg2 (check (car rest-args)))
-; (rest (cdr rest-args)))
-; (if (pair? rest)
-; (let ((arg3 (check (car rest)))
-; (rest (cdr rest)))
-; (if (pair? rest) (error "Too many parameters" proc arg1 rest-args)
-; (values arg1 arg2 arg3)))
-; (values arg1 arg2 1)))
-; (values 0 arg1 1))))
-;
-;(define (iota: arg1 . rest-args)
-; (receive (from to step) (%parse-iota-args arg1 rest-args iota:)
-; (let* ((numsteps (floor (/ (- to from) step)))
-; (last-val (+ from (* step numsteps))))
-; (if (< numsteps 0) (error "Negative step count" iota: from to step))
-; (do ((steps-left numsteps (- steps-left 1))
-; (val last-val (- val step))
-; (ans '() (cons val ans)))
-; ((<= steps-left 0) ans)))))
-;
-;
-;(define (:iota arg1 . rest-args)
-; (receive (from to step) (%parse-iota-args arg1 rest-args :iota)
-; (let* ((numsteps (ceiling (/ (- to from) step)))
-; (last-val (+ from (* step (- numsteps 1)))))
-; (if (< numsteps 0) (error "Negative step count" :iota from to step))
-; (do ((steps-left numsteps (- steps-left 1))
-; (val last-val (- val step))
-; (ans '() (cons val ans)))
-; ((<= steps-left 0) ans)))))
-
-
-
-(define (circular-list val1 . vals)
- (let ((ans (cons val1 vals)))
- (set-cdr! (last-pair ans) ans)
- ans))
-
-;;; <proper-list> ::= () ; Empty proper list
-;;; | (cons <x> <proper-list>) ; 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))))
-
-(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))) ;; could we use ##cdr here? prove?
- (and (not (eq? x lag))
- (lp x lag)))
- (##null? x)))
- (##null? x))))
-
-;;cj: btw the gambit builtin seems to detect circles as well.
-;;(define proper-list? list?) but now that the above is as fast, why bother.
-
-
-;;; 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.
-;;;
-;;; <dotted-list> ::= <non-nil,non-pair> ; Empty dotted list
-;;; | (cons <x> <dotted-list>) ; 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))) ;; could we use ##cdr? but only makes a difference of <10%
- (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))) ;; see above, same.
- (or (eq? x lag)
- (lp x lag))))))))
-
-
-(define (not-pair? x) (not (##pair? x))) ; Inline me.
-;;cj:
-(define-macro (*not-pair? x) `(not (##pair? ,x)))
-
-;;; 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-macro (*null-list? l)
- `(let ((l ,l))
- (cond ((##pair? l) #f)
- ((##null? l) #t)
- (else (error "null-list?: argument out of domain" l)))))
-
-
-(define (list= = . lists)
- (or (##null? lists) ; special case
-
- (let lp1 ((list-a (car lists)) (others (cdr lists)))
- (or (##null? others)
- (let ((list-b (##car others))
- (others (##cdr others)))
- (if (eq? list-a list-b) ; EQ? => LIST=
- (lp1 list-b others)
- (let lp2 ((list-a list-a) (list-b list-b))
- (if (*null-list? list-a)
- (and (*null-list? list-b)
- (lp1 list-b others))
- (and (not (*null-list? list-b))
- (= (##car list-a) (##car list-b))
- (lp2 (##cdr list-a) (##cdr list-b)))))))))))
-
-
-
-;;; R4RS, so commented out.
-;(define (length x) ; LENGTH may diverge or
-; (let lp ((x x) (len 0)) ; raise an error if X is
-; (if (pair? x) ; a circular list. This version
-; (lp (cdr x) (+ len 1)) ; diverges.
-; len)))
-
-(define (length+ x) ; Returns #f if X is circular.
- (let lp ((x x) (lag x) (len 0))
- (if (##pair? x)
- (let ((x (##cdr x))
- (len (##fixnum.+ len 1)))
- (if (##pair? x)
- (let ((x (##cdr x))
- (lag (cdr lag))
- (len (##fixnum.+ len 1)))
- (and (not (eq? x lag))
- (lp x lag len)))
- len))
- len)))
-
-
-(define (zip list1 . more-lists) (apply map list list1 more-lists))
-
-
-;;; Selectors
-;;;;;;;;;;;;;
-
-;;; R4RS non-primitives:
-;(define (caar x) (car (car x)))
-;(define (cadr x) (car (cdr x)))
-;(define (cdar x) (cdr (car x)))
-;(define (cddr x) (cdr (cdr x)))
-;
-;(define (caaar x) (caar (car x)))
-;(define (caadr x) (caar (cdr x)))
-;(define (cadar x) (cadr (car x)))
-;(define (caddr x) (cadr (cdr x)))
-;(define (cdaar x) (cdar (car x)))
-;(define (cdadr x) (cdar (cdr x)))
-;(define (cddar x) (cddr (car x)))
-;(define (cdddr x) (cddr (cdr x)))
-;
-;(define (caaaar x) (caaar (car x)))
-;(define (caaadr x) (caaar (cdr x)))
-;(define (caadar x) (caadr (car x)))
-;(define (caaddr x) (caadr (cdr x)))
-;(define (cadaar x) (cadar (car x)))
-;(define (cadadr x) (cadar (cdr x)))
-;(define (caddar x) (caddr (car x)))
-;(define (cadddr x) (caddr (cdr x)))
-;(define (cdaaar x) (cdaar (car x)))
-;(define (cdaadr x) (cdaar (cdr x)))
-;(define (cdadar x) (cdadr (car x)))
-;(define (cdaddr x) (cdadr (cdr x)))
-;(define (cddaar x) (cddar (car x)))
-;(define (cddadr x) (cddar (cdr x)))
-;(define (cdddar x) (cdddr (car x)))
-;(define (cddddr x) (cdddr (cdr x)))
-
-
-(define first car)
-(define second cadr)
-(define third caddr)
-(define fourth cadddr)
-(define (fifth x) (car (cddddr x)))
-(define (sixth x) (cadr (cddddr x)))
-(define (seventh x) (caddr (cddddr x)))
-(define (eighth x) (cadddr (cddddr x)))
-(define (ninth x) (car (cddddr (cddddr x))))
-(define (tenth x) (cadr (cddddr (cddddr x))))
-
-(define (car+cdr pair) (values (car pair) (cdr pair)))
-
-;;; take & drop
-
-;;cj: hey it seems that here negative arguments had really been forgotten !
-
-(define (take=recur lis k)
- ;;(check-arg integer? k take)
- (if (and (##fixnum? k) (##fixnum.>= k 0))
- (let recur ((lis lis) (k k))
- (if (##fixnum.zero? k) '()
- (if (##pair? lis)
- (##cons (##car lis)
- (recur (##cdr lis) (##fixnum.- k 1)))
- (error "take: lis too short"))))
- (error "take: k is not a positive fixnum:" k)))
-;;cj NOTE: uses recursion, thus overly stack, thus additional gc with large k.
-;; the following is 2.35 times faster (measured with gambit4b14 on ppc) with k==100000, or still 1.15 times faster with k==10000 (where the call stack doesn't allocate heap space yet with take=recur).
-(define (take lis k)
- (if (and (##fixnum? k) (##fixnum.>= k 0))
- (if (##fixnum.= k 0)
- '()
- (or (and (pair? lis)
- (let ((res (cons (##car lis) '())))
- (let iter ((res-tail res)
- (lis (##cdr lis))
- (k (##fixnum.- k 1)))
- (if (##fixnum.zero? k) res
- (and (##pair? lis)
- (let ((res-next (##cons (##car lis) '())))
- (##set-cdr! res-tail res-next)
- (iter res-next
- (##cdr lis)
- (##fixnum.- k 1))))))))
- (error "take: lis too short")))
- (error "take: k is not a positive fixnum:" k)))
-
-(define (drop lis k)
- ;;(check-arg integer? k drop)
- (if (and (##fixnum? k) (##fixnum.>= k 0))
- (let iter ((lis lis) (k k))
- (if (##fixnum.zero? k) lis
- (if (##pair? lis)
- (iter (##cdr lis)
- (##fixnum.- k 1))
- (error "drop: lis too short"))))
- (error "drop: k is not a positive fixnum:" k)))
-
-
-(define (take! lis k)
- ;;(check-arg integer? k take!)
- (if (and (##fixnum? k) (##fixnum.>= k 0))
- (if (##fixnum.zero? k) '()
- (begin (set-cdr! (drop lis (##fixnum.- k 1)) '())
- lis))
- (error "take!: k is not a positive fixnum:" k)))
-
-;;; 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.
-
-;; cj todo continue with optimizations..
-
-(define (take-right lis k)
- (check-arg integer? k take-right)
- (let lp ((lag lis) (lead (drop lis k)))
- (if (pair? lead)
- (lp (cdr lag) (cdr lead))
- lag)))
-
-(define (drop-right lis k)
- (check-arg integer? k drop-right)
- (let recur ((lag lis) (lead (drop lis k)))
- (if (pair? lead)
- (cons (car lag) (recur (cdr lag) (cdr lead)))
- '())))
-
-;;; In this function, LEAD is actually K+1 ahead of LAG. This lets
-;;; us stop LAG one step early, in time to smash its cdr to ().
-(define (drop-right! lis k)
- (check-arg integer? k drop-right!)
- (let ((lead (drop lis k)))
- (if (pair? lead)
-
- (let lp ((lag lis) (lead (cdr lead))) ; Standard case
- (if (pair? lead)
- (lp (cdr lag) (cdr lead))
- (begin (set-cdr! lag '())
- lis)))
-
- '()))) ; Special case dropping everything -- no cons to side-effect.
-
-;(define (list-ref lis i) (car (drop lis i))) ; R4RS
-
-;;; These use the APL convention, whereby negative indices mean
-;;; "from the right." I liked them, but they didn't win over the
-;;; SRFI reviewers.
-;;; K >= 0: Take and drop K elts from the front of the list.
-;;; K <= 0: Take and drop -K elts from the end of the list.
-
-;(define (take lis k)
-; (check-arg integer? k take)
-; (if (negative? k)
-; (list-tail lis (+ k (length lis)))
-; (let recur ((lis lis) (k k))
-; (if (zero? k) '()
-; (cons (car lis)
-; (recur (cdr lis) (- k 1)))))))
-;
-;(define (drop lis k)
-; (check-arg integer? k drop)
-; (if (negative? k)
-; (let recur ((lis lis) (nelts (+ k (length lis))))
-; (if (zero? nelts) '()
-; (cons (car lis)
-; (recur (cdr lis) (- nelts 1)))))
-; (list-tail lis k)))
-;
-;
-;(define (take! lis k)
-; (check-arg integer? k take!)
-; (cond ((zero? k) '())
-; ((positive? k)
-; (set-cdr! (list-tail lis (- k 1)) '())
-; lis)
-; (else (list-tail lis (+ k (length lis))))))
-;
-;(define (drop! lis k)
-; (check-arg integer? k drop!)
-; (if (negative? k)
-; (let ((nelts (+ k (length lis))))
-; (if (zero? nelts) '()
-; (begin (set-cdr! (list-tail lis (- nelts 1)) '())
-; lis)))
-; (list-tail lis k)))
-
-(define (split-at x k)
- (check-arg integer? k split-at)
- (let recur ((lis x) (k k))
- (if (zero? k) (values '() lis)
- (receive (prefix suffix) (recur (cdr lis) (- k 1))
- (values (cons (car lis) prefix) suffix)))))
-
-(define (split-at! x k)
- (check-arg integer? k split-at!)
- (if (zero? k) (values '() x)
- (let* ((prev (drop x (- k 1)))
- (suffix (cdr prev)))
- (set-cdr! prev '())
- (values x suffix))))
-
-
-(define (last lis) (car (last-pair lis)))
-
-(define (last-pair lis)
- (check-arg pair? lis last-pair)
- (let lp ((lis lis))
- (let ((tail (cdr lis)))
- (if (pair? tail) (lp tail) lis))))
-
-
-;;; Unzippers -- 1 through 5
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (unzip1 lis) (map car lis))
-
-(define (unzip2 lis)
- (let recur ((lis lis))
- (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle
- (let ((elt (car lis))) ; dotted lists.
- (receive (a b) (recur (cdr lis))
- (values (cons (car elt) a)
- (cons (cadr elt) b)))))))
-
-(define (unzip3 lis)
- (let recur ((lis lis))
- (if (null-list? lis) (values lis lis lis)
- (let ((elt (car lis)))
- (receive (a b c) (recur (cdr lis))
- (values (cons (car elt) a)
- (cons (cadr elt) b)
- (cons (caddr elt) c)))))))
-
-(define (unzip4 lis)
- (let recur ((lis lis))
- (if (null-list? lis) (values lis lis lis lis)
- (let ((elt (car lis)))
- (receive (a b c d) (recur (cdr lis))
- (values (cons (car elt) a)
- (cons (cadr elt) b)
- (cons (caddr elt) c)
- (cons (cadddr elt) d)))))))
-
-(define (unzip5 lis)
- (let recur ((lis lis))
- (if (null-list? lis) (values lis lis lis lis lis)
- (let ((elt (car lis)))
- (receive (a b c d e) (recur (cdr lis))
- (values (cons (car elt) a)
- (cons (cadr elt) b)
- (cons (caddr elt) c)
- (cons (cadddr elt) d)
- (cons (car (cddddr elt)) e)))))))
-
-
-;;; append! append-reverse append-reverse! concatenate concatenate!
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (append! . lists)
- ;; First, scan through lists looking for a non-empty one.
- (let lp ((lists lists) (prev '()))
- (if (not (pair? lists)) prev
- (let ((first (car lists))
- (rest (cdr lists)))
- (if (not (pair? first)) (lp rest first)
-
- ;; Now, do the splicing.
- (let lp2 ((tail-cons (last-pair first))
- (rest rest))
- (if (pair? rest)
- (let ((next (car rest))
- (rest (cdr rest)))
- (set-cdr! tail-cons next)
- (lp2 (if (pair? next) (last-pair next) tail-cons)
- rest))
- first)))))))
-
-;;; APPEND is R4RS.
-;(define (append . lists)
-; (if (pair? lists)
-; (let recur ((list1 (car lists)) (lists (cdr lists)))
-; (if (pair? lists)
-; (let ((tail (recur (car lists) (cdr lists))))
-; (fold-right cons tail list1)) ; Append LIST1 & TAIL.
-; list1))
-; '()))
-
-;(define (append-reverse rev-head tail) (fold cons tail rev-head))
-
-;(define (append-reverse! rev-head tail)
-; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair)
-; tail
-; rev-head))
-
-;;; Hand-inline the FOLD and PAIR-FOLD ops for speed.
-
-(define (append-reverse rev-head tail)
- (let lp ((rev-head rev-head) (tail tail))
- (if (null-list? rev-head) tail
- (lp (cdr rev-head) (cons (car rev-head) tail)))))
-
-(define (append-reverse! rev-head tail)
- (let lp ((rev-head rev-head) (tail tail))
- (if (null-list? rev-head) tail
- (let ((next-rev (cdr rev-head)))
- (set-cdr! rev-head tail)
- (lp next-rev rev-head)))))
-
-
-(define (concatenate lists) (reduce-right append '() lists))
-(define (concatenate! lists) (reduce-right append! '() lists))
-
-;;; Fold/map internal utilities
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; These little internal utilities are used by the general
-;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined.
-;;; One the other hand, the n-ary cases are painfully inefficient as it is.
-;;; An aggressive implementation should simply re-write these functions
-;;; for raw efficiency; I have written them for as much clarity, portability,
-;;; and simplicity as can be achieved.
-;;;
-;;; I use the dreaded call/cc to do local aborts. A good compiler could
-;;; handle this with extreme efficiency. An implementation that provides
-;;; a one-shot, non-persistent continuation grabber could help the compiler
-;;; out by using that in place of the call/cc's in these routines.
-;;;
-;;; These functions have funky definitions that are precisely tuned to
-;;; the needs of the fold/map procs -- for example, to minimize the number
-;;; of times the argument lists need to be examined.
-
-;;; Return (map cdr lists).
-;;; However, if any element of LISTS is empty, just abort and return '().
-(define (%cdrs lists)
- (call-with-current-continuation
- (lambda (abort)
- (let recur ((lists lists))
- (if (pair? lists)
- (let ((lis (car lists)))
- (if (null-list? lis) (abort '())
- (cons (cdr lis) (recur (cdr lists)))))
- '())))))
-
-(define (%cars+ lists last-elt) ; (append! (map car lists) (list last-elt))
- (let recur ((lists lists))
- (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt))))
-
-;;; LISTS is a (not very long) non-empty list of lists.
-;;; Return two lists: the cars & the cdrs of the lists.
-;;; However, if any of the lists is empty, just abort and return [() ()].
-
-(define (%cars+cdrs lists)
- (call-with-current-continuation
- (lambda (abort)
- (let recur ((lists lists))
- (if (pair? lists)
- (receive (list other-lists) (car+cdr lists)
- (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
- (receive (a d) (car+cdr list)
- (receive (cars cdrs) (recur other-lists)
- (values (cons a cars) (cons d cdrs))))))
- (values '() '()))))))
-
-;;; Like %CARS+CDRS, but we pass in a final elt tacked onto the end of the
-;;; cars list. What a hack.
-(define (%cars+cdrs+ lists cars-final)
- (call-with-current-continuation
- (lambda (abort)
- (let recur ((lists lists))
- (if (pair? lists)
- (receive (list other-lists) (car+cdr lists)
- (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
- (receive (a d) (car+cdr list)
- (receive (cars cdrs) (recur other-lists)
- (values (cons a cars) (cons d cdrs))))))
- (values (list cars-final) '()))))))
-
-;;; Like %CARS+CDRS, but blow up if any list is empty.
-(define (%cars+cdrs/no-test lists)
- (let recur ((lists lists))
- (if (pair? lists)
- (receive (list other-lists) (car+cdr lists)
- (receive (a d) (car+cdr list)
- (receive (cars cdrs) (recur other-lists)
- (values (cons a cars) (cons d cdrs)))))
- (values '() '()))))
-
-
-;;; count
-;;;;;;;;;
-(define (count pred list1 . lists)
- (check-arg procedure? pred count)
- (if (pair? lists)
-
- ;; N-ary case
- (let lp ((list1 list1) (lists lists) (i 0))
- (if (null-list? list1) i
- (receive (as ds) (%cars+cdrs lists)
- (if (null? as) i
- (lp (cdr list1) ds
- (if (apply pred (car list1) as) (+ i 1) i))))))
-
- ;; Fast path
- (let lp ((lis list1) (i 0))
- (if (null-list? lis) i
- (lp (cdr lis) (if (pred (car lis)) (+ i 1) i))))))
-
-
-;;; fold/unfold
-;;;;;;;;;;;;;;;
-
-(define (unfold-right p f g seed #!optional (ans '()))
- (check-arg procedure? p unfold-right)
- (check-arg procedure? f unfold-right)
- (check-arg procedure? g unfold-right)
- (let lp ((seed seed) (ans ans))
- (if (p seed) ans
- (lp (g seed)
- (cons (f seed) ans)))))
-
-
-(define (unfold p f g seed . maybe-tail-gen)
- (check-arg procedure? p unfold)
- (check-arg procedure? f unfold)
- (check-arg procedure? g unfold)
- (if (pair? maybe-tail-gen)
-
- (let ((tail-gen (car maybe-tail-gen)))
- (if (pair? (cdr maybe-tail-gen))
- (apply error "Too many arguments" unfold p f g seed maybe-tail-gen)
-
- (let recur ((seed seed))
- (if (p seed) (tail-gen seed)
- (cons (f seed) (recur (g seed)))))))
-
- (let recur ((seed seed))
- (if (p seed) '()
- (cons (f seed) (recur (g seed)))))))
-
-
-(define (fold kons knil lis1 . lists)
- (check-arg procedure? kons fold)
- (if (pair? lists)
- (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case
- (receive (cars+ans cdrs) (%cars+cdrs+ lists ans)
- (if (null? cars+ans) ans ; Done.
- (lp cdrs (apply kons cars+ans)))))
-
- (let lp ((lis lis1) (ans knil)) ; Fast path
- (if (null-list? lis) ans
- (lp (cdr lis) (kons (car lis) ans))))))
-
-
-(define (fold-right kons knil lis1 . lists)
- (check-arg procedure? kons fold-right)
- (if (pair? lists)
- (let recur ((lists (cons lis1 lists))) ; N-ary case
- (let ((cdrs (%cdrs lists)))
- (if (null? cdrs) knil
- (apply kons (%cars+ lists (recur cdrs))))))
-
- (let recur ((lis lis1)) ; Fast path
- (if (null-list? lis) knil
- (let ((head (car lis)))
- (kons head (recur (cdr lis))))))))
-
-
-(define (pair-fold-right f zero lis1 . lists)
- (check-arg procedure? f pair-fold-right)
- (if (pair? lists)
- (let recur ((lists (cons lis1 lists))) ; N-ary case
- (let ((cdrs (%cdrs lists)))
- (if (null? cdrs) zero
- (apply f (append! lists (list (recur cdrs)))))))
-
- (let recur ((lis lis1)) ; Fast path
- (if (null-list? lis) zero (f lis (recur (cdr lis)))))))
-
-(define (pair-fold f zero lis1 . lists)
- (check-arg procedure? f pair-fold)
- (if (pair? lists)
- (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case
- (let ((tails (%cdrs lists)))
- (if (null? tails) ans
- (lp tails (apply f (append! lists (list ans)))))))
-
- (let lp ((lis lis1) (ans zero))
- (if (null-list? lis) ans
- (let ((tail (cdr lis))) ; Grab the cdr now,
- (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS.
-
-
-;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
-;;; These cannot meaningfully be n-ary.
-
-(define (reduce f ridentity lis)
- (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 f lis1 . lists)
- (really-append-map append-map append f lis1 lists))
-(define (append-map! f lis1 . lists)
- (really-append-map append-map! append! f lis1 lists))
-
-(define (really-append-map who appender f lis1 lists)
- (check-arg procedure? f who)
- (if (pair? lists)
- (receive (cars cdrs) (%cars+cdrs (cons lis1 lists))
- (if (null? cars) '()
- (let recur ((cars cars) (cdrs cdrs))
- (let ((vals (apply f cars)))
- (receive (cars2 cdrs2) (%cars+cdrs cdrs)
- (if (null? cars2) vals
- (appender vals (recur cars2 cdrs2))))))))
-
- ;; Fast path
- (if (null-list? lis1) '()
- (let recur ((elt (car lis1)) (rest (cdr lis1)))
- (let ((vals (f elt)))
- (if (null-list? rest) vals
- (appender vals (recur (car rest) (cdr rest)))))))))
-
-
-(define (pair-for-each proc lis1 . lists)
- (check-arg procedure? proc pair-for-each)
- (if (pair? lists)
-
- (let lp ((lists (cons lis1 lists)))
- (let ((tails (%cdrs lists)))
- (if (pair? tails)
- (begin (apply proc lists)
- (lp tails)))))
-
- ;; Fast path.
- (let lp ((lis lis1))
- (if (not (null-list? lis))
- (let ((tail (cdr lis))) ; Grab the cdr now,
- (proc lis) ; in case PROC SET-CDR!s LIS.
- (lp tail))))))
-
-;;; We stop when LIS1 runs out, not when any list runs out.
-(define (map! f lis1 . lists)
- (check-arg procedure? f map!)
- (if (pair? lists)
- (let lp ((lis1 lis1) (lists lists))
- (if (not (null-list? lis1))
- (receive (heads tails) (%cars+cdrs/no-test lists)
- (set-car! lis1 (apply f (car lis1) heads))
- (lp (cdr lis1) tails))))
-
- ;; Fast path.
- (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
- lis1)
-
-
-;;; Map F across L, and save up all the non-false results.
-(define (filter-map f lis1 . lists)
- (check-arg procedure? f filter-map)
- (if (pair? lists)
- (let recur ((lists (cons lis1 lists)))
- (receive (cars cdrs) (%cars+cdrs lists)
- (if (pair? cars)
- (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs))))
- (else (recur cdrs))) ; Tail call in this arm.
- '())))
-
- ;; Fast path.
- (let recur ((lis lis1))
- (if (null-list? lis) lis
- (let ((tail (recur (cdr lis))))
- (cond ((f (car lis)) => (lambda (x) (cons x tail)))
- (else tail)))))))
-
-
-;;; Map F across lists, guaranteeing to go left-to-right.
-;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
-;;; in which case this procedure may simply be defined as a synonym for MAP.
-
-(define (map-in-order f lis1 . lists)
- (check-arg procedure? f map-in-order)
- (if (pair? lists)
- (let recur ((lists (cons lis1 lists)))
- (receive (cars cdrs) (%cars+cdrs lists)
- (if (pair? cars)
- (let ((x (apply f cars))) ; Do head first,
- (cons x (recur cdrs))) ; then tail.
- '())))
-
- ;; Fast path.
- (let recur ((lis lis1))
- (if (null-list? lis) lis
- (let ((tail (cdr lis))
- (x (f (car lis)))) ; Do head first,
- (cons x (recur tail))))))) ; then tail.
-
-
-;;; We extend MAP to handle arguments of unequal length.
-(define map map-in-order)
-
-
-;;; filter, remove, partition
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
-;;; disorder the elements of their argument.
-
-;; This FILTER shares the longest tail of L that has no deleted elements.
-;; If Scheme had multi-continuation calls, they could be made more efficient.
-
-(define (filter pred lis) ; Sleazing with EQ? makes this
- (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)))))))))
-
-
-;;; Inline us, please.
-(define (remove pred l) (filter (lambda (x) (not (pred x))) l))
-(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
-
-
-
-;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions.
-;;; (I don't actually think these are the world's most important
-;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants
-;;; are far more general.)
-;;;
-;;; Function Action
-;;; ---------------------------------------------------------------------------
-;;; remove pred lis Delete by general predicate
-;;; delete x lis [=] Delete by element comparison
-;;;
-;;; find pred lis Search by general predicate
-;;; find-tail pred lis Search by general predicate
-;;; member x lis [=] Search by element comparison
-;;;
-;;; assoc key lis [=] Search alist by key comparison
-;;; alist-delete key alist [=] Alist-delete by key comparison
-
-(define (delete x lis #!optional (= equal?))
- (filter (lambda (y) (not (= x y))) lis))
-
-(define (delete! x lis #!optional (= equal?))
- (filter! (lambda (y) (not (= x y))) lis))
-
-;;; Extended from R4RS to take an optional comparison argument.
-(define (member x lis #!optional (= equal?))
- (find-tail (lambda (y) (= x y)) lis))
-
-;;; R4RS, hence we don't bother to define.
-;;; The MEMBER and then FIND-TAIL call should definitely
-;;; be inlined for MEMQ & MEMV.
-;(define (memq x lis) (member x lis eq?))
-;(define (memv x lis) (member x lis eqv?))
-
-
-;;; right-duplicate deletion
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; delete-duplicates delete-duplicates!
-;;;
-;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates
-;;; in long lists, sort the list to bring duplicates together, then use a
-;;; linear-time algorithm to kill the dups. Or use an algorithm based on
-;;; element-marking. The former gives you O(n lg n), the latter is linear.
-
-(define (delete-duplicates lis #!optional (elt= equal?))
- (check-arg procedure? elt= delete-duplicates)
- (let recur ((lis lis))
- (if (null-list? lis) lis
- (let* ((x (car lis))
- (tail (cdr lis))
- (new-tail (recur (delete x tail elt=))))
- (if (eq? tail new-tail) lis (cons x new-tail))))))
-
-(define (delete-duplicates! lis #!optional (elt= equal?))
- (check-arg procedure? elt= delete-duplicates!)
- (let recur ((lis lis))
- (if (null-list? lis) lis
- (let* ((x (car lis))
- (tail (cdr lis))
- (new-tail (recur (delete! x tail elt=))))
- (if (eq? tail new-tail) lis (cons x new-tail))))))
-
-
-;;; alist stuff
-;;;;;;;;;;;;;;;
-
-;;; Extended from R4RS to take an optional comparison argument.
-(define (assoc x lis #!optional (= equal?))
- (find (lambda (entry) (= x (car entry))) lis))
-
-(define (alist-cons key datum alist) (cons (cons key datum) alist))
-
-(define (alist-copy alist)
- (map (lambda (elt) (cons (car elt) (cdr elt)))
- alist))
-
-(define (alist-delete key alist #!optional (= equal?))
- (filter (lambda (elt) (not (= key (car elt)))) alist))
-
-(define (alist-delete! key alist #!optional (= equal?))
- (filter! (lambda (elt) (not (= key (car elt)))) alist))
-
-
-;;; find find-tail take-while drop-while span break any every list-index
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (find pred list)
- (cond ((find-tail pred list) => car)
- (else #f)))
-
-(define (find-tail pred list)
- (check-arg procedure? pred find-tail)
- (let lp ((list list))
- (and (not (null-list? list))
- (if (pred (car list)) list
- (lp (cdr list))))))
-
-(define (take-while pred lis)
- (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))
-
-(define (any pred lis1 . lists)
- (check-arg procedure? pred any)
- (if (pair? lists)
-
- ;; N-ary case
- (receive (heads tails) (%cars+cdrs (cons lis1 lists))
- (and (pair? heads)
- (let lp ((heads heads) (tails tails))
- (receive (next-heads next-tails) (%cars+cdrs tails)
- (if (pair? next-heads)
- (or (apply pred heads) (lp next-heads next-tails))
- (apply pred heads)))))) ; Last PRED app is tail call.
-
- ;; Fast path
- (and (not (null-list? lis1))
- (let lp ((head (car lis1)) (tail (cdr lis1)))
- (if (null-list? tail)
- (pred head) ; Last PRED app is tail call.
- (or (pred head) (lp (car tail) (cdr tail))))))))
-
-
-;(define (every pred list) ; Simple definition.
-; (let lp ((list list)) ; Doesn't return the last PRED value.
-; (or (not (pair? list))
-; (and (pred (car list))
-; (lp (cdr list))))))
-
-(define (every pred lis1 . lists)
- (check-arg procedure? pred every)
- (if (pair? lists)
-
- ;; N-ary case
- (receive (heads tails) (%cars+cdrs (cons lis1 lists))
- (or (not (pair? heads))
- (let lp ((heads heads) (tails tails))
- (receive (next-heads next-tails) (%cars+cdrs tails)
- (if (pair? next-heads)
- (and (apply pred heads) (lp next-heads next-tails))
- (apply pred heads)))))) ; Last PRED app is tail call.
-
- ;; Fast path
- (or (null-list? lis1)
- (let lp ((head (car lis1)) (tail (cdr lis1)))
- (if (null-list? tail)
- (pred head) ; Last PRED app is tail call.
- (and (pred head) (lp (car tail) (cdr tail))))))))
-
-(define (list-index pred lis1 . lists)
- (check-arg procedure? pred list-index)
- (if (pair? lists)
-
- ;; N-ary case
- (let lp ((lists (cons lis1 lists)) (n 0))
- (receive (heads tails) (%cars+cdrs lists)
- (and (pair? heads)
- (if (apply pred heads) n
- (lp tails (+ n 1))))))
-
- ;; Fast path
- (let lp ((lis lis1) (n 0))
- (and (not (null-list? lis))
- (if (pred (car lis)) n (lp (cdr lis) (+ n 1)))))))
-
-;;; Reverse
-;;;;;;;;;;;
-
-;R4RS, so not defined here.
-;(define (reverse lis) (fold cons '() lis))
-
-;(define (reverse! lis)
-; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis))
-
-(define (reverse! lis)
- (let lp ((lis lis) (ans '()))
- (if (null-list? lis) ans
- (let ((tail (##cdr lis)))
- (##set-cdr! lis ans)
- (lp tail lis)))))
-
-;;; Lists-as-sets
-;;;;;;;;;;;;;;;;;
-
-;;; This is carefully tuned code; do not modify casually.
-;;; - It is careful to share storage when possible;
-;;; - Side-effecting code tries not to perform redundant writes.
-;;; - It tries to avoid linear-time scans in special cases where constant-time
-;;; computations can be performed.
-;;; - It relies on similar properties from the other list-lib procs it calls.
-;;; For example, it uses the fact that the implementations of MEMBER and
-;;; FILTER in this source code share longest common tails between args
-;;; and results to get structure sharing in the lset procedures.
-
-(define (%lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1))
-
-(define (lset<= = . lists)
- (check-arg procedure? = lset<=)
- (or (not (pair? lists)) ; 0-ary case
- (let lp ((s1 (car lists)) (rest (cdr lists)))
- (or (not (pair? rest))
- (let ((s2 (car rest)) (rest (cdr rest)))
- (and (or (eq? s2 s1) ; Fast path
- (%lset2<= = s1 s2)) ; Real test
- (lp s2 rest)))))))
-
-(define (lset= = . lists)
- (check-arg procedure? = lset=)
- (or (not (pair? lists)) ; 0-ary case
- (let lp ((s1 (car lists)) (rest (cdr lists)))
- (or (not (pair? rest))
- (let ((s2 (car rest))
- (rest (cdr rest)))
- (and (or (eq? s1 s2) ; Fast path
- (and (%lset2<= = s1 s2) (%lset2<= = s2 s1))) ; Real test
- (lp s2 rest)))))))
-
-
-(define (lset-adjoin = lis . elts)
- (check-arg procedure? = lset-adjoin)
- (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans)))
- lis elts))
-
-
-(define (lset-union = . lists)
- (check-arg procedure? = lset-union)
- (reduce (lambda (lis ans) ; Compute ANS + LIS.
- (cond ((null? lis) ans) ; Don't copy any lists
- ((null? ans) lis) ; if we don't have to.
- ((eq? lis ans) ans)
- (else
- (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans)
- ans
- (cons elt ans)))
- ans lis))))
- '() lists))
-
-(define (lset-union! = . lists)
- (check-arg procedure? = lset-union!)
- (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS.
- (cond ((null? lis) ans) ; Don't copy any lists
- ((null? ans) lis) ; if we don't have to.
- ((eq? lis ans) ans)
- (else
- (pair-fold (lambda (pair ans)
- (let ((elt (car pair)))
- (if (any (lambda (x) (= x elt)) ans)
- ans
- (begin (set-cdr! pair ans) pair))))
- ans lis))))
- '() lists))
-
-
-(define (lset-intersection = lis1 . lists)
- (check-arg procedure? = lset-intersection)
- (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
- (cond ((any null-list? lists) '()) ; Short cut
- ((null? lists) lis1) ; Short cut
- (else (filter (lambda (x)
- (every (lambda (lis) (member x lis =)) lists))
- lis1)))))
-
-(define (lset-intersection! = lis1 . lists)
- (check-arg procedure? = lset-intersection!)
- (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
- (cond ((any null-list? lists) '()) ; Short cut
- ((null? lists) lis1) ; Short cut
- (else (filter! (lambda (x)
- (every (lambda (lis) (member x lis =)) lists))
- lis1)))))
-
-
-(define (lset-difference = lis1 . lists)
- (check-arg procedure? = lset-difference)
- (let ((lists (filter pair? lists))) ; Throw out empty lists.
- (cond ((null? lists) lis1) ; Short cut
- ((memq lis1 lists) '()) ; Short cut
- (else (filter (lambda (x)
- (every (lambda (lis) (not (member x lis =)))
- lists))
- lis1)))))
-
-(define (lset-difference! = lis1 . lists)
- (check-arg procedure? = lset-difference!)
- (let ((lists (filter pair? lists))) ; Throw out empty lists.
- (cond ((null? lists) lis1) ; Short cut
- ((memq lis1 lists) '()) ; Short cut
- (else (filter! (lambda (x)
- (every (lambda (lis) (not (member x lis =)))
- lists))
- lis1)))))
-
-
-(define (lset-xor = . lists)
- (check-arg procedure? = lset-xor)
- (reduce (lambda (b a) ; Compute A xor B:
- ;; Note that this code relies on the constant-time
- ;; short-cuts provided by LSET-DIFF+INTERSECTION,
- ;; LSET-DIFFERENCE & APPEND to provide constant-time short
- ;; cuts for the cases A = (), B = (), and A eq? B. It takes
- ;; a careful case analysis to see it, but it's carefully
- ;; built in.
-
- ;; Compute a-b and a^b, then compute b-(a^b) and
- ;; cons it onto the front of a-b.
- (receive (a-b a-int-b) (lset-diff+intersection = a b)
- (cond ((null? a-b) (lset-difference b a =))
- ((null? a-int-b) (append b a))
- (else (fold (lambda (xb ans)
- (if (member xb a-int-b =) ans (cons xb ans)))
- a-b
- b)))))
- '() lists))
-
-
-(define (lset-xor! = . lists)
- (check-arg procedure? = lset-xor!)
- (reduce (lambda (b a) ; Compute A xor B:
- ;; Note that this code relies on the constant-time
- ;; short-cuts provided by LSET-DIFF+INTERSECTION,
- ;; LSET-DIFFERENCE & APPEND to provide constant-time short
- ;; cuts for the cases A = (), B = (), and A eq? B. It takes
- ;; a careful case analysis to see it, but it's carefully
- ;; built in.
-
- ;; Compute a-b and a^b, then compute b-(a^b) and
- ;; cons it onto the front of a-b.
- (receive (a-b a-int-b) (lset-diff+intersection! = a b)
- (cond ((null? a-b) (lset-difference! b a =))
- ((null? a-int-b) (append! b a))
- (else (pair-fold (lambda (b-pair ans)
- (if (member (car b-pair) a-int-b =) ans
- (begin (set-cdr! b-pair ans) b-pair)))
- a-b
- b)))))
- '() lists))
-
-
-(define (lset-diff+intersection = lis1 . lists)
- (check-arg procedure? = lset-diff+intersection)
- (cond ((every null-list? lists) (values lis1 '())) ; Short cut
- ((memq lis1 lists) (values '() lis1)) ; Short cut
- (else (partition (lambda (elt)
- (not (any (lambda (lis) (member elt lis =))
- lists)))
- lis1))))
-
-(define (lset-diff+intersection! = lis1 . lists)
- (check-arg procedure? = lset-diff+intersection!)
- (cond ((every null-list? lists) (values lis1 '())) ; Short cut
- ((memq lis1 lists) (values '() lis1)) ; Short cut
- (else (partition! (lambda (elt)
- (not (any (lambda (lis) (member elt lis =))
- lists)))
- lis1))))
43 srfi/11.scm
View
@@ -1,43 +0,0 @@
-;; Copyright (C) Lars T Hansen (1999). All Rights Reserved.
-;; This code is in the public domain.
-
-;;
-;; Adapted to Blackhole for Gambit by Álvaro Castro-Castilla
-;; (no changes needed from reference implementation)
-
-(compile-options no-global-state: #t)
-
-(define-syntax let-values
- (syntax-rules ()
- ((let-values (?binding ...) ?body0 ?body1 ...)
- (let-values "bind" (?binding ...) () (begin ?body0 ?body1 ...)))
-
- ((let-values "bind" () ?tmps ?body)
- (let ?tmps ?body))
-
- ((let-values "bind" ((?b0 ?e0) ?binding ...) ?tmps ?body)
- (let-values "mktmp" ?b0 ?e0 () (?binding ...) ?tmps ?body))
-
- ((let-values "mktmp" () ?e0 ?args ?bindings ?tmps ?body)
- (call-with-values
- (lambda () ?e0)
- (lambda ?args
- (let-values "bind" ?bindings ?tmps ?body))))
-
- ((let-values "mktmp" (?a . ?b) ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
- (let-values "mktmp" ?b ?e0 (?arg ... x) ?bindings (?tmp ... (?a x)) ?body))
-
- ((let-values "mktmp" ?a ?e0 (?arg ...) ?bindings (?tmp ...) ?body)
- (call-with-values
- (lambda () ?e0)
- (lambda (?arg ... . x)
- (let-values "bind" ?bindings (?tmp ... (?a x)) ?body))))))
-
-(define-syntax let*-values
- (syntax-rules ()
- ((let*-values () ?body0 ?body1 ...)
- (begin ?body0 ?body1 ...))
-
- ((let*-values (?binding0 ?binding1 ...) ?body0 ?body1 ...)
- (let-values (?binding0)
- (let*-values (?binding1 ...) ?body0 ?body1 ...)))))
2,040 srfi/13.scm
View
@@ -1,2040 +0,0 @@
-(compile-options no-global-state: #t)
-(import |14|
- ../misc/optionals)
-
-(define (check-arg pred val proc)
- (if (pred val) val (error "Bad arg" val pred proc)))
-
-;;; 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=? char<? char-ci<?
-;;; char-upcase char-downcase
-;;; char->integer (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 (char-cased? chr)
- ;; This is a quick and dirty implementation
- (not
- (and (eq? chr (char-upcase chr))
- (eq? chr (char-downcase chr)))))
-
-(define (char-titlecase chr)
- ;; This is only correct in ASCII
- (char-upcase chr))
-
-(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
- (let ((end (:optional maybe-end slen)))
- (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<? (string-ref s1 (+ start1 match))
- (string-ref s2 (+ start2 match)))
- proc< proc>))
- (+ 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<? (string-ref s1 (+ start1 match))
- (string-ref s2 (+ start2 match)))
- proc< proc>))
- (+ 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