Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial checkin

  • Loading branch information...
commit 2c3d015862c5caa871d53a0e9f4f310714f7d3f6 0 parents
@dharmatech authored
Showing with 31,971 additions and 0 deletions.
  1. +32 −0 LICENSE
  2. +25 −0 private/OS-id-features.sls
  3. +53 −0 private/feature-cond.sls
  4. +51 −0 private/include.sls
  5. +11 −0 private/include/compat.chezscheme.sls
  6. +16 −0 private/include/compat.ikarus.sls
  7. +22 −0 private/include/compat.larceny.sls
  8. +10 −0 private/include/compat.mosh.sls
  9. +19 −0 private/include/compat.mzscheme.sls
  10. +16 −0 private/include/compat.ypsilon.sls
  11. +129 −0 private/let-opt.sls
  12. +54 −0 private/make-aliased-libraries.sps
  13. +23 −0 private/platform-features.chezscheme.sls
  14. +30 −0 private/platform-features.ikarus.sls
  15. +30 −0 private/platform-features.larceny.sls
  16. +32 −0 private/platform-features.mzscheme.sls
  17. +29 −0 private/platform-features.ypsilon.sls
  18. +103 −0 private/registry.sls
  19. +43 −0 private/vanish.sls
  20. +51 −0 s0/cond-expand.sls
  21. +1,142 −0 s1/lists.sls
  22. +14 −0 s11/let-values.sls
  23. +2,019 −0 s13/srfi-13.scm
  24. +82 −0 s13/strings.sls
  25. +67 −0 s14/char-sets.sls
  26. +806 −0 s14/srfi-14.scm
  27. +13 −0 s16/case-lambda.sls
  28. +1,476 −0 s19/srfi-19.scm
  29. +58 −0 s19/time.sls
  30. +26 −0 s19/time/compat.chezscheme.sls
  31. +24 −0 s19/time/compat.ikarus.sls
  32. +43 −0 s19/time/compat.larceny.sls
  33. +43 −0 s19/time/compat.mosh.sls
  34. +35 −0 s19/time/compat.mzscheme.sls
  35. +24 −0 s19/time/compat.ypsilon.sls
  36. +46 −0 s2/and-let*.larceny.sls
  37. +46 −0 s2/and-let.sls
  38. +16 −0 s23/error.sls
  39. +43 −0 s23/error/tricks.sls
  40. +540 −0 s25/arlib.scm
  41. +641 −0 s25/array.scm
  42. +77 −0 s25/ix-ctor.scm
  43. +837 −0 s25/list.scm
  44. +22 −0 s25/multi-dimensional-arrays.sls
  45. +95 −0 s25/multi-dimensional-arrays/all.sls
  46. +40 −0 s25/multi-dimensional-arrays/arlib.sls
  47. +645 −0 s25/op-ctor.scm
  48. +457 −0 s25/test.scm
  49. +96 −0 s26/cut.scm
  50. +13 −0 s26/cut.sls
  51. +30 −0 s27/random-bits.sls
  52. +584 −0 s27/random.ss
  53. +67 −0 s27/readme
  54. +20 −0 s31/rec.sls
  55. +46 −0 s37/args-fold.sls
  56. +222 −0 s37/srfi-37-reference.scm
  57. +30 −0 s38/with-shared-structure.chezscheme.sls
  58. +30 −0 s38/with-shared-structure.ikarus.sls
  59. +4,065 −0 s38/with-shared-structure.larceny.sls
  60. +15 −0 s38/with-shared-structure.ypsilon.sls
  61. +13 −0 s39/parameters.ikarus.sls
  62. +14 −0 s39/parameters.mzscheme.sls
  63. +51 −0 s39/parameters.sls
  64. +12 −0 s39/parameters.ypsilon.sls
  65. +34 −0 s41/streams.sls
  66. +382 −0 s41/streams/derived.sls
  67. +91 −0 s41/streams/primitive.sls
  68. +1,069 −0 s42/_eager-comprehensions-a.sls
  69. +26 −0 s42/_eager-comprehensions.sls
  70. +371 −0 s42/design.scm
  71. +1,069 −0 s42/eager-comprehensions.sls
  72. +1,039 −0 s42/ec.scm
  73. +180 −0 s42/extension.scm
  74. +100 −0 s42/timing.scm
  75. +1,402 −0 s43/_vectors-a.sls
  76. +73 −0 s43/_vectors.sls
  77. +1,316 −0 s43/vector-lib.scm
  78. +73 −0 s43/vectors.sls
  79. +433 −0 s48/intermediate-format-strings.sls
  80. +9 −0 s48/intermediate-format-strings/compat.chezscheme.sls
  81. +12 −0 s48/intermediate-format-strings/compat.ikarus.sls
  82. +12 −0 s48/intermediate-format-strings/compat.larceny.sls
  83. +13 −0 s48/intermediate-format-strings/compat.mzscheme.sls
  84. +12 −0 s48/intermediate-format-strings/compat.ypsilon.sls
  85. +43 −0 s6/basic-string-ports.mzscheme.sls
  86. +20 −0 s6/basic-string-ports.sls
  87. +6 −0 s6/basic-string-ports/compat.chezscheme.sls
  88. +11 −0 s6/basic-string-ports/compat.ikarus.sls
  89. +13 −0 s6/basic-string-ports/compat.larceny.sls
  90. +32 −0 s6/basic-string-ports/compat.mosh.sls
  91. +15 −0 s6/basic-string-ports/compat.ypsilon.sls
  92. +30 −0 s61/cond.sls
  93. +993 −0 s64/testing.scm
  94. +74 −0 s64/testing.sls
  95. +745 −0 s67/_compare-procedures.sls
  96. +759 −0 s67/compare-procedures.sls
  97. +710 −0 s67/compare.ss
  98. +153 −0 s69/basic-hash-tables.sls
  99. +282 −0 s78/check.scm
  100. +29 −0 s78/lightweight-testing.sls
  101. +9 −0 s78/lightweight-testing/compat.chezscheme.sls
  102. +12 −0 s78/lightweight-testing/compat.ikarus.sls
  103. +12 −0 s78/lightweight-testing/compat.larceny.sls
  104. +13 −0 s78/lightweight-testing/compat.mzscheme.sls
  105. +20 −0 s78/lightweight-testing/compat.ypsilon.sls
  106. +19 −0 s8/receive.sls
  107. +51 −0 s9/records.sls
  108. +5 −0 s98/os-environment-variables.chezscheme.sls
  109. +6 −0 s98/os-environment-variables.ikarus.sls
  110. +81 −0 s98/os-environment-variables.larceny.sls
  111. +37 −0 s98/os-environment-variables.mzscheme.sls
  112. +6 −0 s98/os-environment-variables.ypsilon.sls
  113. +9 −0 s99/records.sls
  114. +33 −0 s99/records/helper.sls
  115. +5 −0 s99/records/inspection.larceny.sls
  116. +66 −0 s99/records/inspection.sls
  117. +4 −0 s99/records/procedural.larceny.sls
  118. +136 −0 s99/records/procedural.sls
  119. +3 −0  s99/records/syntactic.larceny.sls
  120. +247 −0 s99/records/syntactic.sls
  121. +66 −0 tests/and-let.sps
  122. +1,394 −0 tests/compare-procedures.sps
  123. +101 −0 tests/cut.sps
  124. +641 −0 tests/eager-comprehensions.sps
  125. +240 −0 tests/intermediate-format-strings.sps
  126. +88 −0 tests/lightweight-testing.sps
  127. +648 −0 tests/lists.sps
  128. +23 −0 tests/multi-dimensional-arrays--arlib.sps
  129. +497 −0 tests/multi-dimensional-arrays.sps
  130. +31 −0 tests/os-environment-variables.sps
  131. +71 −0 tests/print-ascii.sps
  132. +250 −0 tests/random-conftest.sps
  133. +17 −0 tests/random.sps
  134. +14 −0 tests/rec-factorial.sps
  135. +21 −0 tests/records.sps
Sorry, we could not display the entire diff because it was too big.
32 LICENSE
@@ -0,0 +1,32 @@
+The following license applies to all files written by Derick Eddington,
+unless otherwise stated.
+
+===========================================================================
+ Copyright (c) 2008-2009 Derick Eddington
+
+ Permission is hereby granted, free of charge, to any person obtaining a
+ copy of this software and associated documentation files (the "Software"),
+ to deal in the Software without restriction, including without limitation
+ the rights to use, copy, modify, merge, publish, distribute, sublicense,
+ and/or sell copies of the Software, and to permit persons to whom the
+ Software is furnished to do so, subject to the following conditions:
+
+ The above copyright notice and this permission notice shall be included in
+ all copies or substantial portions of the Software.
+
+ Except as contained in this notice, the name(s) of the above copyright
+ holders shall not be used in advertising or otherwise to promote the sale,
+ use or other dealings in this Software without prior written authorization.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+ THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ DEALINGS IN THE SOFTWARE.
+===========================================================================
+
+
+Files written by others retain any copyright, license, and/or other notice
+they originally had.
25 private/OS-id-features.sls
@@ -0,0 +1,25 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+#!r6rs
+(library (surfage private OS-id-features)
+ (export
+ OS-id-features)
+ (import
+ (rnrs))
+
+ (define (OS-id-features OS-id features-alist)
+ (define OS-id-len (string-length OS-id))
+ (define (OS-id-contains? str)
+ (define str-len (string-length str))
+ (let loop ((i 0))
+ (and (<= (+ i str-len) OS-id-len)
+ (or (string-ci=? str (substring OS-id i (+ i str-len)))
+ (loop (+ 1 i))))))
+ (apply append
+ (map cdr (filter (lambda (x) (OS-id-contains? (car x)))
+ features-alist))))
+)
53 private/feature-cond.sls
@@ -0,0 +1,53 @@
+#!r6rs
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+(library (surfage private feature-cond)
+ (export
+ feature-cond)
+ (import
+ (rnrs)
+ (surfage private registry))
+
+ (define-syntax feature-cond
+ (lambda (stx)
+ (define (identifier?/name=? x n)
+ (and (identifier? x)
+ (symbol=? n (syntax->datum x))))
+ (define (make-test t)
+ (define (invalid-test)
+ (syntax-violation #F "invalid test syntax" stx t))
+ (syntax-case t ()
+ ((c x ...)
+ (identifier?/name=? (syntax c) (quote and))
+ (cons (syntax and) (map make-test (syntax (x ...)))))
+ ((c x ...)
+ (identifier?/name=? (syntax c) (quote or))
+ (cons (syntax or) (map make-test (syntax (x ...)))))
+ ((c x ...)
+ (identifier?/name=? (syntax c) (quote not))
+ (if (= 1 (length (syntax (x ...))))
+ (list (syntax not) (make-test (car (syntax (x ...)))))
+ (invalid-test)))
+ (datum
+ (not (and (identifier? (syntax datum))
+ (memq (syntax->datum (syntax datum))
+ (quote (and or not else)))))
+ (syntax (and (member (quote datum) available-features) #T)))
+ (_ (invalid-test))))
+ (syntax-case stx ()
+ ((_ (test . exprs) ... (e . eexprs))
+ (identifier?/name=? (syntax e) (quote else))
+ (with-syntax (((clause ...)
+ (map cons (map make-test (syntax (test ...)))
+ (syntax (exprs ...)))))
+ (syntax (cond clause ... (else . eexprs)))))
+ ((kw (test . exprs) ...)
+ (syntax (kw (test . exprs) ... (else (no-clause-true))))))))
+
+ (define (no-clause-true)
+ (assertion-violation (quote feature-cond) "no clause true"))
+)
51 private/include.sls
@@ -0,0 +1,51 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+#!r6rs
+(library (surfage private include)
+ (export
+ include/resolve)
+ (import
+ (rnrs)
+ (for (surfage private include compat) expand))
+
+ (define-syntax include/resolve
+ (lambda (stx)
+ (define (include/lexical-context ctxt filename)
+ (with-exception-handler
+ (lambda (ex)
+ (raise
+ (condition
+ (make-error)
+ (make-who-condition 'include/resolve)
+ (make-message-condition "error while trying to include")
+ (make-irritants-condition (list filename))
+ (if (condition? ex) ex (make-irritants-condition (list ex))))))
+ (lambda ()
+ (call-with-input-file filename
+ (lambda (fip)
+ (let loop ([a '()])
+ (let ([x (read fip)])
+ (if (eof-object? x)
+ (cons #'begin (datum->syntax ctxt (reverse a)))
+ (loop (cons x a))))))))))
+ (syntax-case stx ()
+ [(ctxt (lib-path* ...) file-path)
+ (for-all (lambda (s) (and (string? s) (positive? (string-length s))))
+ (syntax->datum #'(lib-path* ... file-path)))
+ (let ([p (apply string-append
+ (map (lambda (ps) (string-append "/" ps))
+ (syntax->datum #'(lib-path* ... file-path))))]
+ [sp (search-paths)])
+ (let loop ([search sp])
+ (if (null? search)
+ (error 'include/resolve "cannot find file in search paths"
+ (substring p 1 (string-length p)) sp)
+ (let ([full (string-append (car search) p)])
+ (if (file-exists? full)
+ (include/lexical-context #'ctxt full)
+ (loop (cdr search)))))))])))
+)
11 private/include/compat.chezscheme.sls
@@ -0,0 +1,11 @@
+
+(library (surfage private include compat)
+
+ (export search-paths)
+
+ (import (chezscheme))
+
+ (define (search-paths)
+ (map car (library-directories)))
+
+ )
16 private/include/compat.ikarus.sls
@@ -0,0 +1,16 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+(library (surfage private include compat)
+ (export
+ search-paths)
+ (import
+ (rnrs base)
+ (only (ikarus) library-path))
+
+ (define (search-paths)
+ (library-path))
+)
22 private/include/compat.larceny.sls
@@ -0,0 +1,22 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+(library (surfage private include compat)
+ (export
+ search-paths)
+ (import
+ (rnrs base)
+ (primitives current-require-path getenv absolute-path-string?))
+
+ (define (search-paths)
+ (let ([larceny-root (getenv "LARCENY_ROOT")])
+ (map (lambda (crp)
+ (if (absolute-path-string? crp)
+ crp
+ (string-append larceny-root "/" crp)))
+ (current-require-path))))
+
+)
10 private/include/compat.mosh.sls
@@ -0,0 +1,10 @@
+(library (surfage private include compat)
+ (export
+ search-paths)
+ (import
+ (rnrs base)
+ (only (mosh) library-path))
+
+ (define (search-paths)
+ (library-path))
+)
19 private/include/compat.mzscheme.sls
@@ -0,0 +1,19 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+#!r6rs
+(library (surfage private include compat)
+ (export
+ search-paths)
+ (import
+ (rnrs base)
+ (only (scheme base) current-library-collection-paths path->string)
+ (only (scheme mpair) list->mlist))
+
+ (define (search-paths)
+ (map path->string
+ (list->mlist (current-library-collection-paths))))
+)
16 private/include/compat.ypsilon.sls
@@ -0,0 +1,16 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+(library (surfage private include compat)
+ (export
+ search-paths)
+ (import
+ (rnrs base)
+ (only (core) scheme-library-paths))
+
+ (define (search-paths)
+ (scheme-library-paths))
+)
129 private/let-opt.sls
@@ -0,0 +1,129 @@
+#!r6rs
+;;; LET-OPTIONALS macros
+;;; Copyright (c) 2001 by Olin Shivers.
+
+;;; Copyright (c) 1993-2003 Richard Kelsey and Jonathan Rees
+;;; Copyright (c) 1994-2003 by Olin Shivers and Brian D. Carlstrom.
+;;; Copyright (c) 1999-2003 by Martin Gasbichler.
+;;; Copyright (c) 2001-2003 by Michael Sperber.
+;;;
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the authors may not be used to endorse or promote products
+;;; derived from this software without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; Made into an R6RS library by Derick Eddington.
+
+(library (surfage private let-opt)
+ (export
+ let-optionals* :optional)
+ (import
+ (rnrs))
+
+;;; (:optional rest-arg default-exp [test-pred])
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This form is for evaluating optional arguments and their defaults
+;;; in simple procedures that take a *single* optional argument. It is
+;;; a macro so that the default will not be computed unless it is needed.
+;;;
+;;; REST-ARG is a rest list from a lambda -- e.g., R in
+;;; (lambda (a b . r) ...)
+;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
+;;; - If REST-ARG has 1 element, return that element.
+;;; - If REST-ARG has >1 element, error.
+;;;
+;;; If there is an TEST-PRED form, it is a predicate that is used to test
+;;; a non-default value. If the predicate returns false, an error is raised.
+
+(define-syntax :optional
+ (syntax-rules ()
+ ([_ rest default-exp]
+ (let ((maybe-arg rest))
+ (if (pair? maybe-arg)
+ (if (null? (cdr maybe-arg)) (car maybe-arg)
+ (error ':optional "too many optional arguments" maybe-arg))
+ default-exp)))
+ ([_ rest default-exp arg-test]
+ (let ((maybe-arg rest))
+ (if (pair? maybe-arg)
+ (if (null? (cdr maybe-arg))
+ (let ((val (car maybe-arg)))
+ (if (arg-test val) val
+ (error ':optional "optional argument failed test" val)))
+ (error ':optional "too many optional arguments" maybe-arg))
+ default-exp)))))
+ ; erutcurts-enifed
+
+;;; Here is a simpler but less-efficient version of LET-OPTIONALS*.
+;;; It redundantly performs end-of-list checks for every optional var,
+;;; even after the list runs out.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax let-optionals*
+ (syntax-rules ()
+ ((let-optionals* arg (opt-clause ...) body ...)
+ (let ((rest arg))
+ (%let-optionals* rest (opt-clause ...) body ...)))))
+
+;;; The arg-list expression *must* be a variable.
+;;; (Or must be side-effect-free, in any event.)
+
+(define-syntax %let-optionals*
+ (syntax-rules ()
+ ((%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...)
+ (call-with-values (lambda () (xparser arg))
+ (lambda (rest var ...)
+ (%let-optionals* rest (opt-clause ...) body ...))))
+
+ ((%let-optionals* arg ((var default) opt-clause ...) body ...)
+ (call-with-values (lambda () (if (null? arg) (values default '())
+ (values (car arg) (cdr arg))))
+ (lambda (var rest)
+ (%let-optionals* rest (opt-clause ...) body ...))))
+
+ ((%let-optionals* arg ((var default test) opt-clause ...) body ...)
+ (call-with-values (lambda ()
+ (if (null? arg) (values default '())
+ (let ((var (car arg)))
+ (if test (values var (cdr arg))
+ (error 'let-optionals* "arg failed LET-OPT test" var)))))
+ (lambda (var rest)
+ (%let-optionals* rest (opt-clause ...) body ...))))
+
+ ((%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...)
+ (call-with-values (lambda ()
+ (if (null? arg) (values default #f '())
+ (let ((var (car arg)))
+ (if test (values var #t (cdr arg))
+ (error 'let-optionals* "arg failed LET-OPT test" var)))))
+ (lambda (var supplied? rest)
+ (%let-optionals* rest (opt-clause ...) body ...))))
+
+ ((%let-optionals* arg (rest) body ...)
+ (let ((rest arg)) body ...))
+
+ ((%let-optionals* arg () body ...)
+ (if (null? arg) (begin body ...)
+ (error 'let-optionals* "too many arguments in let-opt" arg)))))
+; erutcurts-enifed
+
+)
54 private/make-aliased-libraries.sps
@@ -0,0 +1,54 @@
+#!r6rs
+(import
+ (rnrs)
+ (only (srfi private registry) available-features)
+ (only (xitomatl lists) map/filter)
+ (only (xitomatl match) match-lambda)
+ (only (xitomatl common) format fprintf printf)
+ (only (xitomatl strings) string-intersperse)
+ (only (xitomatl predicates) symbol<?)
+ (only (xitomatl environments) environment environment-symbols))
+
+(define srfi-libraries/mnemonics
+ (map/filter (match-lambda
+ ;; NOTE: Uses only the 3-element names.
+ ((:and ('srfi (:symbol ":(\\d+)" num) _)
+ name)
+ (list (string->number (symbol->string num))
+ name))
+ (_ #F))
+ available-features))
+
+(define alias-template
+";; Automatically generated by ~a
+#!r6rs
+(library ~s
+ (export
+ ~a)
+ (import ~s)
+)
+")
+
+(define program-name (car (command-line)))
+
+(for-each
+ (lambda (x)
+ (let* ((srfi-num (car x))
+ (lib-name (cadr x))
+ (exports (list-sort symbol<?
+ (environment-symbols (environment lib-name))))
+ (alias-name `(srfi ,(string->symbol (format ":~d" srfi-num))))
+ (out-file (format "~d.sls" srfi-num)))
+ (cond
+ ((file-exists? out-file)
+ (printf "Skipping ~a because it already exists.\n" out-file))
+ (else
+ (call-with-output-file out-file
+ (lambda (fop)
+ (fprintf fop alias-template
+ program-name
+ alias-name
+ (string-intersperse (map symbol->string exports) "\n ")
+ lib-name)))
+ (printf "~a\n" out-file)))))
+ srfi-libraries/mnemonics)
23 private/platform-features.chezscheme.sls
@@ -0,0 +1,23 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+(library (surfage private platform-features)
+ (export
+ OS-features
+ implementation-features)
+ (import
+ (rnrs)
+ (only (chezscheme) machine-type)
+ (surfage private OS-id-features))
+
+ (define (OS-features)
+ (OS-id-features
+ (symbol->string (machine-type))
+ '(("i3la" linux posix))))
+
+ (define (implementation-features)
+ '(chezscheme))
+)
30 private/platform-features.ikarus.sls
@@ -0,0 +1,30 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+(library (surfage private platform-features)
+ (export
+ OS-features
+ implementation-features)
+ (import
+ (rnrs)
+ (only (ikarus) host-info)
+ (surfage private OS-id-features))
+
+ (define (OS-features)
+ (OS-id-features
+ (host-info)
+ '(("linux" linux posix)
+ ("solaris" solaris posix)
+ ("darwin" darwin posix)
+ ("bsd" bsd)
+ ("freebsd" freebsd posix)
+ ("openbsd" openbsd posix)
+ ("cygwin" cygwin posix) ;; correct?
+ ("gnu" gnu))))
+
+ (define (implementation-features)
+ '(ikarus))
+)
30 private/platform-features.larceny.sls
@@ -0,0 +1,30 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+(library (surfage private platform-features)
+ (export
+ OS-features
+ implementation-features)
+ (import
+ (rnrs base)
+ (rnrs lists)
+ (primitives system-features)
+ (surfage private OS-id-features))
+
+ (define (OS-features)
+ (OS-id-features
+ (cdr (assq 'os-name (system-features)))
+ '(("linux" linux posix)
+ ("solaris" solaris posix)
+ ("darwin" darwin posix)
+ ("bsd" bsd)
+ ("freebsd" freebsd posix)
+ ("openbsd" openbsd posix)
+ ("windows" windows))))
+
+ (define (implementation-features)
+ '(larceny))
+)
32 private/platform-features.mzscheme.sls
@@ -0,0 +1,32 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+#!r6rs
+(library (surfage private platform-features)
+ (export
+ OS-features
+ implementation-features)
+ (import
+ (rnrs)
+ (only (scheme base) system-type)
+ (surfage private OS-id-features))
+
+ (define (OS-features)
+ (OS-id-features
+ (string-append (symbol->string (system-type 'os))
+ " " (system-type 'machine))
+ '(("linux" linux posix)
+ ("macosx" mac-os-x darwin posix)
+ ("solaris" solaris posix)
+ ("gnu" gnu)
+ ("bsd" bsd)
+ ("freebsd" freebsd posix)
+ ("openbsd" openbsd posix)
+ ("windows" windows))))
+
+ (define (implementation-features)
+ '(mzscheme))
+)
29 private/platform-features.ypsilon.sls
@@ -0,0 +1,29 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+(library (surfage private platform-features)
+ (export
+ OS-features
+ implementation-features)
+ (import
+ (rnrs)
+ (only (core) architecture-feature)
+ (surfage private OS-id-features))
+
+ (define (OS-features)
+ (OS-id-features
+ (architecture-feature 'operating-system)
+ '(("linux" linux posix)
+ ("solaris" solaris posix)
+ ("darwin" darwin posix)
+ ("bsd" bsd)
+ ("freebsd" freebsd posix)
+ ("openbsd" openbsd posix)
+ ("windows" windows))))
+
+ (define (implementation-features)
+ '(ypsilon))
+)
103 private/registry.sls
@@ -0,0 +1,103 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+#!r6rs
+(library (surfage private registry)
+ (export
+ available-features)
+ (import
+ (rnrs)
+ (surfage private platform-features))
+
+ (define available-features
+ (let-syntax
+ ((SRFI-features
+ (lambda (stx)
+ (define SRFIs
+ '((0 cond-expand)
+ (1 lists)
+ (2 and-let*)
+ #;(5 let)
+ (6 basic-string-ports)
+ (8 receive)
+ (9 records)
+ (11 let-values)
+ (13 strings)
+ (14 char-sets)
+ (16 case-lambda)
+ #;(17 generalized-set!)
+ #;(18 multithreading)
+ (19 time)
+ #;(21 real-time-multithreading)
+ (23 error)
+ (25 multi-dimensional-arrays)
+ (26 cut)
+ (27 random-bits)
+ #;(28 basic-format-strings)
+ #;(29 localization)
+ (31 rec)
+ (37 args-fold)
+ (38 with-shared-structure)
+ (39 parameters)
+ (41 streams)
+ (42 eager-comprehensions)
+ (43 vectors)
+ #;(44 collections)
+ #;(45 lazy)
+ #;(46 syntax-rules)
+ #;(47 arrays)
+ (48 intermediate-format-strings)
+ #;(51 rest-values)
+ #;(54 cat)
+ #;(57 records)
+ #;(59 vicinities)
+ #;(60 integer-bits)
+ (61 cond)
+ #;(63 arrays)
+ (64 testing)
+ #;(66 octet-vectors)
+ (67 compare-procedures)
+ (69 basic-hash-tables)
+ #;(71 let)
+ #;(74 blobs)
+ (78 lightweight-testing)
+ #;(86 mu-and-nu)
+ #;(87 case)
+ #;(95 sorting-and-merging)
+ (98 os-environment-variables)
+ (99 records)))
+ (define (make-feature-names x)
+ (define number car)
+ (define mnemonic cdr)
+ (define (make-symbol . args)
+ (string->symbol (apply string-append
+ (map (lambda (a)
+ (if (symbol? a)
+ (symbol->string a)
+ a))
+ args))))
+ (let* ((n-str (number->string (number x)))
+ (colon-n (make-symbol ":" n-str))
+ (srfi-n (make-symbol "srfi-" n-str))
+ (srfi-n-m (apply make-symbol srfi-n
+ (map (lambda (m) (make-symbol "-" m))
+ (mnemonic x)))))
+ ;; The first two are recommended by SRFI-97.
+ ;; The last two are the two types of SRFI-97 library name.
+ (list srfi-n
+ srfi-n-m
+ `(srfi ,colon-n)
+ `(srfi ,colon-n . ,(mnemonic x)))))
+ (syntax-case stx ()
+ ((kw)
+ #`(quote #,(datum->syntax #'kw
+ (apply append (map make-feature-names SRFIs)))))))))
+ `(,@(OS-features)
+ ,@(implementation-features)
+ ,@(SRFI-features)
+ r6rs)))
+
+)
43 private/vanish.sls
@@ -0,0 +1,43 @@
+#!r6rs
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+(library (surfage private vanish)
+ (export
+ vanish-define)
+ (import
+ (rnrs)
+ (for (only (rnrs base) begin) (meta -1)))
+
+ #;(define (show stx)
+ (display (make-string 60 #\-)) (newline)
+ (write (syntax->datum stx)) (newline))
+
+ (define-syntax vanish-define
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ def (vanish ...))
+ (for-all identifier? #'(vanish ...))
+ #'(make-vanish-define (syntax def) (syntax vanish) ...)))))
+
+ (define (make-vanish-define def . to-vanish)
+ (lambda (stx)
+ (define (vanish? id)
+ (memp (lambda (x) (free-identifier=? id x))
+ to-vanish))
+ #;(show stx)
+ (syntax-case stx ()
+ ((_ name . _)
+ (and (identifier? #'name)
+ (vanish? #'name))
+ #'(begin))
+ ((_ (name . _) . _)
+ (and (identifier? #'name)
+ (vanish? #'name))
+ #'(begin))
+ ((_ . r)
+ (cons def #'r)))))
+)
51 s0/cond-expand.sls
@@ -0,0 +1,51 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+#!r6rs
+(library (surfage s0 cond-expand)
+ (export
+ cond-expand)
+ (import
+ (rnrs)
+ (for (surfage private registry) expand))
+
+ (define-syntax cond-expand
+ (lambda (stx)
+ (syntax-case stx (and or not else)
+ [(_)
+ (syntax-violation #f "Unfulfilled cond-expand" stx)]
+ [(_ (else body ...))
+ #'(begin body ...)]
+ [(_ ((and) body ...) more-clauses ...)
+ #'(begin body ...)]
+ [(_ ((and req1 req2 ...) body ...) more-clauses ...)
+ #'(cond-expand
+ (req1
+ (cond-expand
+ ((and req2 ...) body ...)
+ more-clauses ...))
+ more-clauses ...)]
+ [(_ ((or) body ...) more-clauses ...)
+ #'(cond-expand more-clauses ...)]
+ [(_ ((or req1 req2 ...) body ...) more-clauses ...)
+ #'(cond-expand
+ (req1
+ (begin body ...))
+ (else
+ (cond-expand
+ ((or req2 ...) body ...)
+ more-clauses ...)))]
+ [(_ ((not req) body ...) more-clauses ...)
+ #'(cond-expand
+ (req
+ (cond-expand more-clauses ...))
+ (else body ...))]
+ [(_ (feature-id body ...) more-clauses ...)
+ (if (member (syntax->datum #'feature-id) available-features)
+ #'(begin body ...)
+ #'(cond-expand more-clauses ...))])))
+
+)
1,142 s1/lists.sls
@@ -0,0 +1,1142 @@
+#!r6rs
+
+;; 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
+
+;; Ikarus porting begun by Abdulaziz Ghuloum,
+;; and continued by Derick Eddington.
+
+(library (surfage s1 lists)
+ (export
+ xcons make-list list-tabulate list-copy
+ proper-list? circular-list? dotted-list? not-pair? null-list? list=
+ circular-list length+
+ iota
+ first second third fourth fifth sixth seventh eighth ninth tenth
+ car+cdr
+ take drop
+ take-right drop-right
+ take! drop-right!
+ split-at split-at!
+ last last-pair
+ zip unzip1 unzip2 unzip3 unzip4 unzip5
+ count
+ append! append-reverse append-reverse! concatenate concatenate!
+ unfold fold pair-fold reduce
+ unfold-right pair-fold-right reduce-right
+ append-map append-map! map! pair-for-each filter-map map-in-order
+ filter! partition! remove!
+ find-tail any every list-index
+ take-while drop-while take-while!
+ span break span! break!
+ delete delete!
+ alist-cons alist-copy
+ delete-duplicates delete-duplicates!
+ alist-delete alist-delete!
+ reverse!
+ lset<= lset= lset-adjoin
+ lset-union lset-intersection lset-difference lset-xor
+ lset-diff+intersection
+ lset-union! lset-intersection! lset-difference! lset-xor!
+ lset-diff+intersection!
+ ;; re-exported:
+ append assq assv caaaar caaadr caaar caadar caaddr
+ caadr caar cadaar cadadr cadar caddar cadddr caddr cadr
+ car cdaaar cdaadr cdaar cdadar cdaddr cdadr cdar cddaar
+ cddadr cddar cdddar cddddr cdddr cddr cdr cons cons*
+ length list list-ref memq memv null? pair?
+ reverse set-car! set-cdr!
+ ;; different than R6RS:
+ assoc filter find fold-right for-each map member partition remove)
+ (import
+ (except (rnrs)
+ assoc error filter find fold-right
+ for-each map member partition remove)
+ (rnrs mutable-pairs))
+
+ (define-syntax check-arg
+ (lambda (stx)
+ (syntax-case stx ()
+ [(_ pred val caller)
+ (and (identifier? #'val) (identifier? #'caller))
+ #'(unless (pred val)
+ (assertion-violation 'caller "check-arg failed" val))])))
+
+ (define (error . args)
+ (if (and (<= 2 (length args)) (symbol? (car args)) (string? (cadr args)))
+ (apply assertion-violation args)
+ (apply assertion-violation "(library (surfage s1 lists))"
+ "misuse of error procedure" args)))
+
+ ;; Constructors
+ ;; ;;;;;;;;;;;;;
+
+ (define (xcons d a) (cons a d))
+
+ (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 'make-list "Too many arguments"
+ (cons len maybe-elt))))))
+ (do ((i len (- i 1))
+ (ans '() (cons elt ans)))
+ ((<= i 0) ans))))
+
+ (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)))
+
+ (define (list-copy lis)
+ (let recur ((lis lis))
+ (if (pair? lis)
+ (cons (car lis) (recur (cdr lis)))
+ lis)))
+
+ (define iota
+ (case-lambda
+ [(count) (iota count 0 1)]
+ [(count start) (iota count start 1)]
+ [(count start step)
+ (check-arg integer? count iota)
+ (if (< count 0) (error 'iota "Negative step count" 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)))]))
+
+ (define (circular-list val1 . vals)
+ (let ((ans (cons val1 vals)))
+ (set-cdr! (last-pair ans) ans)
+ ans))
+
+ (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 (dotted-list? x)
+ (let lp ((x x) (lag x))
+ (if (pair? x)
+ (let ((x (cdr x)))
+ (if (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag)))
+ (and (not (eq? x lag)) (lp x lag)))
+ (not (null? x))))
+ (not (null? x)))))
+
+ (define (circular-list? x)
+ (let lp ((x x) (lag x))
+ (and (pair? x)
+ (let ((x (cdr x)))
+ (and (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag)))
+ (or (eq? x lag) (lp x lag))))))))
+
+ (define (not-pair? x) (not (pair? x))) ; Inline me.
+
+ (define (null-list? l)
+ (cond ((pair? l) #f)
+ ((null? l) #t)
+ (else (error 'null-list? "argument out of domain" l))))
+
+
+ (define (list= elt= . lists)
+ (or (null? lists) ; special case
+ (let lp1 ((list-a (car lists)) (others (cdr lists)))
+ (or (null? others)
+ (let ((list-b-orig (car others))
+ (others (cdr others)))
+ (if (eq? list-a list-b-orig) ; EQ? => LIST=
+ (lp1 list-b-orig others)
+ (let lp2 ((list-a list-a) (list-b list-b-orig))
+ (if (null-list? list-a)
+ (and (null-list? list-b)
+ (lp1 list-b-orig others))
+ (and (not (null-list? list-b))
+ (elt= (car list-a) (car list-b))
+ (lp2 (cdr list-a) (cdr list-b)))))))))))
+
+ (define (length+ x) ; Returns #f if X is circular.
+ (let lp ((x x) (lag x) (len 0))
+ (if (pair? x)
+ (let ((x (cdr x))
+ (len (+ len 1)))
+ (if (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag))
+ (len (+ len 1)))
+ (and (not (eq? x lag)) (lp x lag len)))
+ len))
+ len)))
+
+ (define (zip list1 . more-lists) (apply map list list1 more-lists))
+
+
+ ;; Selectors
+ ;; ;;;;;;;;;;
+
+ (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)))
+
+ (define (take lis k)
+ (check-arg integer? k take)
+ (let recur ((lis lis) (k k))
+ (if (zero? k) '()
+ (cons (car lis)
+ (recur (cdr lis) (- k 1))))))
+
+ (define (drop lis k)
+ (check-arg integer? k drop)
+ (let iter ((lis lis) (k k))
+ (if (zero? k) lis (iter (cdr lis) (- k 1)))))
+
+ (define (take! lis k)
+ (check-arg integer? k take!)
+ (if (zero? k) '()
+ (begin (set-cdr! (drop lis (- k 1)) '())
+ lis)))
+
+ (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)))
+ '())))
+
+ (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-syntax receive
+ (syntax-rules ()
+ [(_ (id* ...) expr body body* ...)
+ (let-values ([(id* ...) expr]) body body* ...)]))
+
+
+ (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)))))))
+
+ (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
+ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+ (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))))
+
+ (define (%cars+cdrs lists)
+ (let f ([ls lists] [a* '()] [d* '()])
+ (cond
+ [(pair? ls)
+ (let ([a (car ls)])
+ (if (pair? a)
+ (f (cdr ls) (cons (car a) a*) (cons (cdr a) d*))
+ (values '() '())))]
+ [else (values (reverse a*) (reverse d*))])))
+
+ (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) '()))))))
+
+ (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
+ (case-lambda
+ [(p f g seed)
+ (unfold-right p f g seed '())]
+ [(p f g seed tail)
+ (check-arg procedure? p unfold-right)
+ (check-arg procedure? f unfold-right)
+ (check-arg procedure? g unfold-right)
+ (let lp ((seed seed) (ans tail))
+ (if (p seed) ans
+ (lp (g seed)
+ (cons (f seed) ans))))]))
+
+
+ (define (unfold 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) ;;; so much for :optional (aghuloum)
+
+ (let ((tail-gen (car maybe-tail-gen)))
+ (if (pair? (cdr maybe-tail-gen))
+ (apply error 'unfold "Too many arguments" 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)
+ (check-arg procedure? f append-map)
+ (really-append-map append f lis1 lists))
+ (define (append-map! f lis1 . lists)
+ (check-arg procedure? f append-map!)
+ (really-append-map append! f lis1 lists))
+
+ (define (really-append-map appender f lis1 lists)
+ (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)
+
+ ;; Contributed by Michael Sperber since it was missing from the
+ ;; reference implementation.
+ (define (for-each f lis1 . lists)
+ (if (pair? lists)
+ (let recur ((lists (cons lis1 lists)))
+ (receive (cars cdrs) (%cars+cdrs lists)
+ (if (pair? cars)
+ (begin
+ (apply f cars) ; Do head first,
+ (recur cdrs))))) ; then tail.
+
+ ;; Fast path.
+ (let recur ((lis lis1))
+ (if (not (null-list? lis))
+ (begin
+ (f (car lis)) ; Do head first,
+ (recur (cdr lis))))))) ; then tail.
+
+ ;; filter, remove, partition
+ ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
+ ;; disorder the elements of their argument.
+
+ ;; This FILTER shares the longest tail of L that has no deleted elements.
+ ;; If Scheme had multi-continuation calls, they could be made more efficient.
+
+ (define (filter pred lis) ; Sleazing with EQ? makes this
+ (check-arg procedure? pred filter) ; one faster.
+ (let recur ((lis lis))
+ (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists.
+ (let ((head (car lis))
+ (tail (cdr lis)))
+ (if (pred head)
+ (let ((new-tail (recur tail))) ; Replicate the RECUR call so
+ (if (eq? tail new-tail) lis
+ (cons head new-tail)))
+ (recur tail)))))) ; this one can be a tail call.
+
+
+ (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.
+ (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)))))
+
+ (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)
+ (check-arg procedure? pred partition!)
+ (if (null-list? lis) (values lis 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))
+
+ (define delete
+ (case-lambda
+ [(x lis)
+ (delete x lis equal?)]
+ [(x lis =)
+ (filter (lambda (y) (not (= x y))) lis)]))
+
+ (define delete!
+ (case-lambda
+ [(x lis)
+ (delete! x lis equal?)]
+ [(x lis =)
+ (filter! (lambda (y) (not (= x y))) lis)]))
+
+ ;; Extended from R4RS to take an optional comparison argument.
+ (define member
+ (case-lambda
+ [(x lis)
+ (member x lis equal?)]
+ [(x lis =)
+ (find-tail (lambda (y) (= x y)) lis)]))
+
+ (define delete-duplicates
+ (case-lambda
+ [(lis)
+ (delete-duplicates lis equal?)]
+ [(lis elt=)
+ (check-arg procedure? elt= delete-duplicates)
+ (let recur ((lis lis))
+ (if (null-list? lis) lis
+ (let* ((x (car lis))
+ (tail (cdr lis))
+ (new-tail (recur (delete x tail elt=))))
+ (if (eq? tail new-tail) lis (cons x new-tail)))))]))
+
+ (define delete-duplicates!
+ (case-lambda
+ [(lis)
+ (delete-duplicates! lis equal?)]
+ [(lis elt=)
+ (check-arg procedure? elt= delete-duplicates!)
+ (let recur ((lis lis))
+ (if (null-list? lis) lis
+ (let* ((x (car lis))
+ (tail (cdr lis))
+ (new-tail (recur (delete! x tail elt=))))
+ (when (not (eq? tail new-tail))
+ (set-cdr! lis new-tail))
+ lis)))]))
+
+
+ ;; alist stuff
+ ;; ;;;;;;;;;;;;
+
+ (define assoc
+ (case-lambda
+ [(x lis)
+ (assoc x lis equal?)]
+ [(x lis =)
+ (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
+ (case-lambda
+ [(key alist)
+ (alist-delete key alist equal?)]
+ [(key alist =)
+ (filter (lambda (elt) (not (= key (car elt)))) alist)]))
+
+ (define alist-delete!
+ (case-lambda
+ [(key alist)
+ (alist-delete! key alist equal?)]
+ [(key alist =)
+ (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
+ (case-lambda
+ [(p ls)
+ (or (null-list? ls)
+ (let f ([p p] [a (car ls)] [d (cdr ls)])
+ (cond
+ [(pair? d)
+ (and (p a) (f p (car d) (cdr d)))]
+ [else (p a)])))]
+ [(p ls1 ls2)
+ (cond
+ [(and (pair? ls1) (pair? ls2))
+ (let f ([p p] [a1 (car ls1)] [d1 (cdr ls1)] [a2 (car ls2)] [d2 (cdr ls2)])
+ (cond
+ [(and (pair? d1) (pair? d2))
+ (and (p a1 a2) (f p (car d1) (cdr d1) (car d2) (cdr d2)))]
+ [else (p a1 a2)]))]
+ [else #t])]
+ [(pred lis1 . lists)
+ (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))))))]))
+
+ (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
+ ;; ;;;;;;;;
+
+ (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
+ ;; ;;;;;;;;;;;;;;
+
+ (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))))
+ ;; end of library
+ )
14 s11/let-values.sls
@@ -0,0 +1,14 @@
+;; Copyright (c) 2009 Derick Eddington. All rights reserved.
+;; Licensed under an MIT-style license. My license is in the file
+;; named LICENSE from the original collection this file is distributed
+;; with. If this file is redistributed with some other collection, my
+;; license must also be included.
+
+#!r6rs
+(library (surfage s11 let-values)
+ (export
+ let-values
+ let*-values)
+ (import
+ (only (rnrs) let-values let*-values))
+)
2,019 s13/srfi-13.scm
@@ -0,0 +1,2019 @@
+;;; 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-syntax let-string-start+end
+ (syntax-rules ()
+ ((let-string-start+end (start end) proc s-exp args-exp body ...)
+ (receive (start end) (string-parse-final-start+end proc s-exp args-exp)
+ body ...))
+ ((let-string-start+end (start end rest) proc s-exp args-exp body ...)
+ (receive (rest start end) (string-parse-start+end proc s-exp args-exp)
+ body ...))))
+
+;;; This one parses out a *pair* of final start/end indices.
+;;; Not exported; for internal use.
+(define-syntax let-string-start+end2
+ (syntax-rules ()
+ ((l-s-s+e2 (start1 end1 start2 end2) proc s1 s2 args body ...)
+ (let ((procv proc)) ; Make sure PROC is only evaluated once.
+ (let-string-start+end (start1 end1 rest) procv s1 args
+ (let-string-start+end (start2 end2) procv s2 rest
+ body ...))))))
+
+
+;;; Returns three values: rest start end
+
+(define (string-parse-start+end proc s args)
+ (if (not (string? s)) (error "Non-string value" proc s))
+ (let ((slen (string-length s)))
+ (if (pair? args)
+
+ (let ((start (car args))
+ (args (cdr args)))
+ (if (and (integer? start) (exact? start) (>= start 0))
+ (receive (end args)
+ (if (pair? args)
+ (let ((end (car args))
+ (args (cdr args)))
+ (if (and (integer? end) (exact? end) (<= end slen))
+ (values end args)
+ (error "Illegal substring END spec" proc end s)))
+ (values slen args))
+ (if (<= start end) (values args start end)
+ (error "Illegal substring START/END spec"
+ proc start end s)))
+ (error "Illegal substring START spec" proc start s)))
+
+ (values '() 0 slen))))
+
+(define (string-parse-final-start+end proc s args)
+ (receive (rest start end) (string-parse-start+end proc s args)
+ (if (pair? rest) (error "Extra arguments to procedure" proc rest)
+ (values start end))))
+
+(define (substring-spec-ok? s start end)
+ (and (string? s)
+ (integer? start)
+ (exact? start)
+ (integer? end)
+ (exact? end)
+ (<= 0 start)
+ (<= start end)
+ (<= end (string-length s))))
+
+(define (check-substring-spec proc s start end)
+ (if (not (substring-spec-ok? s start end))
+ (error "Illegal substring spec." proc s start end)))
+
+
+;;; Defined by R5RS, so commented out here.
+;(define (string . chars)
+; (let* ((len (length chars))
+; (ans (make-string len)))
+; (do ((i 0 (+ i 1))
+; (chars chars (cdr chars)))
+; ((>= i len))
+; (string-set! ans i (car chars)))
+; ans))
+;
+;(define (string . chars) (string-unfold null? car cdr chars))
+
+
+
+;;; substring/shared S START [END]
+;;; string-copy S [START END]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; All this goop is just arg parsing & checking surrounding a call to the
+;;; actual primitive, %SUBSTRING/SHARED.
+
+(define (substring/shared s start . maybe-end)
+ (check-arg string? s substring/shared)
+ (let ((slen (string-length s)))
+ (check-arg (lambda (start) (and (integer? start) (exact? start) (<= 0 start)))
+ start substring/shared)
+ (%substring/shared s start
+ (:optional maybe-end slen
+ (lambda (end) (and (integer? end)
+ (exact? end)
+ (<= start end)
+ (<= end slen)))))))
+
+;;; Split out so that other routines in this library can avoid arg-parsing
+;;; overhead for END parameter.
+(define (%substring/shared s start end)
+ (if (and (zero? start) (= end (string-length s))) s
+ (substring s start end)))
+
+(define (string-copy s . maybe-start+end)
+ (let-string-start+end (start end) string-copy s maybe-start+end
+ (substring s start end)))
+
+;This library uses the R5RS SUBSTRING, but doesn't export it.
+;Here is a definition, just for completeness.
+;(define (substring s start end)
+; (check-substring-spec substring s start end)
+; (let* ((slen (- end start))
+; (ans (make-string slen)))
+; (do ((i 0 (+ i 1))
+; (j start (+ j 1)))
+; ((>= i slen) ans)
+; (string-set! ans i (string-ref s j)))))
+
+;;; Basic iterators and other higher-order abstractions
+;;; (string-map proc s [start end])
+;;; (string-map! proc s [start end])
+;;; (string-fold kons knil s [start end])
+;;; (string-fold-right kons knil s [start end])
+;;; (string-unfold p f g seed [base make-final])
+;;; (string-unfold-right p f g seed [base make-final])
+;;; (string-for-each proc s [start end])
+;;; (string-for-each-index proc s [start end])
+;;; (string-every char-set/char/pred s [start end])
+;;; (string-any char-set/char/pred s [start end])
+;;; (string-tabulate proc len)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; You want compiler support for high-level transforms on fold and unfold ops.
+;;; You'd at least like a lot of inlining for clients of these procedures.
+;;; Don't hold your breath.
+
+(define (string-map proc s . maybe-start+end)
+ (check-arg procedure? proc string-map)
+ (let-string-start+end (start end) string-map s maybe-start+end
+ (%string-map proc s start end)))
+
+(define (%string-map proc s start end) ; Internal utility
+ (let* ((len (- end start))
+ (ans (make-string len)))
+ (do ((i (- end 1) (- i 1))
+ (j (- len 1) (- j 1)))
+ ((< j 0))
+ (string-set! ans j (proc (string-ref s i))))