initial checkin

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.

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))))
+)

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"))
+)

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)))))))])))
+)

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)))
+
+  )

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))
+)

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))))
+
+)

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))
+)

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))))
+)

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))
+)

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
+
+)