Permalink
Browse files

initial checkin

  • Loading branch information...
0 parents commit 2c3d015862c5caa871d53a0e9f4f310714f7d3f6 @dharmatech committed Mar 20, 2010
Showing with 33,675 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
  136. +943 −0 tests/testing.sps
  137. +251 −0 tests/time.sps
  138. +10 −0 tests/tmp1
  139. +500 −0 tests/vectors.sps
@@ -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.
@@ -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))))
+)
@@ -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"))
+)
@@ -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)))))))])))
+)
@@ -0,0 +1,11 @@
+
+(library (surfage private include compat)
+
+ (export search-paths)
+
+ (import (chezscheme))
+
+ (define (search-paths)
+ (map car (library-directories)))
+
+ )
@@ -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))
+)
@@ -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))))
+
+)
@@ -0,0 +1,10 @@
+(library (surfage private include compat)
+ (export
+ search-paths)
+ (import
+ (rnrs base)
+ (only (mosh) library-path))
+
+ (define (search-paths)
+ (library-path))
+)
@@ -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))))
+)
@@ -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))
+)
@@ -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
+
+)
Oops, something went wrong.

0 comments on commit 2c3d015

Please sign in to comment.