├── README └── srfi ├── %3a0.sls ├── %3a0 └── cond-expand.sls ├── %3a1.sls ├── %3a1 ├── %3a1.sls └── lists.sls ├── %3a11.sls ├── %3a11 └── let-values.sls ├── %3a13.sls ├── %3a13 ├── srfi-13.scm └── strings.sls ├── %3a14.sls ├── %3a14 ├── char-sets.sls └── srfi-14.scm ├── %3a16.sls ├── %3a16 └── case-lambda.sls ├── %3a19.sls ├── %3a19 ├── srfi-19.scm ├── time.sls └── time │ ├── compat.chezscheme.sls │ ├── compat.ikarus.sls │ ├── compat.larceny.sls │ ├── compat.mzscheme.sls │ └── compat.ypsilon.sls ├── %3a2.sls ├── %3a2 ├── and-let%2a.sls └── and-let*.larceny.sls ├── %3a23.sls ├── %3a23 ├── error.sls └── error │ └── tricks.sls ├── %3a25.sls ├── %3a25 ├── arlib.scm ├── array.scm ├── ix-ctor.scm ├── list.scm ├── multi-dimensional-arrays.sls ├── multi-dimensional-arrays │ ├── all.sls │ └── arlib.sls ├── op-ctor.scm └── test.scm ├── %3a26.sls ├── %3a26 ├── cut.scm └── cut.sls ├── %3a27.sls ├── %3a27 ├── random-bits.sls ├── random.ss └── readme ├── %3a31.sls ├── %3a31 └── rec.sls ├── %3a37.sls ├── %3a37 ├── args-fold.sls └── srfi-37-reference.scm ├── %3a38.sls ├── %3a38 ├── with-shared-structure.ikarus.sls ├── with-shared-structure.larceny.sls └── with-shared-structure.ypsilon.sls ├── %3a39.sls ├── %3a39 ├── parameters.ikarus.sls ├── parameters.mzscheme.sls ├── parameters.sls └── parameters.ypsilon.sls ├── %3a41.sls ├── %3a41 ├── streams.sls └── streams │ ├── derived.sls │ └── primitive.sls ├── %3a42.sls ├── %3a42 ├── design.scm ├── eager-comprehensions.sls ├── ec.scm ├── extension.scm └── timing.scm ├── %3a43.sls ├── %3a43 ├── vector-lib.scm └── vectors.sls ├── %3a48.sls ├── %3a48 ├── intermediate-format-strings.sls └── intermediate-format-strings │ ├── compat.ikarus.sls │ ├── compat.larceny.sls │ ├── compat.mzscheme.sls │ └── compat.ypsilon.sls ├── %3a6.sls ├── %3a6 ├── basic-string-ports.mzscheme.sls ├── basic-string-ports.sls └── basic-string-ports │ ├── compat.chezscheme.sls │ ├── compat.ikarus.sls │ ├── compat.larceny.sls │ └── compat.ypsilon.sls ├── %3a61.sls ├── %3a61 └── cond.sls ├── %3a64.sls ├── %3a64 ├── testing.scm └── testing.sls ├── %3a67.sls ├── %3a67 ├── compare-procedures.sls └── compare.ss ├── %3a69.sls ├── %3a69 └── basic-hash-tables.sls ├── %3a78.sls ├── %3a78 ├── check.scm ├── lightweight-testing.sls └── lightweight-testing │ ├── compat.ikarus.sls │ ├── compat.larceny.sls │ ├── compat.mzscheme.sls │ └── compat.ypsilon.sls ├── %3a8.sls ├── %3a8 └── receive.sls ├── %3a9.sls ├── %3a9 └── records.sls ├── %3a98.sls ├── %3a98 ├── os-environment-variables.ikarus.sls ├── os-environment-variables.larceny.sls ├── os-environment-variables.mzscheme.sls └── os-environment-variables.ypsilon.sls ├── %3a99.sls ├── %3a99 ├── records.sls └── records │ ├── helper.sls │ ├── inspection.larceny.sls │ ├── inspection.sls │ ├── procedural.larceny.sls │ ├── procedural.sls │ ├── syntactic.larceny.sls │ └── syntactic.sls ├── :0 ├── :0.sls ├── :1 ├── :1.sls ├── :11 ├── :11.sls ├── :13 ├── :13.sls ├── :14 ├── :14.sls ├── :16 ├── :16.sls ├── :19 ├── :19.sls ├── :2 ├── :2.sls ├── :23 ├── :23.sls ├── :25 ├── :25.sls ├── :26 ├── :26.sls ├── :27 ├── :27.sls ├── :31 ├── :31.sls ├── :37 ├── :37.sls ├── :39 ├── :39.sls ├── :41 ├── :41.sls ├── :42 ├── :42.sls ├── :43 ├── :43.sls ├── :6 ├── :6.sls ├── :64 ├── :64.sls ├── :69 ├── :69.sls ├── :8 ├── :8.sls ├── :9 ├── :9.sls ├── LICENSE ├── README ├── compile-all.ikarus.sps ├── private ├── OS-id-features.sls ├── feature-cond.sls ├── include.sls ├── include │ ├── compat.chezscheme.sls │ ├── compat.ikarus.sls │ ├── compat.larceny.sls │ ├── compat.mzscheme.sls │ └── compat.ypsilon.sls ├── let-opt.sls ├── make-aliased-libraries.sps ├── platform-features.chezscheme.sls ├── platform-features.ikarus.sls ├── platform-features.larceny.sls ├── platform-features.mzscheme.sls ├── platform-features.ypsilon.sls ├── registry.sls └── vanish.sls └── tests ├── and-let*.sps ├── compare-procedures.sps ├── cut.sps ├── eager-comprehensions.sps ├── intermediate-format-strings.sps ├── lightweight-testing.sps ├── lists.sps ├── multi-dimensional-arrays--arlib.sps ├── multi-dimensional-arrays.sps ├── os-environment-variables.sps ├── print-ascii.sps ├── random-conftest.sps ├── random.sps ├── rec-factorial.sps ├── records.sps ├── testing.sps ├── time.sps └── vectors.sps /README: -------------------------------------------------------------------------------- 1 | 2 | Add path to 'chez-srfi' to your CHEZSCHEMELIBDIRS. 3 | -------------------------------------------------------------------------------- /srfi/%3a0.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :0) 4 | (export 5 | cond-expand) 6 | (import (srfi :0 cond-expand)) 7 | ) 8 | -------------------------------------------------------------------------------- /srfi/%3a0/cond-expand.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :0 cond-expand) 8 | (export 9 | cond-expand) 10 | (import 11 | (rnrs) 12 | (for (srfi private registry) expand)) 13 | 14 | (define-syntax cond-expand 15 | (lambda (stx) 16 | (syntax-case stx (and or not else) 17 | [(_) 18 | (syntax-violation #f "Unfulfilled cond-expand" stx)] 19 | [(_ (else body ...)) 20 | #'(begin body ...)] 21 | [(_ ((and) body ...) more-clauses ...) 22 | #'(begin body ...)] 23 | [(_ ((and req1 req2 ...) body ...) more-clauses ...) 24 | #'(cond-expand 25 | (req1 26 | (cond-expand 27 | ((and req2 ...) body ...) 28 | more-clauses ...)) 29 | more-clauses ...)] 30 | [(_ ((or) body ...) more-clauses ...) 31 | #'(cond-expand more-clauses ...)] 32 | [(_ ((or req1 req2 ...) body ...) more-clauses ...) 33 | #'(cond-expand 34 | (req1 35 | (begin body ...)) 36 | (else 37 | (cond-expand 38 | ((or req2 ...) body ...) 39 | more-clauses ...)))] 40 | [(_ ((not req) body ...) more-clauses ...) 41 | #'(cond-expand 42 | (req 43 | (cond-expand more-clauses ...)) 44 | (else body ...))] 45 | [(_ (feature-id body ...) more-clauses ...) 46 | (if (member (syntax->datum #'feature-id) available-features) 47 | #'(begin body ...) 48 | #'(cond-expand more-clauses ...))]))) 49 | 50 | ) 51 | -------------------------------------------------------------------------------- /srfi/%3a1.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :1) 4 | (export 5 | alist-cons 6 | alist-copy 7 | alist-delete 8 | alist-delete! 9 | any 10 | append 11 | append! 12 | append-map 13 | append-map! 14 | append-reverse 15 | append-reverse! 16 | assoc 17 | assq 18 | assv 19 | break 20 | break! 21 | caaaar 22 | caaadr 23 | caaar 24 | caadar 25 | caaddr 26 | caadr 27 | caar 28 | cadaar 29 | cadadr 30 | cadar 31 | caddar 32 | cadddr 33 | caddr 34 | cadr 35 | car 36 | car+cdr 37 | cdaaar 38 | cdaadr 39 | cdaar 40 | cdadar 41 | cdaddr 42 | cdadr 43 | cdar 44 | cddaar 45 | cddadr 46 | cddar 47 | cdddar 48 | cddddr 49 | cdddr 50 | cddr 51 | cdr 52 | circular-list 53 | circular-list? 54 | concatenate 55 | concatenate! 56 | cons 57 | cons* 58 | count 59 | delete 60 | delete! 61 | delete-duplicates 62 | delete-duplicates! 63 | dotted-list? 64 | drop 65 | drop-right 66 | drop-right! 67 | drop-while 68 | eighth 69 | every 70 | fifth 71 | filter 72 | filter! 73 | filter-map 74 | find 75 | find-tail 76 | first 77 | fold 78 | fold-right 79 | for-each 80 | fourth 81 | iota 82 | last 83 | last-pair 84 | length 85 | length+ 86 | list 87 | list-copy 88 | list-index 89 | list-ref 90 | list-tabulate 91 | list= 92 | lset-adjoin 93 | lset-diff+intersection 94 | lset-diff+intersection! 95 | lset-difference 96 | lset-difference! 97 | lset-intersection 98 | lset-intersection! 99 | lset-union 100 | lset-union! 101 | lset-xor 102 | lset-xor! 103 | lset<= 104 | lset= 105 | make-list 106 | map 107 | map! 108 | map-in-order 109 | member 110 | memq 111 | memv 112 | ninth 113 | not-pair? 114 | null-list? 115 | null? 116 | pair-fold 117 | pair-fold-right 118 | pair-for-each 119 | pair? 120 | partition 121 | partition! 122 | proper-list? 123 | reduce 124 | reduce-right 125 | remove 126 | remove! 127 | reverse 128 | reverse! 129 | second 130 | set-car! 131 | set-cdr! 132 | seventh 133 | sixth 134 | span 135 | span! 136 | split-at 137 | split-at! 138 | take 139 | take! 140 | take-right 141 | take-while 142 | take-while! 143 | tenth 144 | third 145 | unfold 146 | unfold-right 147 | unzip1 148 | unzip2 149 | unzip3 150 | unzip4 151 | unzip5 152 | xcons 153 | zip) 154 | (import (srfi :1 lists)) 155 | ) 156 | -------------------------------------------------------------------------------- /srfi/%3a1/%3a1.sls: -------------------------------------------------------------------------------- 1 | %3a1.sls -------------------------------------------------------------------------------- /srfi/%3a11.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :11) 4 | (export 5 | let*-values 6 | let-values) 7 | (import (srfi :11 let-values)) 8 | ) 9 | -------------------------------------------------------------------------------- /srfi/%3a11/let-values.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :11 let-values) 8 | (export 9 | let-values 10 | let*-values) 11 | (import 12 | (only (rnrs) let-values let*-values)) 13 | ) 14 | -------------------------------------------------------------------------------- /srfi/%3a13.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :13) 4 | (export 5 | list->string 6 | make-string 7 | reverse-list->string 8 | string 9 | string->list 10 | string-any 11 | string-append 12 | string-append/shared 13 | string-ci< 14 | string-ci<= 15 | string-ci<> 16 | string-ci= 17 | string-ci> 18 | string-ci>= 19 | string-compare 20 | string-compare-ci 21 | string-concatenate 22 | string-concatenate-reverse 23 | string-concatenate-reverse/shared 24 | string-concatenate/shared 25 | string-contains 26 | string-contains-ci 27 | string-copy 28 | string-copy! 29 | string-count 30 | string-delete 31 | string-downcase 32 | string-downcase! 33 | string-drop 34 | string-drop-right 35 | string-every 36 | string-fill! 37 | string-filter 38 | string-fold 39 | string-fold-right 40 | string-for-each 41 | string-for-each-index 42 | string-hash 43 | string-hash-ci 44 | string-index 45 | string-index-right 46 | string-join 47 | string-length 48 | string-map 49 | string-map! 50 | string-null? 51 | string-pad 52 | string-pad-right 53 | string-prefix-ci? 54 | string-prefix-length 55 | string-prefix-length-ci 56 | string-prefix? 57 | string-ref 58 | string-replace 59 | string-reverse 60 | string-reverse! 61 | string-set! 62 | string-skip 63 | string-skip-right 64 | string-suffix-ci? 65 | string-suffix-length 66 | string-suffix-length-ci 67 | string-suffix? 68 | string-tabulate 69 | string-take 70 | string-take-right 71 | string-titlecase 72 | string-titlecase! 73 | string-tokenize 74 | string-trim 75 | string-trim-both 76 | string-trim-right 77 | string-unfold 78 | string-unfold-right 79 | string-upcase 80 | string-upcase! 81 | string-xcopy! 82 | string< 83 | string<= 84 | string<> 85 | string= 86 | string> 87 | string>= 88 | string? 89 | substring/shared 90 | xsubstring) 91 | (import (srfi :13 strings)) 92 | ) 93 | -------------------------------------------------------------------------------- /srfi/%3a13/strings.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :13 strings) 8 | (export 9 | string-map string-map! 10 | string-fold string-unfold 11 | string-fold-right string-unfold-right 12 | string-tabulate string-for-each string-for-each-index 13 | string-every string-any 14 | string-hash string-hash-ci 15 | string-compare string-compare-ci 16 | string= string< string> string<= string>= string<> 17 | string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<> 18 | string-downcase string-upcase string-titlecase 19 | string-downcase! string-upcase! string-titlecase! 20 | string-take string-take-right 21 | string-drop string-drop-right 22 | string-pad string-pad-right 23 | string-trim string-trim-right string-trim-both 24 | string-filter string-delete 25 | string-index string-index-right 26 | string-skip string-skip-right 27 | string-count 28 | string-prefix-length string-prefix-length-ci 29 | string-suffix-length string-suffix-length-ci 30 | string-prefix? string-prefix-ci? 31 | string-suffix? string-suffix-ci? 32 | string-contains string-contains-ci 33 | string-copy! substring/shared 34 | string-reverse string-reverse! reverse-list->string 35 | string-concatenate string-concatenate/shared string-concatenate-reverse 36 | string-concatenate-reverse/shared 37 | string-append/shared 38 | xsubstring string-xcopy! 39 | string-null? 40 | string-join 41 | string-tokenize 42 | string-replace 43 | ; R5RS extended: 44 | string->list string-copy string-fill! 45 | ; R5RS re-exports: 46 | string? make-string string-length string-ref string-set! 47 | string string-append list->string 48 | ; Low-level routines: 49 | #;(make-kmp-restart-vector string-kmp-partial-search kmp-step 50 | string-parse-start+end 51 | string-parse-final-start+end 52 | let-string-start+end 53 | check-substring-spec 54 | substring-spec-ok?) 55 | ) 56 | (import 57 | (except (rnrs) string-copy string-for-each string->list 58 | string-upcase string-downcase string-titlecase string-hash) 59 | (except (rnrs mutable-strings) string-fill!) 60 | (rnrs r5rs) 61 | (srfi :23 error tricks) 62 | (srfi :8 receive) 63 | (srfi :14 char-sets) 64 | (srfi private let-opt) 65 | (srfi private include)) 66 | 67 | 68 | (define-syntax check-arg 69 | (lambda (stx) 70 | (syntax-case stx () 71 | [(_ pred val caller) 72 | (and (identifier? #'val) (identifier? #'caller)) 73 | #'(unless (pred val) 74 | (assertion-violation 'caller "check-arg failed" val))]))) 75 | 76 | (define (char-cased? c) 77 | (char-upper-case? (char-upcase c))) 78 | 79 | (SRFI-23-error->R6RS "(library (srfi :13 strings))" 80 | (include/resolve ("srfi" "%3a13") "srfi-13.scm")) 81 | ) 82 | -------------------------------------------------------------------------------- /srfi/%3a14.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :14) 4 | (export 5 | ->char-set 6 | char-set 7 | char-set->list 8 | char-set->string 9 | char-set-adjoin 10 | char-set-adjoin! 11 | char-set-any 12 | char-set-complement 13 | char-set-complement! 14 | char-set-contains? 15 | char-set-copy 16 | char-set-count 17 | char-set-cursor 18 | char-set-cursor-next 19 | char-set-delete 20 | char-set-delete! 21 | char-set-diff+intersection 22 | char-set-diff+intersection! 23 | char-set-difference 24 | char-set-difference! 25 | char-set-every 26 | char-set-filter 27 | char-set-filter! 28 | char-set-fold 29 | char-set-for-each 30 | char-set-hash 31 | char-set-intersection 32 | char-set-intersection! 33 | char-set-map 34 | char-set-ref 35 | char-set-size 36 | char-set-unfold 37 | char-set-unfold! 38 | char-set-union 39 | char-set-union! 40 | char-set-xor 41 | char-set-xor! 42 | char-set:ascii 43 | char-set:blank 44 | char-set:digit 45 | char-set:empty 46 | char-set:full 47 | char-set:graphic 48 | char-set:hex-digit 49 | char-set:iso-control 50 | char-set:letter 51 | char-set:letter+digit 52 | char-set:lower-case 53 | char-set:printing 54 | char-set:punctuation 55 | char-set:symbol 56 | char-set:title-case 57 | char-set:upper-case 58 | char-set:whitespace 59 | char-set<= 60 | char-set= 61 | char-set? 62 | end-of-char-set? 63 | list->char-set 64 | list->char-set! 65 | string->char-set 66 | string->char-set! 67 | ucs-range->char-set 68 | ucs-range->char-set!) 69 | (import (srfi :14 char-sets)) 70 | ) 71 | -------------------------------------------------------------------------------- /srfi/%3a14/char-sets.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :14 char-sets) 8 | (export 9 | ; Predicates & comparison 10 | char-set? char-set= char-set<= char-set-hash 11 | ; Iterating over character sets 12 | char-set-cursor char-set-ref char-set-cursor-next end-of-char-set? 13 | char-set-fold char-set-unfold char-set-unfold! 14 | char-set-for-each char-set-map 15 | ; Creating character sets 16 | char-set-copy char-set 17 | list->char-set string->char-set 18 | list->char-set! string->char-set! 19 | char-set-filter ucs-range->char-set 20 | char-set-filter! ucs-range->char-set! 21 | ->char-set 22 | ; Querying character sets 23 | char-set->list char-set->string 24 | char-set-size char-set-count char-set-contains? 25 | char-set-every char-set-any 26 | ; Character-set algebra 27 | char-set-adjoin char-set-delete 28 | char-set-adjoin! char-set-delete! 29 | char-set-complement char-set-union char-set-intersection 30 | char-set-complement! char-set-union! char-set-intersection! 31 | char-set-difference char-set-xor char-set-diff+intersection 32 | char-set-difference! char-set-xor! char-set-diff+intersection! 33 | ; Standard character sets 34 | char-set:lower-case char-set:upper-case char-set:title-case 35 | char-set:letter char-set:digit char-set:letter+digit 36 | char-set:graphic char-set:printing char-set:whitespace 37 | char-set:iso-control char-set:punctuation char-set:symbol 38 | char-set:hex-digit char-set:blank char-set:ascii 39 | char-set:empty char-set:full 40 | ) 41 | (import 42 | (except (rnrs) define-record-type) 43 | (rnrs mutable-strings) 44 | (rnrs r5rs) 45 | (srfi :23 error tricks) 46 | (srfi :9 records) 47 | (srfi private let-opt) 48 | (srfi private include)) 49 | 50 | (define (%latin1->char i) 51 | (integer->char i)) 52 | 53 | (define (%char->latin1 c) 54 | (char->integer c)) 55 | 56 | (define-syntax check-arg 57 | (lambda (stx) 58 | (syntax-case stx () 59 | [(_ pred val caller) 60 | (identifier? #'val) 61 | #'(unless (pred val) 62 | (assertion-violation caller "check-arg failed" val))]))) 63 | 64 | (SRFI-23-error->R6RS "(library (srfi :14 char-sets))" 65 | (include/resolve ("srfi" "%3a14") "srfi-14.scm")) 66 | ) 67 | -------------------------------------------------------------------------------- /srfi/%3a16.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :16) 4 | (export 5 | case-lambda) 6 | (import (srfi :16 case-lambda)) 7 | ) 8 | -------------------------------------------------------------------------------- /srfi/%3a16/case-lambda.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :16 case-lambda) 8 | (export 9 | case-lambda) 10 | (import 11 | (only (rnrs control) case-lambda)) 12 | ) 13 | -------------------------------------------------------------------------------- /srfi/%3a19.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :19) 4 | (export 5 | add-duration 6 | add-duration! 7 | copy-time 8 | current-date 9 | current-julian-day 10 | current-modified-julian-day 11 | current-time 12 | date 13 | date->julian-day 14 | date->modified-julian-day 15 | date->string 16 | date->time-monotonic 17 | date->time-tai 18 | date->time-utc 19 | date-day 20 | date-hour 21 | date-minute 22 | date-month 23 | date-nanosecond 24 | date-second 25 | date-week-day 26 | date-week-number 27 | date-year 28 | date-year-day 29 | date-zone-offset 30 | date? 31 | julian-day->date 32 | julian-day->time-monotonic 33 | julian-day->time-tai 34 | julian-day->time-utc 35 | leap-year? 36 | make-date 37 | make-time 38 | modified-julian-day->date 39 | modified-julian-day->time-monotonic 40 | modified-julian-day->time-tai 41 | modified-julian-day->time-utc 42 | read-leap-second-table 43 | string->date 44 | subtract-duration 45 | subtract-duration! 46 | time 47 | time-difference 48 | time-difference! 49 | time-duration 50 | time-monotonic 51 | time-monotonic->date 52 | time-monotonic->julian-day 53 | time-monotonic->modified-julian-day 54 | time-monotonic->time-tai 55 | time-monotonic->time-tai! 56 | time-monotonic->time-utc 57 | time-monotonic->time-utc! 58 | time-nanosecond 59 | time-resolution 60 | time-second 61 | time-tai 62 | time-tai->date 63 | time-tai->julian-day 64 | time-tai->modified-julian-day 65 | time-tai->time-monotonic 66 | time-tai->time-monotonic! 67 | time-tai->time-utc 68 | time-tai->time-utc! 69 | time-type 70 | time-utc 71 | time-utc->date 72 | time-utc->julian-day 73 | time-utc->modified-julian-day 74 | time-utc->time-monotonic 75 | time-utc->time-monotonic! 76 | time-utc->time-tai 77 | time-utc->time-tai! 78 | time<=? 79 | time=? 82 | time>? 83 | time?) 84 | (import (srfi :19 time)) 85 | ) 86 | -------------------------------------------------------------------------------- /srfi/%3a19/time.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :19 time) 8 | (export 9 | time make-time time? time-type time-nanosecond time-second 10 | date make-date date? date-nanosecond date-second date-minute 11 | date-hour date-day date-month date-year date-zone-offset 12 | time-tai time-utc time-monotonic 13 | #|time-thread time-process|# time-duration 14 | read-leap-second-table copy-time current-time 15 | time-resolution time=? time>? time=? time<=? 16 | time-difference time-difference! add-duration 17 | add-duration! subtract-duration subtract-duration! 18 | time-tai->time-utc time-tai->time-utc! time-utc->time-tai 19 | time-utc->time-tai! time-monotonic->time-utc 20 | time-monotonic->time-utc! time-monotonic->time-tai 21 | time-monotonic->time-tai! time-utc->time-monotonic 22 | time-utc->time-monotonic! time-tai->time-monotonic 23 | time-tai->time-monotonic! time-tai->date time-utc->date 24 | time-monotonic->date date->time-utc date->time-tai 25 | date->time-monotonic leap-year? date-year-day 26 | date-week-day date-week-number current-date 27 | date->julian-day date->modified-julian-day 28 | time-utc->julian-day time-utc->modified-julian-day 29 | time-tai->julian-day time-tai->modified-julian-day 30 | time-monotonic->julian-day 31 | time-monotonic->modified-julian-day julian-day->time-utc 32 | julian-day->time-tai julian-day->time-monotonic 33 | julian-day->date modified-julian-day->date 34 | modified-julian-day->time-utc 35 | modified-julian-day->time-tai 36 | modified-julian-day->time-monotonic current-julian-day 37 | current-modified-julian-day date->string string->date) 38 | (import 39 | (rnrs) 40 | (rnrs r5rs) 41 | (rnrs mutable-strings) 42 | (srfi :19 time compat) 43 | (srfi :6 basic-string-ports) 44 | (srfi private include)) 45 | 46 | (define read-line 47 | (case-lambda 48 | [() 49 | (get-line (current-input-port))] 50 | [(port) 51 | (get-line port)])) 52 | 53 | (define eof (eof-object)) 54 | 55 | (include/resolve ("srfi" "%3a19") "srfi-19.scm") 56 | ) 57 | 58 | -------------------------------------------------------------------------------- /srfi/%3a19/time/compat.chezscheme.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (srfi :19 time compat) 3 | 4 | (export format 5 | host:time-resolution 6 | host:current-time 7 | host:time-nanosecond 8 | host:time-second 9 | host:time-gmt-offset) 10 | 11 | (import (chezscheme) 12 | 13 | (prefix (only (chezscheme) 14 | current-time 15 | time-nanosecond 16 | time-second) 17 | host:)) 18 | 19 | (define host:time-resolution 1000) 20 | 21 | (define (host:time-gmt-offset t) 22 | 23 | (date-zone-offset t)) 24 | 25 | ) 26 | -------------------------------------------------------------------------------- /srfi/%3a19/time/compat.ikarus.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :19 time compat) 7 | (export 8 | format 9 | host:time-resolution 10 | host:current-time 11 | host:time-nanosecond 12 | host:time-second 13 | host:time-gmt-offset) 14 | (import 15 | (rnrs base) 16 | (only (ikarus) format) 17 | (prefix (only (ikarus) current-time time-nanosecond time-second time-gmt-offset) 18 | host:)) 19 | 20 | ;; Ikarus uses gettimeofday() which gives microseconds, 21 | ;; so our resolution is 1000 nanoseconds 22 | (define host:time-resolution 1000) 23 | ) 24 | -------------------------------------------------------------------------------- /srfi/%3a19/time/compat.larceny.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :19 time compat) 7 | (export 8 | format 9 | host:time-resolution 10 | host:current-time 11 | host:time-nanosecond 12 | host:time-second 13 | host:time-gmt-offset) 14 | (import 15 | (r5rs) 16 | (rnrs) 17 | (larceny load) 18 | (primitives r5rs:require current-utc-time timezone-offset) 19 | (srfi :48 intermediate-format-strings)) 20 | 21 | (define-record-type time (fields secs usecs)) 22 | 23 | ;; Larceny uses gettimeofday() which gives microseconds, 24 | ;; so our resolution is 1000 nanoseconds 25 | (define host:time-resolution 1000) 26 | 27 | (define (host:current-time) 28 | (let-values ([(secs usecs) (current-utc-time)]) 29 | (make-time secs usecs))) 30 | 31 | (define (host:time-nanosecond t) 32 | (* (time-usecs t) 1000)) 33 | 34 | (define (host:time-second t) 35 | (time-secs t)) 36 | 37 | (define (host:time-gmt-offset t) 38 | (timezone-offset (time-secs t))) 39 | 40 | (r5rs:require 'time) 41 | 42 | ) 43 | -------------------------------------------------------------------------------- /srfi/%3a19/time/compat.mzscheme.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :19 time compat) 8 | (export 9 | format 10 | host:time-resolution 11 | host:current-time 12 | host:time-nanosecond 13 | host:time-second 14 | host:time-gmt-offset) 15 | (import 16 | (rnrs base) 17 | (only (scheme base) format current-inexact-milliseconds date-time-zone-offset 18 | seconds->date current-seconds)) 19 | 20 | ;; MzScheme uses milliseconds, so our resolution in nanoseconds is #e1e6 21 | (define host:time-resolution #e1e6) 22 | 23 | (define (host:current-time) 24 | (exact (floor (current-inexact-milliseconds)))) 25 | 26 | (define (host:time-nanosecond t) 27 | (* (mod t 1000) #e1e6)) 28 | 29 | (define (host:time-second t) 30 | (div t 1000)) 31 | 32 | (define (host:time-gmt-offset t) 33 | (date-time-zone-offset (seconds->date (host:time-second t)))) 34 | ) 35 | -------------------------------------------------------------------------------- /srfi/%3a19/time/compat.ypsilon.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :19 time compat) 7 | (export 8 | format 9 | host:time-resolution 10 | host:current-time 11 | host:time-nanosecond 12 | host:time-second 13 | host:time-gmt-offset) 14 | (import 15 | (rnrs base) 16 | (only (core) format microsecond microsecond->utc)) 17 | 18 | (define host:time-resolution 1000) 19 | (define (host:current-time) (microsecond)) 20 | (define (host:time-nanosecond t) (* (mod t 1000000) 1000)) 21 | (define (host:time-second t) (div t 1000000)) 22 | (define (host:time-gmt-offset t) (/ (- t (microsecond->utc t)) 1000000)) 23 | ) 24 | -------------------------------------------------------------------------------- /srfi/%3a2.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :2) 4 | (export 5 | and-let*) 6 | (import (srfi :2 and-let*)) 7 | ) 8 | -------------------------------------------------------------------------------- /srfi/%3a2/and-let%2a.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :2 and-let*) 8 | (export 9 | and-let*) 10 | (import 11 | (rnrs)) 12 | 13 | (define-syntax and-let* 14 | (lambda (stx) 15 | (define (get-id c) 16 | (syntax-case c () [(var expr) #'var] [_ #f])) 17 | (syntax-case stx () 18 | [(_ (clause* ...) body* ...) 19 | (for-all identifier? (filter values (map get-id #'(clause* ...)))) 20 | #'(and-let*-core #t (clause* ...) body* ...)]))) 21 | 22 | (define-syntax and-let*-core 23 | (lambda (stx) 24 | (syntax-case stx () 25 | [(kw _ ([var expr] clause* ...) body* ...) 26 | #'(let ([var expr]) 27 | (if var 28 | (kw var (clause* ...) body* ...) 29 | #f))] 30 | [(kw _ ([expr] clause* ...) body* ...) 31 | #'(let ([t expr]) 32 | (if t 33 | (kw t (clause* ...) body* ...) 34 | #f))] 35 | [(kw _ (id clause* ...) body* ...) 36 | (or (identifier? #'id) 37 | (syntax-violation #f "invalid clause" stx #'id)) 38 | #'(if id 39 | (kw id (clause* ...) body* ...) 40 | #f)] 41 | [(kw last () body* ...) 42 | (if (positive? (length #'(body* ...))) 43 | #'(begin body* ...) 44 | #'last)]))) 45 | ) 46 | -------------------------------------------------------------------------------- /srfi/%3a2/and-let*.larceny.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :2 and-let*) 8 | (export 9 | and-let*) 10 | (import 11 | (rnrs)) 12 | 13 | (define-syntax and-let* 14 | (lambda (stx) 15 | (define (get-id c) 16 | (syntax-case c () [(var expr) #'var] [_ #f])) 17 | (syntax-case stx () 18 | [(_ (clause* ...) body* ...) 19 | (for-all identifier? (filter values (map get-id #'(clause* ...)))) 20 | #'(and-let*-core #t (clause* ...) body* ...)]))) 21 | 22 | (define-syntax and-let*-core 23 | (lambda (stx) 24 | (syntax-case stx () 25 | [(kw _ ([var expr] clause* ...) body* ...) 26 | #'(let ([var expr]) 27 | (if var 28 | (kw var (clause* ...) body* ...) 29 | #f))] 30 | [(kw _ ([expr] clause* ...) body* ...) 31 | #'(let ([t expr]) 32 | (if t 33 | (kw t (clause* ...) body* ...) 34 | #f))] 35 | [(kw _ (id clause* ...) body* ...) 36 | (or (identifier? #'id) 37 | (syntax-violation #f "invalid clause" stx #'id)) 38 | #'(if id 39 | (kw id (clause* ...) body* ...) 40 | #f)] 41 | [(kw last () body* ...) 42 | (if (positive? (length #'(body* ...))) 43 | #'(begin body* ...) 44 | #'last)]))) 45 | ) 46 | -------------------------------------------------------------------------------- /srfi/%3a23.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :23) 4 | (export 5 | error) 6 | (import (srfi :23 error)) 7 | ) 8 | -------------------------------------------------------------------------------- /srfi/%3a23/error.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 3 | ;; MIT-style license. My license is in the file named LICENSE from the original 4 | ;; collection this file is distributed with. If this file is redistributed with 5 | ;; some other collection, my license must also be included. 6 | 7 | (library (srfi :23 error) 8 | (export 9 | error) 10 | (import 11 | (rename (rnrs base) (error rnrs:error))) 12 | 13 | (define (error . args) 14 | (apply rnrs:error #F args)) 15 | ) 16 | -------------------------------------------------------------------------------- /srfi/%3a23/error/tricks.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 3 | ;; MIT-style license. My license is in the file named LICENSE from the original 4 | ;; collection this file is distributed with. If this file is redistributed with 5 | ;; some other collection, my license must also be included. 6 | 7 | (library (srfi :23 error tricks) 8 | (export 9 | SRFI-23-error->R6RS) 10 | (import 11 | (rnrs)) 12 | 13 | (define-syntax error-wrap 14 | (lambda (stx) 15 | (syntax-case stx () 16 | ((_ ctxt signal expr ...) 17 | (with-syntax ((e (datum->syntax #'ctxt 'error))) 18 | #'(let-syntax ((e (identifier-syntax signal))) 19 | expr ...)))))) 20 | 21 | (define (AV who) 22 | (lambda args (apply assertion-violation who args))) 23 | 24 | (define-syntax SRFI-23-error->R6RS 25 | (lambda (stx) 26 | (syntax-case stx () 27 | ((ctxt ewho expr ...) 28 | (with-syntax ((e (datum->syntax #'ctxt 'error)) 29 | (d (datum->syntax #'ctxt 'define))) 30 | #'(let-syntax ((e (identifier-syntax (AV 'ewho))) 31 | (d (lambda (stx) 32 | (syntax-case stx () 33 | ((kw (id . formals) . body) 34 | (identifier? #'id) 35 | #'(error-wrap kw (AV 'id) 36 | (d (id . formals) . body))) 37 | ((kw id . r) 38 | (identifier? #'id) 39 | #'(error-wrap kw (AV 'id) 40 | (d id . r))))))) 41 | expr ...)))))) 42 | ) 43 | -------------------------------------------------------------------------------- /srfi/%3a25.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :25) 4 | (export 5 | array 6 | array-end 7 | array-rank 8 | array-ref 9 | array-set! 10 | array-start 11 | array? 12 | make-array 13 | shape 14 | share-array) 15 | (import (srfi :25 multi-dimensional-arrays)) 16 | ) 17 | -------------------------------------------------------------------------------- /srfi/%3a25/array.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/dharmatech/chez-srfi/9822eb301fa14643ac664f103da7e038885d0adb/srfi/%3a25/array.scm -------------------------------------------------------------------------------- /srfi/%3a25/ix-ctor.scm: -------------------------------------------------------------------------------- 1 | (define (array-ref a . xs) 2 | (or (array:array? a) 3 | (error "not an array")) 4 | (let ((shape (array:shape a))) 5 | (if (null? xs) 6 | (array:check-indices "array-ref" xs shape) 7 | (let ((x (car xs))) 8 | (if (vector? x) 9 | (array:check-index-vector "array-ref" x shape) 10 | (if (integer? x) 11 | (array:check-indices "array-ref" xs shape) 12 | (if (array:array? x) 13 | (array:check-index-actor "array-ref" x shape) 14 | (error "not an index object")))))) 15 | (vector-ref 16 | (array:vector a) 17 | (if (null? xs) 18 | (vector-ref (array:index a) 0) 19 | (let ((x (car xs))) 20 | (if (vector? x) 21 | (array:index/vector 22 | (quotient (vector-length shape) 2) 23 | (array:index a) 24 | x) 25 | (if (integer? x) 26 | (array:vector-index (array:index a) xs) 27 | (if (array:array? x) 28 | (array:index/array 29 | (quotient (vector-length shape) 2) 30 | (array:index a) 31 | (array:vector x) 32 | (array:index x)) 33 | (error "array-ref: bad index object"))))))))) 34 | 35 | (define (array-set! a x . xs) 36 | (or (array:array? a) 37 | (error "array-set!: not an array")) 38 | (let ((shape (array:shape a))) 39 | (if (null? xs) 40 | (array:check-indices "array-set!" '() shape) 41 | (if (vector? x) 42 | (array:check-index-vector "array-set!" x shape) 43 | (if (integer? x) 44 | (array:check-indices.o "array-set!" (cons x xs) shape) 45 | (if (array:array? x) 46 | (array:check-index-actor "array-set!" x shape) 47 | (error "not an index object"))))) 48 | (if (null? xs) 49 | (vector-set! (array:vector a) (vector-ref (array:index a) 0) x) 50 | (if (vector? x) 51 | (vector-set! (array:vector a) 52 | (array:index/vector 53 | (quotient (vector-length shape) 2) 54 | (array:index a) 55 | x) 56 | (car xs)) 57 | (if (integer? x) 58 | (let ((v (array:vector a)) 59 | (i (array:index a)) 60 | (r (quotient (vector-length shape) 2))) 61 | (do ((sum (* (vector-ref i 0) x) 62 | (+ sum (* (vector-ref i k) (car ks)))) 63 | (ks xs (cdr ks)) 64 | (k 1 (+ k 1))) 65 | ((= k r) 66 | (vector-set! v (+ sum (vector-ref i k)) (car ks))))) 67 | (if (array:array? x) 68 | (vector-set! (array:vector a) 69 | (array:index/array 70 | (quotient (vector-length shape) 2) 71 | (array:index a) 72 | (array:vector x) 73 | (array:index x)) 74 | (car xs)) 75 | (error (string-append 76 | "array-set!: bad index object: " 77 | (array:thing->string x))))))))) 78 | -------------------------------------------------------------------------------- /srfi/%3a25/multi-dimensional-arrays.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 3 | ;; MIT-style license. My license is in the file named LICENSE from the original 4 | ;; collection this file is distributed with. If this file is redistributed with 5 | ;; some other collection, my license must also be included. 6 | 7 | (library (srfi :25 multi-dimensional-arrays) 8 | (export 9 | array? 10 | make-array 11 | shape 12 | array 13 | array-rank 14 | array-start 15 | array-end 16 | array-ref 17 | array-set! 18 | share-array) 19 | (import 20 | (srfi :25 multi-dimensional-arrays all)) 21 | ) 22 | -------------------------------------------------------------------------------- /srfi/%3a25/multi-dimensional-arrays/all.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 3 | ;; MIT-style license. My license is in the file named LICENSE from the original 4 | ;; collection this file is distributed with. If this file is redistributed with 5 | ;; some other collection, my license must also be included. 6 | 7 | (library (srfi :25 multi-dimensional-arrays all) 8 | (export 9 | array:make 10 | array:array? 11 | array:vector 12 | array:index 13 | array:shape 14 | array-ref 15 | array-set! 16 | array:opt-args 17 | array:optimize 18 | array:optimize-empty 19 | array:coefficients 20 | array:vector-index 21 | array:shape-index 22 | array:empty-shape-index 23 | array:shape-vector-index 24 | array:actor-index 25 | array:0 26 | array:1 27 | array:2 28 | array:3 29 | array:n 30 | array:maker 31 | array:indexer/vector 32 | array:indexer/array 33 | array:applier-to-vector 34 | array:applier-to-actor 35 | array:applier-to-backing-vector 36 | array:index/vector 37 | array:index/array 38 | array:apply-to-vector 39 | array:apply-to-actor 40 | array? 41 | make-array 42 | array:make-array 43 | shape 44 | array 45 | array-rank 46 | array-start 47 | array-end 48 | share-array 49 | array:share/index! 50 | array:optimize/vector 51 | array:optimize/actor 52 | array:shape->vector 53 | array:size 54 | array:make-index 55 | array:good-shape? 56 | array:good-share? 57 | array:unchecked-share-depth? 58 | array:check-indices 59 | array:check-indices.o 60 | array:check-index-vector 61 | array:check-index-actor 62 | array:good-indices? 63 | array:good-indices.o? 64 | array:good-index-vector? 65 | array:good-index-actor? 66 | array:good-index? 67 | array:not-in 68 | array:list->string 69 | array:shape-vector->string 70 | array:thing->string 71 | array:index-ref 72 | array:index-set! 73 | array:index-length 74 | array:map->string 75 | array:map-column->string 76 | array:grok/arguments 77 | array:grok/index!) 78 | (import 79 | (rnrs) 80 | (rnrs mutable-pairs) 81 | (rnrs r5rs) 82 | (srfi :23 error tricks) 83 | (srfi private include)) 84 | 85 | (define-record-type (array-type array:make array:array?) 86 | (fields (immutable vec array:vector) 87 | (immutable ind array:index) 88 | (immutable shp array:shape))) 89 | 90 | (SRFI-23-error->R6RS "(library (srfi :25 multi-dimensional-arrays))" 91 | (include/resolve ("srfi" "%3a25") "ix-ctor.scm") 92 | (include/resolve ("srfi" "%3a25") "op-ctor.scm") 93 | (include/resolve ("srfi" "%3a25") "array.scm")) 94 | ) 95 | -------------------------------------------------------------------------------- /srfi/%3a25/multi-dimensional-arrays/arlib.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 3 | ;; MIT-style license. My license is in the file named LICENSE from the original 4 | ;; collection this file is distributed with. If this file is redistributed with 5 | ;; some other collection, my license must also be included. 6 | 7 | (library (srfi :25 multi-dimensional-arrays arlib) 8 | (export 9 | array-shape 10 | array-length 11 | array-size 12 | array-equal? 13 | shape-for-each 14 | array-for-each-index 15 | tabulate-array 16 | tabulate-array! 17 | array-retabulate! 18 | array-map 19 | array-map! 20 | array->vector 21 | array->list 22 | share-array/prefix 23 | share-row 24 | share-column 25 | share-array/origin 26 | share-array/index! 27 | array-append 28 | transpose 29 | share-nths) 30 | (import 31 | (rnrs) 32 | (rnrs r5rs) 33 | (srfi :23 error tricks) 34 | (srfi :25 multi-dimensional-arrays all) 35 | (srfi private include)) 36 | 37 | (SRFI-23-error->R6RS "(library (srfi :25 multi-dimensional-arrays arlib))" 38 | (include/resolve ("srfi" "%3a25") "arlib.scm")) 39 | ) 40 | -------------------------------------------------------------------------------- /srfi/%3a26.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :26) 4 | (export 5 | cut 6 | cute) 7 | (import (srfi :26 cut)) 8 | ) 9 | -------------------------------------------------------------------------------- /srfi/%3a26/cut.scm: -------------------------------------------------------------------------------- 1 | ; REFERENCE IMPLEMENTATION FOR SRFI-26 "CUT" 2 | ; ========================================== 3 | ; 4 | ; Sebastian.Egner@philips.com, 5-Jun-2002. 5 | ; adapted from the posting by Al Petrofsky 6 | ; placed in the public domain 7 | ; 8 | ; The code to handle the variable argument case was originally 9 | ; proposed by Michael Sperber and has been adapted to the new 10 | ; syntax of the macro using an explicit rest-slot symbol. The 11 | ; code to evaluate the non-slots for cute has been proposed by 12 | ; Dale Jordan. The code to allow a slot for the procedure position 13 | ; and to process the macro using an internal macro is based on 14 | ; a suggestion by Al Petrofsky. The code found below is, with 15 | ; exception of this header and some changes in variable names, 16 | ; entirely written by Al Petrofsky. 17 | ; 18 | ; compliance: 19 | ; Scheme R5RS (including macros). 20 | ; 21 | ; loading this file into Scheme 48 0.57: 22 | ; ,load cut.scm 23 | ; 24 | ; history of this file: 25 | ; SE, 6-Feb-2002: initial version as 'curry' with ". <>" notation 26 | ; SE, 14-Feb-2002: revised for <...> 27 | ; SE, 27-Feb-2002: revised for 'cut' 28 | ; SE, 03-Jun-2002: revised for proc-slot, cute 29 | ; SE, 04-Jun-2002: rewritten with internal transformer (no "loop" pattern) 30 | ; SE, 05-Jun-2002: replace my code by Al's; substituted "constant" etc. 31 | ; to match the convention in the SRFI-document 32 | 33 | ; (srfi-26-internal-cut slot-names combination . se) 34 | ; transformer used internally 35 | ; slot-names : the internal names of the slots 36 | ; combination : procedure being specialized, followed by its arguments 37 | ; se : slots-or-exprs, the qualifiers of the macro 38 | 39 | (define-syntax srfi-26-internal-cut 40 | (syntax-rules (<> <...>) 41 | 42 | ;; construct fixed- or variable-arity procedure: 43 | ;; (begin proc) throws an error if proc is not an 44 | ((srfi-26-internal-cut (slot-name ...) (proc arg ...)) 45 | (lambda (slot-name ...) ((begin proc) arg ...))) 46 | ((srfi-26-internal-cut (slot-name ...) (proc arg ...) <...>) 47 | (lambda (slot-name ... . rest-slot) (apply proc arg ... rest-slot))) 48 | 49 | ;; process one slot-or-expr 50 | ((srfi-26-internal-cut (slot-name ...) (position ...) <> . se) 51 | (srfi-26-internal-cut (slot-name ... x) (position ... x) . se)) 52 | ((srfi-26-internal-cut (slot-name ...) (position ...) nse . se) 53 | (srfi-26-internal-cut (slot-name ...) (position ... nse) . se)))) 54 | 55 | ; (srfi-26-internal-cute slot-names nse-bindings combination . se) 56 | ; transformer used internally 57 | ; slot-names : the internal names of the slots 58 | ; nse-bindings : let-style bindings for the non-slot expressions. 59 | ; combination : procedure being specialized, followed by its arguments 60 | ; se : slots-or-exprs, the qualifiers of the macro 61 | 62 | (define-syntax srfi-26-internal-cute 63 | (syntax-rules (<> <...>) 64 | 65 | ;; If there are no slot-or-exprs to process, then: 66 | ;; construct a fixed-arity procedure, 67 | ((srfi-26-internal-cute 68 | (slot-name ...) nse-bindings (proc arg ...)) 69 | (let nse-bindings (lambda (slot-name ...) (proc arg ...)))) 70 | ;; or a variable-arity procedure 71 | ((srfi-26-internal-cute 72 | (slot-name ...) nse-bindings (proc arg ...) <...>) 73 | (let nse-bindings (lambda (slot-name ... . x) (apply proc arg ... x)))) 74 | 75 | ;; otherwise, process one slot: 76 | ((srfi-26-internal-cute 77 | (slot-name ...) nse-bindings (position ...) <> . se) 78 | (srfi-26-internal-cute 79 | (slot-name ... x) nse-bindings (position ... x) . se)) 80 | ;; or one non-slot expression 81 | ((srfi-26-internal-cute 82 | slot-names nse-bindings (position ...) nse . se) 83 | (srfi-26-internal-cute 84 | slot-names ((x nse) . nse-bindings) (position ... x) . se)))) 85 | 86 | ; exported syntax 87 | 88 | (define-syntax cut 89 | (syntax-rules () 90 | ((cut . slots-or-exprs) 91 | (srfi-26-internal-cut () () . slots-or-exprs)))) 92 | 93 | (define-syntax cute 94 | (syntax-rules () 95 | ((cute . slots-or-exprs) 96 | (srfi-26-internal-cute () () () . slots-or-exprs)))) 97 | -------------------------------------------------------------------------------- /srfi/%3a26/cut.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :26 cut) 8 | (export cut cute) 9 | (import (rnrs) (srfi private include)) 10 | 11 | (include/resolve ("srfi" "%3a26") "cut.scm") 12 | ) 13 | -------------------------------------------------------------------------------- /srfi/%3a27.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :27) 4 | (export 5 | default-random-source 6 | make-random-source 7 | random-integer 8 | random-real 9 | random-source-make-integers 10 | random-source-make-reals 11 | random-source-pseudo-randomize! 12 | random-source-randomize! 13 | random-source-state-ref 14 | random-source-state-set! 15 | random-source?) 16 | (import (srfi :27 random-bits)) 17 | ) 18 | -------------------------------------------------------------------------------- /srfi/%3a27/random-bits.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :27 random-bits) 8 | (export random-integer 9 | random-real 10 | default-random-source 11 | make-random-source 12 | random-source? 13 | random-source-state-ref 14 | random-source-state-set! 15 | random-source-randomize! 16 | random-source-pseudo-randomize! 17 | random-source-make-integers 18 | random-source-make-reals) 19 | 20 | (import (rnrs) 21 | (rnrs r5rs) 22 | (only (srfi :19 time) time-nanosecond current-time) 23 | (srfi :23 error tricks) 24 | (srfi private include) 25 | ) 26 | 27 | (SRFI-23-error->R6RS "(library (srfi :27 random-bits))" 28 | (include/resolve ("srfi" "%3a27") "random.ss")) 29 | ) 30 | -------------------------------------------------------------------------------- /srfi/%3a27/readme: -------------------------------------------------------------------------------- 1 | REFERENCE IMPLEMENTATIONS FOR SRFI-27 "Sources of Random Bits" 2 | ============================================================== 3 | 4 | Sebastian.Egner@philips.com, 10-Apr-2002. 5 | 6 | Files 7 | ----- 8 | 9 | readme - this file 10 | mrg32k3a.scm - generic parts of P. L' Ecuyer's MRG32k3a PRGN 11 | mrg32k3a-a.scm - core generator in Scheme integers 12 | mrg32k3a-b.c - core generator in C doubles for Scheme 48 13 | mrg32k3a-c.scm - core generator in Gambit [Scheme] flonums 14 | srfi-27-a.scm - Scheme 48 package definition for Scheme-only impl. 15 | srfi-27-b.scm - Scheme 48 package definition for C/Scheme impl. 16 | srfi-27-c.scm - Gambit definition for Scheme-only impl. 17 | conftest.scm - confidence tests for the implementation 18 | 19 | Implementations 20 | --------------- 21 | 22 | The implementation has been factored into three parts. 23 | One part implements the core generator, one part provides 24 | the more generic functionality as specified in the SRFI, 25 | and one part combines the parts and provides the interface 26 | as specified in the SRFI. 27 | 28 | a) A Scheme-only implementation for Scheme 48 0.57: 29 | srfi-27-a.scm 30 | mrg32k3a-a.scm 31 | mrg32k3a.scm 32 | 33 | This implementation uses 54-bit Scheme integers for all 34 | arithmetics of the generator. The result are Scheme integers 35 | and inexact Scheme numbers when floating point values are 36 | requested. 37 | 38 | The implementation is slow but tries to stay away from 39 | unportable features as much as possible. 40 | 41 | b) An implementation in Scheme 48 0.57 and ANSI-C: 42 | srfi-27-b.scm 43 | mrg32k3a-b.scm 44 | mrg32k3a.scm 45 | 46 | This is a more realistic implementation using C's (double) 47 | datatype for the core generator and 54-bit Scheme integers 48 | for the more infrequent operations on the state like the 49 | random-source-pseudo-randomize! operation. 50 | 51 | This implementation is meant as an example for a realistic 52 | native code implementation of the SRFI. Performance is good. 53 | 54 | c) A Scheme-only implementation for Gambit 3.0: 55 | srfi-27-c.scm 56 | mrg32k3a-c.scm 57 | mrg32k3a.scm 58 | 59 | This implementation uses Gambit's 64-bit flonums. It is 60 | entirely written in Scheme but uses a few special features 61 | of the Gambit system to tell the compiler. 62 | 63 | This implementation is meant as an example for a realistic 64 | Scheme implementation using flonums in Scheme and no C-code. 65 | Performance is good when the code is used in compiled form; 66 | the implementation has been optimized by Brad Lucier. This 67 | has resulted in a subtantial performance gain. 68 | -------------------------------------------------------------------------------- /srfi/%3a31.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :31) 4 | (export 5 | rec) 6 | (import (srfi :31 rec)) 7 | ) 8 | -------------------------------------------------------------------------------- /srfi/%3a31/rec.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :31 rec) 8 | (export rec) 9 | (import (rnrs)) 10 | 11 | ;; Taken directly from the SRFI-31 12 | (define-syntax rec 13 | (syntax-rules () 14 | [(rec (NAME . VARIABLES) . BODY) 15 | (letrec ( (NAME (lambda VARIABLES . BODY)) ) NAME)] 16 | [(rec NAME EXPRESSION) 17 | (letrec ( (NAME EXPRESSION) ) NAME)])) 18 | 19 | ) 20 | -------------------------------------------------------------------------------- /srfi/%3a37.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :37) 4 | (export 5 | args-fold 6 | option 7 | option-names 8 | option-optional-arg? 9 | option-processor 10 | option-required-arg? 11 | option?) 12 | (import (srfi :37 args-fold)) 13 | ) 14 | -------------------------------------------------------------------------------- /srfi/%3a37/args-fold.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :37 args-fold) 8 | (export 9 | args-fold 10 | (rename (make-option option)) 11 | option? 12 | option-names 13 | option-required-arg? 14 | option-optional-arg? 15 | option-processor) 16 | (import 17 | (rnrs) 18 | (srfi private include)) 19 | 20 | 21 | (define-record-type option 22 | (fields 23 | names required-arg? optional-arg? processor) 24 | (protocol 25 | (lambda (c) 26 | (lambda (n ra oa p) 27 | (if (and 28 | (and (list? n) 29 | (positive? (length n)) 30 | (for-all (lambda (x) 31 | (or (and (string? x) (positive? (string-length x))) 32 | (char? x))) 33 | n)) 34 | (boolean? ra) 35 | (boolean? oa) 36 | (not (and ra oa)) 37 | (procedure? p)) 38 | (c n ra oa p) 39 | (assertion-violation 'option "invalid arguments" n ra oa p)))))) 40 | 41 | (define args-fold 42 | (let ([option make-option]) 43 | (include/resolve ("srfi" "%3a37") "srfi-37-reference.scm") 44 | args-fold)) 45 | ) 46 | -------------------------------------------------------------------------------- /srfi/%3a38.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :38) 4 | (export 5 | read-with-shared-structure 6 | read/ss 7 | write-with-shared-structure 8 | write/ss) 9 | (import (srfi :38 with-shared-structure)) 10 | ) 11 | -------------------------------------------------------------------------------- /srfi/%3a38/with-shared-structure.ikarus.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :38 with-shared-structure) 7 | (export 8 | write-with-shared-structure 9 | (rename (write-with-shared-structure write/ss)) 10 | read-with-shared-structure 11 | (rename (read-with-shared-structure read/ss))) 12 | (import 13 | (rnrs) 14 | (only (ikarus) print-graph parameterize)) 15 | 16 | (define write-with-shared-structure 17 | (case-lambda 18 | [(obj) 19 | (write-with-shared-structure obj (current-output-port))] 20 | [(obj port) 21 | (parameterize ([print-graph #t]) 22 | (write obj port))] 23 | [(obj port optarg) 24 | (assertion-violation 'write-with-shared-structure 25 | "this implementation does not support optarg")])) 26 | 27 | (define read-with-shared-structure read) 28 | 29 | ) 30 | -------------------------------------------------------------------------------- /srfi/%3a38/with-shared-structure.ypsilon.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :38 with-shared-structure) 7 | (export 8 | write-with-shared-structure 9 | (rename (write-with-shared-structure write/ss)) 10 | read-with-shared-structure 11 | (rename (read-with-shared-structure read/ss))) 12 | (import 13 | (only (core) write-with-shared-structure read-with-shared-structure)) 14 | ) 15 | -------------------------------------------------------------------------------- /srfi/%3a39.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :39) 4 | (export 5 | make-parameter 6 | parameterize) 7 | (import (srfi :39 parameters)) 8 | ) 9 | -------------------------------------------------------------------------------- /srfi/%3a39/parameters.ikarus.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :39 parameters) 7 | (export 8 | make-parameter 9 | parameterize) 10 | (import 11 | (only (ikarus) make-parameter parameterize)) 12 | ) 13 | -------------------------------------------------------------------------------- /srfi/%3a39/parameters.mzscheme.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :39 parameters) 8 | (export 9 | make-parameter 10 | parameterize) 11 | (import 12 | (only (scheme base) make-parameter parameterize)) 13 | ) 14 | -------------------------------------------------------------------------------- /srfi/%3a39/parameters.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | ;; Fall-back library in case the host Scheme system does not provide SRFI-39. 7 | 8 | #!r6rs 9 | (library (srfi :39 parameters) 10 | (export 11 | make-parameter 12 | parameterize) 13 | (import 14 | (rnrs)) 15 | 16 | (define make-parameter 17 | (case-lambda 18 | [(val) (make-parameter val values)] 19 | [(val guard) 20 | (unless (procedure? guard) 21 | (assertion-violation 'make-parameter "not a procedure" guard)) 22 | (let ([p (case-lambda 23 | [() val] 24 | [(x) (set! val (guard x))])]) 25 | (p val) 26 | p)])) 27 | 28 | (define-syntax parameterize 29 | ;; Derived from Ikarus's implementation of parameterize. 30 | (lambda (stx) 31 | (syntax-case stx () 32 | [(_ () b0 b ...) 33 | #'(let () b0 b ...)] 34 | [(_ ([p e] ...) b0 b ...) 35 | (with-syntax ([(tp ...) (generate-temporaries #'(p ...))] 36 | [(te ...) (generate-temporaries #'(e ...))]) 37 | #'(let ([tp p] ... 38 | [te e] ...) 39 | (let ([swap (lambda () 40 | (let ([t (tp)]) 41 | (tp te) 42 | (set! te t)) 43 | ...)]) 44 | (dynamic-wind 45 | swap 46 | (lambda () b0 b ...) 47 | swap))))]))) 48 | 49 | ) 50 | 51 | -------------------------------------------------------------------------------- /srfi/%3a39/parameters.ypsilon.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :39 parameters) 7 | (export 8 | make-parameter parameterize) 9 | (import 10 | (only (core) make-parameter parameterize)) 11 | ) 12 | -------------------------------------------------------------------------------- /srfi/%3a41.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :41) 4 | (export 5 | define-stream 6 | list->stream 7 | port->stream 8 | stream 9 | stream->list 10 | stream-append 11 | stream-car 12 | stream-cdr 13 | stream-concat 14 | stream-cons 15 | stream-constant 16 | stream-drop 17 | stream-drop-while 18 | stream-filter 19 | stream-fold 20 | stream-for-each 21 | stream-from 22 | stream-iterate 23 | stream-lambda 24 | stream-length 25 | stream-let 26 | stream-map 27 | stream-match 28 | stream-null 29 | stream-null? 30 | stream-of 31 | stream-pair? 32 | stream-range 33 | stream-ref 34 | stream-reverse 35 | stream-scan 36 | stream-take 37 | stream-take-while 38 | stream-unfold 39 | stream-unfolds 40 | stream-zip 41 | stream?) 42 | (import (srfi :41 streams)) 43 | ) 44 | -------------------------------------------------------------------------------- /srfi/%3a41/streams.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation files 5 | ;;; (the "Software"), to deal in the Software without restriction, 6 | ;;; including without limitation the rights to use, copy, modify, merge, 7 | ;;; publish, distribute, sublicense, and/or sell copies of the Software, 8 | ;;; and to permit persons to whom the Software is furnished to do so, 9 | ;;; subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;;; SOFTWARE. 22 | 23 | (library (srfi :41 streams) 24 | 25 | (export stream-null stream-cons stream? stream-null? stream-pair? stream-car 26 | stream-cdr stream-lambda define-stream list->stream port->stream stream 27 | stream->list stream-append stream-concat stream-constant stream-drop 28 | stream-drop-while stream-filter stream-fold stream-for-each stream-from 29 | stream-iterate stream-length stream-let stream-map stream-match 30 | stream-of stream-range stream-ref stream-reverse stream-scan stream-take 31 | stream-take-while stream-unfold stream-unfolds stream-zip) 32 | 33 | (import (srfi :41 streams primitive) 34 | (srfi :41 streams derived))) 35 | -------------------------------------------------------------------------------- /srfi/%3a41/streams/primitive.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; Copyright (C) Philip L. Bewig (2007). All Rights Reserved. 3 | ;;; Permission is hereby granted, free of charge, to any person 4 | ;;; obtaining a copy of this software and associated documentation files 5 | ;;; (the "Software"), to deal in the Software without restriction, 6 | ;;; including without limitation the rights to use, copy, modify, merge, 7 | ;;; publish, distribute, sublicense, and/or sell copies of the Software, 8 | ;;; and to permit persons to whom the Software is furnished to do so, 9 | ;;; subject to the following conditions: 10 | ;;; 11 | ;;; The above copyright notice and this permission notice shall be 12 | ;;; included in all copies or substantial portions of the Software. 13 | ;;; 14 | ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS 18 | ;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN 19 | ;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | ;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | ;;; SOFTWARE. 22 | 23 | (library (srfi :41 streams primitive) 24 | 25 | (export stream-null stream-cons stream? stream-null? stream-pair? 26 | stream-car stream-cdr stream-lambda) 27 | 28 | (import (rnrs) (rnrs mutable-pairs)) 29 | 30 | (define-record-type (stream-type make-stream stream?) 31 | (fields (mutable box stream-promise stream-promise!))) 32 | 33 | (define-syntax stream-lazy 34 | (syntax-rules () 35 | ((lazy expr) 36 | (make-stream 37 | (cons 'lazy (lambda () expr)))))) 38 | 39 | (define (stream-eager expr) 40 | (make-stream 41 | (cons 'eager expr))) 42 | 43 | (define-syntax stream-delay 44 | (syntax-rules () 45 | ((stream-delay expr) 46 | (stream-lazy (stream-eager expr))))) 47 | 48 | (define (stream-force promise) 49 | (let ((content (stream-promise promise))) 50 | (case (car content) 51 | ((eager) (cdr content)) 52 | ((lazy) (let* ((promise* ((cdr content))) 53 | (content (stream-promise promise))) 54 | (if (not (eqv? (car content) 'eager)) 55 | (begin (set-car! content (car (stream-promise promise*))) 56 | (set-cdr! content (cdr (stream-promise promise*))) 57 | (stream-promise! promise* content))) 58 | (stream-force promise)))))) 59 | 60 | (define stream-null (stream-delay (cons 'stream 'null))) 61 | 62 | (define-record-type (stream-pare-type make-stream-pare stream-pare?) 63 | (fields (immutable kar stream-kar) (immutable kdr stream-kdr))) 64 | 65 | (define (stream-pair? obj) 66 | (and (stream? obj) (stream-pare? (stream-force obj)))) 67 | 68 | (define (stream-null? obj) 69 | (and (stream? obj) 70 | (eqv? (stream-force obj) 71 | (stream-force stream-null)))) 72 | 73 | (define-syntax stream-cons 74 | (syntax-rules () 75 | ((stream-cons obj strm) 76 | (stream-delay (make-stream-pare (stream-delay obj) (stream-lazy strm)))))) 77 | 78 | (define (stream-car strm) 79 | (cond ((not (stream? strm)) (error 'stream-car "non-stream")) 80 | ((stream-null? strm) (error 'stream-car "null stream")) 81 | (else (stream-force (stream-kar (stream-force strm)))))) 82 | 83 | (define (stream-cdr strm) 84 | (cond ((not (stream? strm)) (error 'stream-cdr "non-stream")) 85 | ((stream-null? strm) (error 'stream-cdr "null stream")) 86 | (else (stream-kdr (stream-force strm))))) 87 | 88 | (define-syntax stream-lambda 89 | (syntax-rules () 90 | ((stream-lambda formals body0 body1 ...) 91 | (lambda formals (stream-lazy (let () body0 body1 ...))))))) 92 | -------------------------------------------------------------------------------- /srfi/%3a42.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :42) 4 | (export 5 | : 6 | :-dispatch-ref 7 | :-dispatch-set! 8 | :char-range 9 | :dispatched 10 | :do 11 | :generator-proc 12 | :integers 13 | :let 14 | :list 15 | :parallel 16 | :port 17 | :range 18 | :real-range 19 | :string 20 | :until 21 | :vector 22 | :while 23 | any?-ec 24 | append-ec 25 | dispatch-union 26 | do-ec 27 | every?-ec 28 | first-ec 29 | fold-ec 30 | fold3-ec 31 | last-ec 32 | list-ec 33 | make-initial-:-dispatch 34 | max-ec 35 | min-ec 36 | product-ec 37 | string-append-ec 38 | string-ec 39 | sum-ec 40 | vector-ec 41 | vector-of-length-ec) 42 | (import (srfi :42 eager-comprehensions)) 43 | ) 44 | -------------------------------------------------------------------------------- /srfi/%3a42/eager-comprehensions.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :42 eager-comprehensions) 8 | (export 9 | do-ec list-ec append-ec string-ec string-append-ec vector-ec 10 | vector-of-length-ec sum-ec product-ec min-ec max-ec any?-ec 11 | every?-ec first-ec last-ec fold-ec fold3-ec 12 | : :list :string :vector :integers :range :real-range :char-range 13 | :port :dispatched :do :let :parallel :while :until 14 | :-dispatch-ref :-dispatch-set! make-initial-:-dispatch 15 | dispatch-union :generator-proc) 16 | (import 17 | (rnrs) 18 | (rnrs r5rs) 19 | (srfi :39 parameters) 20 | (srfi :23 error tricks) 21 | (srfi private include)) 22 | 23 | (SRFI-23-error->R6RS "(library (srfi :42 eager-comprehensions))" 24 | (include/resolve ("srfi" "%3a42") "ec.scm")) 25 | ) 26 | -------------------------------------------------------------------------------- /srfi/%3a42/extension.scm: -------------------------------------------------------------------------------- 1 | ; 2 | ; Examples for Application Specific Extensions of Eager Comprehensions 3 | ; ==================================================================== 4 | ; 5 | ; sebastian.egner@philips.com, Eindhoven, The Netherlands, Feb-2003. 6 | ; Scheme R5RS (incl. macros), SRFI-23 (error). 7 | ; 8 | ; Running the extensions in Scheme48 (version 0.57): 9 | ; ; load "examples.scm" as described there 10 | ; ,load extension.scm 11 | ; 12 | ; Running the extensions in PLT (version 202): 13 | ; ; load "examples.scm" as described there 14 | ; (load "extension.scm") 15 | ; 16 | ; Running the extensions in SCM (version 5d7): 17 | ; ; load "examples.scm" as described there 18 | ; (load "extension.scm") 19 | 20 | ; reset SRFI 21 | 22 | (set! :-dispatch (make-initial-:-dispatch)) 23 | 24 | (define my-check-correct 0) 25 | (define my-check-wrong 0) 26 | 27 | 28 | ; ========================================================================== 29 | ; Extending the predefined dispatching generator 30 | ; ========================================================================== 31 | 32 | ; example from SRFI document (for :dispatch) 33 | 34 | (define (example-dispatch args) 35 | (cond 36 | ((null? args) 37 | 'example ) 38 | ((and (= (length args) 1) (symbol? (car args)) ) 39 | (:generator-proc (:string (symbol->string (car args)))) ) 40 | (else 41 | #f ))) 42 | 43 | (:-dispatch-set! (dispatch-union (:-dispatch-ref) example-dispatch)) 44 | 45 | ; run the example 46 | 47 | (my-check (list-ec (: c 'abc) c) => '(#\a #\b #\c)) 48 | 49 | 50 | ; ========================================================================== 51 | ; Adding an application specific dispatching generator 52 | ; ========================================================================== 53 | 54 | ; example from SRFI document (for :dispatch) 55 | 56 | (define (:my-dispatch args) 57 | (case (length args) 58 | ((0) 'example) 59 | ((1) (let ((a1 (car args))) 60 | (cond 61 | ((list? a1) 62 | (:generator-proc (:list a1)) ) 63 | ((string? a1) 64 | (:generator-proc (:string a1)) ) 65 | ; ...more unary cases... 66 | (else 67 | #f )))) 68 | ((2) (let ((a1 (car args)) (a2 (cadr args))) 69 | (cond 70 | ((and (list? a1) (list? a2)) 71 | (:generator-proc (:list a1 a2)) ) 72 | ; ...more binary cases... 73 | (else 74 | #f )))) 75 | ; ...more arity cases... 76 | (else 77 | (cond 78 | ((every?-ec (:list a args) (list? a)) 79 | (:generator-proc (:list (apply append args))) ) 80 | ; ...more large variable arity cases... 81 | (else 82 | #f ))))) 83 | 84 | (define-syntax :my 85 | (syntax-rules (index) 86 | ((:my cc var (index i) arg1 arg ...) 87 | (:dispatched cc var (index i) :my-dispatch arg1 arg ...) ) 88 | ((:my cc var arg1 arg ...) 89 | (:dispatched cc var :my-dispatch arg1 arg ...) ))) 90 | 91 | ; run the example 92 | 93 | (my-check (list-ec (:my x "abc") x) => '(#\a #\b #\c)) 94 | 95 | (my-check (list-ec (:my x '(1) '(2) '(3)) x) => '(1 2 3)) 96 | 97 | (my-check 98 | (list-ec (:my x (index i) "abc") (list x i)) 99 | => '((#\a 0) (#\b 1) (#\c 2)) ) 100 | 101 | 102 | ; ========================================================================== 103 | ; Adding an application specific typed generator 104 | ; ========================================================================== 105 | 106 | ; example from SRFI document 107 | 108 | (define-syntax :mygen 109 | (syntax-rules () 110 | ((:mygen cc var arg) 111 | (:list cc var (reverse arg)) ))) 112 | 113 | ; run the example 114 | 115 | (my-check (list-ec (:mygen x '(1 2 3)) x) => '(3 2 1)) 116 | 117 | 118 | ; ========================================================================== 119 | ; Adding application specific comprehensions 120 | ; ========================================================================== 121 | 122 | ; example from SRFI document 123 | 124 | (define-syntax new-list-ec 125 | (syntax-rules () 126 | ((new-list-ec etc1 etc ...) 127 | (reverse (fold-ec '() etc1 etc ... cons)) ))) 128 | 129 | (define-syntax new-min-ec 130 | (syntax-rules () 131 | ((new-min-ec etc1 etc ...) 132 | (fold3-ec (min) etc1 etc ... min min) ))) 133 | 134 | (define-syntax new-fold3-ec 135 | (syntax-rules (nested) 136 | ((new-fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...) 137 | (new-fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) ) 138 | ((new-fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...) 139 | (new-fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) ) 140 | ((new-fold3-ec x0 expression f1 f2) 141 | (new-fold3-ec x0 (nested) expression f1 f2) ) 142 | 143 | ((new-fold3-ec x0 qualifier expression f1 f2) 144 | (let ((result #f) (empty #t)) 145 | (do-ec qualifier 146 | (let ((value expression)) ; don't duplicate 147 | (if empty 148 | (begin (set! result (f1 value)) 149 | (set! empty #f) ) 150 | (set! result (f2 value result)) ))) 151 | (if empty x0 result) )))) 152 | 153 | ; run the example 154 | 155 | (my-check (new-list-ec (: i 5) i) => '(0 1 2 3 4)) 156 | 157 | (my-check (new-min-ec (: i 5) i) => 0) 158 | 159 | (my-check 160 | (let ((f1 (lambda (x) (list 'f1 x))) 161 | (f2 (lambda (x result) (list 'f2 x result))) ) 162 | (new-fold3-ec (error "bad") (: i 5) i f1 f2) ) 163 | => '(f2 4 (f2 3 (f2 2 (f2 1 (f1 0))))) ) 164 | 165 | 166 | ; ========================================================================== 167 | ; Summary 168 | ; ========================================================================== 169 | 170 | (begin 171 | (newline) 172 | (newline) 173 | (display "correct examples : ") 174 | (display my-check-correct) 175 | (newline) 176 | (display "wrong examples : ") 177 | (display my-check-wrong) 178 | (newline) 179 | (newline) ) 180 | 181 | -------------------------------------------------------------------------------- /srfi/%3a42/timing.scm: -------------------------------------------------------------------------------- 1 | ; <PLAINTEXT> 2 | ; Timing for Eager Comprehensions in [outer..inner|expr]-Convention 3 | ; ================================================================= 4 | ; 5 | ; sebastian.egner@philips.com, Eindhoven, The Netherlands, Feb-2003. 6 | ; Scheme R5RS (incl. macros), SRFI-23 (error). 7 | ; 8 | ; Running the examples in Scheme48 (version 0.57): 9 | ; ,open srfi-23 10 | ; ,load ec.scm 11 | ; ,load timing.scm 12 | ; 13 | ; Running the examples in PLT/DrScheme (version 202): 14 | ; ; open "ec.scm", click Execute 15 | ; (load "timing.scm") 16 | ; 17 | ; Running the examples in SCM (version 5d7): 18 | ; ; invoke SCM with -v on the command line 19 | ; (require 'macro) (require 'record) 20 | ; (load "ec.scm") 21 | ; (load "timing.scm") 22 | 23 | 24 | ; ======================================================================= 25 | ; Basic loops 26 | ; ======================================================================= 27 | ; 28 | ; We measure execution times for (:range var n) and for (: var n), 29 | ; both as an outer loop (to measure iteration speed) or as an inner 30 | ; loop (to measure start up overhead). For comparison the same is 31 | ; measured for a hand-coded DO-loop. 32 | 33 | (define (perf0 n) ; reference for loop duration 34 | (do ((i 0 (+ i 1))) 35 | ((= i n)) 36 | i)) 37 | 38 | (define (perf1 n) 39 | (do-ec (:range i n) i)) 40 | 41 | (define (perf2 n) 42 | (do-ec (: i n) i)) 43 | 44 | (define (perf0s n) ; reference for startup delay 45 | (do-ec (:range i n) 46 | (do ((i 0 (+ i 1))) 47 | ((= i 1)) 48 | i))) 49 | 50 | (define (perf1s n) 51 | (do-ec (:range i n) (:range j 1) i)) 52 | 53 | (define (perf2s n) 54 | (do-ec (:range i n) (: j 1) i)) 55 | 56 | (define n-perf 57 | 10000000) 58 | 59 | 60 | ; Scheme48 0.57 on HP 9000/800 server running HP-UX 61 | ; ------------------------------------------------- 62 | ; 63 | ; ,time (perf0 n-perf) 19.3 ; built-in do 64 | ; ,time (perf1 n-perf) 17.0 ; faster than built-in do (?) 65 | ; ,time (perf2 n-perf) 40.4 ; due to calling the generator as procedure 66 | ; 67 | ; ,time (perf0s n-perf) 57.5 ; built-in do in the inner loop 68 | ; ,time (perf1s n-perf) 78.5 ; due to checking exact? integer? 69 | ; ,time (perf2s n-perf) 274.0 ; due to dispatch mechanism 70 | ; 71 | ; [All times are CPU time in seconds for n-perf iterations.] 72 | 73 | 74 | ; PLT 202 on Pentium III Mobile, 1 GHz, 1 GB RAM, Windows 2k 75 | ; ---------------------------------------------------------- 76 | ; 77 | ; (time (perf0 n-perf)) 11.1 78 | ; (time (perf1 n-perf)) 7.8 79 | ; (time (perf2 n-perf)) 18.1 80 | ; 81 | ; (time (perf0s n-perf)) 35.2 82 | ; (time (perf1s n-perf)) 42.9 83 | ; (time (perf2s n-perf)) 147.8 84 | ; 85 | ; [All times are CPU time in seconds for n-perf iterations.] 86 | 87 | 88 | ; SCM 5d7 on Pentium III Mobile, 1 GHz, 1 GB RAM, Windows 2k 89 | ; ---------------------------------------------------------- 90 | ; 91 | ; (perf0 n-perf) 29.1 92 | ; (perf1 n-perf) 30.0 93 | ; (perf2 n-perf) 45.5 94 | ; 95 | ; (perf0s n-perf) 79.2 96 | ; (perf1s n-perf) 448.6 97 | ; (perf2s n-perf) 756.2 98 | ; 99 | ; [All times are CPU time in seconds for n-perf iterations.] 100 | 101 | -------------------------------------------------------------------------------- /srfi/%3a43.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :43) 4 | (export 5 | list->vector 6 | make-vector 7 | reverse-list->vector 8 | reverse-vector->list 9 | vector 10 | vector->list 11 | vector-any 12 | vector-append 13 | vector-binary-search 14 | vector-concatenate 15 | vector-copy 16 | vector-copy! 17 | vector-count 18 | vector-empty? 19 | vector-every 20 | vector-fill! 21 | vector-fold 22 | vector-fold-right 23 | vector-for-each 24 | vector-index 25 | vector-index-right 26 | vector-length 27 | vector-map 28 | vector-map! 29 | vector-ref 30 | vector-reverse! 31 | vector-reverse-copy 32 | vector-reverse-copy! 33 | vector-set! 34 | vector-skip 35 | vector-skip-right 36 | vector-swap! 37 | vector-unfold 38 | vector-unfold-right 39 | vector= 40 | vector?) 41 | (import (srfi :43 vectors)) 42 | ) 43 | -------------------------------------------------------------------------------- /srfi/%3a43/vectors.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :43 vectors) 8 | (export 9 | ;;; * Constructors 10 | make-vector vector 11 | vector-unfold vector-unfold-right 12 | vector-copy vector-reverse-copy 13 | vector-append vector-concatenate 14 | ;;; * Predicates 15 | vector? 16 | vector-empty? 17 | vector= 18 | ;;; * Selectors 19 | vector-ref 20 | vector-length 21 | ;;; * Iteration 22 | vector-fold vector-fold-right 23 | vector-map vector-map! 24 | vector-for-each 25 | vector-count 26 | ;;; * Searching 27 | vector-index vector-skip 28 | vector-index-right vector-skip-right 29 | vector-binary-search vector-any vector-every 30 | ;;; * Mutators 31 | vector-set! 32 | vector-swap! 33 | (rename (my:vector-fill! vector-fill!)) 34 | vector-reverse! 35 | vector-copy! vector-reverse-copy! 36 | ;;; * Conversion 37 | (rename (my:vector->list vector->list)) reverse-vector->list 38 | (rename (my:list->vector list->vector)) reverse-list->vector ) 39 | (import 40 | (except (rnrs) vector-map vector-for-each) 41 | (rnrs r5rs) 42 | (srfi :23 error tricks) 43 | (srfi :8 receive) 44 | (for (srfi private vanish) expand) 45 | (srfi private include)) 46 | 47 | ;; I do these let-syntax tricks so the original vector-lib.scm file does 48 | ;; not have to be modified at all. 49 | (let-syntax 50 | ((define 51 | (let ((vd (vanish-define define 52 | (make-vector vector vector? vector-ref vector-set! vector-length)))) 53 | (lambda (stx) 54 | (define (rename? id) 55 | (memp (lambda (x) (free-identifier=? id x)) 56 | (list #'vector-fill! #'vector->list #'list->vector))) 57 | (define (rename id) 58 | (datum->syntax id 59 | (string->symbol 60 | (string-append "my:" (symbol->string (syntax->datum id)))))) 61 | (syntax-case stx () 62 | ((_ name . r) 63 | (and (identifier? #'name) 64 | (rename? #'name)) 65 | #`(define #,(rename #'name) . r)) 66 | (_ (vd stx)))))) 67 | (define-syntax 68 | (vanish-define define-syntax 69 | (receive)))) 70 | (SRFI-23-error->R6RS "(library (srfi :43 vectors))" 71 | (include/resolve ("srfi" "%3a43") "vector-lib.scm"))) 72 | ) 73 | -------------------------------------------------------------------------------- /srfi/%3a48.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :48) 4 | (export 5 | format) 6 | (import (srfi :48 intermediate-format-strings)) 7 | ) 8 | -------------------------------------------------------------------------------- /srfi/%3a48/intermediate-format-strings/compat.ikarus.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :48 intermediate-format-strings compat) 7 | (export 8 | pretty-print) 9 | (import 10 | (only (ikarus) pretty-print)) 11 | ) 12 | -------------------------------------------------------------------------------- /srfi/%3a48/intermediate-format-strings/compat.larceny.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :48 intermediate-format-strings compat) 7 | (export 8 | pretty-print) 9 | (import 10 | (primitives pretty-print)) 11 | ) 12 | -------------------------------------------------------------------------------- /srfi/%3a48/intermediate-format-strings/compat.mzscheme.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :48 intermediate-format-strings compat) 8 | (export 9 | pretty-print) 10 | (import 11 | (only (scheme pretty) pretty-print)) 12 | ) 13 | -------------------------------------------------------------------------------- /srfi/%3a48/intermediate-format-strings/compat.ypsilon.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :48 intermediate-format-strings compat) 7 | (export 8 | pretty-print) 9 | (import 10 | (only (core) pretty-print)) 11 | ) 12 | -------------------------------------------------------------------------------- /srfi/%3a6.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :6) 4 | (export 5 | get-output-string 6 | open-input-string 7 | open-output-string) 8 | (import (srfi :6 basic-string-ports)) 9 | ) 10 | -------------------------------------------------------------------------------- /srfi/%3a6/basic-string-ports.mzscheme.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :6 basic-string-ports) 8 | (export 9 | (rename (open-string-input-port open-input-string)) 10 | open-output-string 11 | get-output-string) 12 | (import 13 | (rnrs) 14 | (only (scheme base) make-weak-hasheq hash-ref hash-set!)) 15 | 16 | (define accumed-ht (make-weak-hasheq)) 17 | 18 | (define (open-output-string) 19 | (letrec ([sop 20 | (make-custom-textual-output-port 21 | "string-output-port" 22 | (lambda (string start count) ; write! 23 | (when (positive? count) 24 | (let ([al (hash-ref accumed-ht sop)]) 25 | (hash-set! accumed-ht sop 26 | (cons (substring string start (+ start count)) al)))) 27 | count) 28 | #f ; get-position TODO? 29 | #f ; set-position! TODO? 30 | #f #| closed TODO? |# )]) 31 | (hash-set! accumed-ht sop '()) 32 | sop)) 33 | 34 | (define (get-output-string sop) 35 | (if (output-port? sop) 36 | (cond [(hash-ref accumed-ht sop #f) 37 | => (lambda (al) (apply string-append (reverse al)))] 38 | [else 39 | (assertion-violation 'get-output-string "not a string-output-port" sop)]) 40 | (assertion-violation 'get-output-string "not an output-port" sop))) 41 | 42 | ) 43 | -------------------------------------------------------------------------------- /srfi/%3a6/basic-string-ports.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :6 basic-string-ports) 8 | (export 9 | open-input-string 10 | open-output-string 11 | get-output-string) 12 | (import 13 | (rnrs base) 14 | (only (rnrs io ports) open-string-input-port) 15 | (srfi :6 basic-string-ports compat)) 16 | 17 | (define (open-input-string str) 18 | (open-string-input-port str)) 19 | ) 20 | -------------------------------------------------------------------------------- /srfi/%3a6/basic-string-ports/compat.chezscheme.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (srfi :6 basic-string-ports compat) 3 | 4 | (export open-output-string get-output-string) 5 | 6 | (import (only (chezscheme) open-output-string get-output-string))) -------------------------------------------------------------------------------- /srfi/%3a6/basic-string-ports/compat.ikarus.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :6 basic-string-ports compat) 7 | (export 8 | open-output-string get-output-string) 9 | (import 10 | (only (ikarus) open-output-string get-output-string))) 11 | -------------------------------------------------------------------------------- /srfi/%3a6/basic-string-ports/compat.larceny.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :6 basic-string-ports compat) 7 | (export 8 | open-output-string get-output-string) 9 | (import 10 | (primitives 11 | open-output-string get-output-string)) 12 | ) -------------------------------------------------------------------------------- /srfi/%3a6/basic-string-ports/compat.ypsilon.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :6 basic-string-ports compat) 8 | (export 9 | (rename 10 | (make-string-output-port open-output-string) 11 | (get-accumulated-string get-output-string))) 12 | (import 13 | (only (core) make-string-output-port get-accumulated-string)) 14 | ) 15 | -------------------------------------------------------------------------------- /srfi/%3a61.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :61) 4 | (export 5 | cond) 6 | (import (srfi :61 cond)) 7 | ) 8 | -------------------------------------------------------------------------------- /srfi/%3a61/cond.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :61 cond) 8 | (export 9 | (rename (general-cond cond))) 10 | (import 11 | (rnrs)) 12 | 13 | (define-syntax general-cond 14 | (lambda (stx) 15 | (syntax-case stx () 16 | [(_ clauses ...) 17 | (with-syntax ([(ours ...) 18 | (map (lambda (c) 19 | (syntax-case c (=>) 20 | [(generator guard => receiver) 21 | #'((let-values ([vals generator]) 22 | (and (apply guard vals) 23 | vals)) 24 | => (lambda (vals) 25 | (apply receiver vals)))] 26 | [_ c])) 27 | #'(clauses ...))]) 28 | #'(cond ours ...))]))) 29 | ) 30 | -------------------------------------------------------------------------------- /srfi/%3a64.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :64) 4 | (export 5 | test-apply 6 | test-approximate 7 | test-assert 8 | test-begin 9 | test-end 10 | test-eq 11 | test-equal 12 | test-eqv 13 | test-error 14 | test-expect-fail 15 | test-group 16 | test-group-with-cleanup 17 | test-log-to-file 18 | test-match-all 19 | test-match-any 20 | test-match-name 21 | test-match-nth 22 | test-on-bad-count-simple 23 | test-on-bad-end-name-simple 24 | test-on-final-simple 25 | test-on-group-begin-simple 26 | test-on-group-end-simple 27 | test-on-test-end-simple 28 | test-passed? 29 | test-read-eval-string 30 | test-result-alist 31 | test-result-alist! 32 | test-result-clear 33 | test-result-kind 34 | test-result-ref 35 | test-result-remove 36 | test-result-set! 37 | test-runner-aux-value 38 | test-runner-aux-value! 39 | test-runner-create 40 | test-runner-current 41 | test-runner-factory 42 | test-runner-fail-count 43 | test-runner-fail-count! 44 | test-runner-get 45 | test-runner-group-path 46 | test-runner-group-stack 47 | test-runner-group-stack! 48 | test-runner-null 49 | test-runner-on-bad-count 50 | test-runner-on-bad-count! 51 | test-runner-on-bad-end-name 52 | test-runner-on-bad-end-name! 53 | test-runner-on-final 54 | test-runner-on-final! 55 | test-runner-on-group-begin 56 | test-runner-on-group-begin! 57 | test-runner-on-group-end 58 | test-runner-on-group-end! 59 | test-runner-on-test-begin 60 | test-runner-on-test-begin! 61 | test-runner-on-test-end 62 | test-runner-on-test-end! 63 | test-runner-pass-count 64 | test-runner-pass-count! 65 | test-runner-reset 66 | test-runner-simple 67 | test-runner-skip-count 68 | test-runner-skip-count! 69 | test-runner-test-name 70 | test-runner-xfail-count 71 | test-runner-xfail-count! 72 | test-runner-xpass-count 73 | test-runner-xpass-count! 74 | test-runner? 75 | test-skip 76 | test-with-runner) 77 | (import (srfi :64 testing)) 78 | ) 79 | -------------------------------------------------------------------------------- /srfi/%3a64/testing.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :64 testing) 8 | (export 9 | test-begin 10 | test-end test-assert test-eqv test-eq test-equal 11 | test-approximate test-error test-apply test-with-runner 12 | test-match-nth test-match-all test-match-any test-match-name 13 | test-skip test-expect-fail test-read-eval-string 14 | test-group test-runner-group-path test-group-with-cleanup 15 | test-result-ref test-result-set! test-result-clear test-result-remove 16 | test-result-kind test-passed? 17 | (rename (%test-log-to-file test-log-to-file)) 18 | ; Misc test-runner functions 19 | test-runner? test-runner-reset test-runner-null 20 | test-runner-simple test-runner-current test-runner-factory test-runner-get 21 | test-runner-create test-runner-test-name 22 | ;; test-runner field setter and getter functions - see %test-record-define: 23 | test-runner-pass-count test-runner-pass-count! 24 | test-runner-fail-count test-runner-fail-count! 25 | test-runner-xpass-count test-runner-xpass-count! 26 | test-runner-xfail-count test-runner-xfail-count! 27 | test-runner-skip-count test-runner-skip-count! 28 | test-runner-group-stack test-runner-group-stack! 29 | test-runner-on-test-begin test-runner-on-test-begin! 30 | test-runner-on-test-end test-runner-on-test-end! 31 | test-runner-on-group-begin test-runner-on-group-begin! 32 | test-runner-on-group-end test-runner-on-group-end! 33 | test-runner-on-final test-runner-on-final! 34 | test-runner-on-bad-count test-runner-on-bad-count! 35 | test-runner-on-bad-end-name test-runner-on-bad-end-name! 36 | test-result-alist test-result-alist! 37 | test-runner-aux-value test-runner-aux-value! 38 | ;; default/simple call-back functions, used in default test-runner, 39 | ;; but can be called to construct more complex ones. 40 | test-on-group-begin-simple test-on-group-end-simple 41 | test-on-bad-count-simple test-on-bad-end-name-simple 42 | test-on-final-simple test-on-test-end-simple) 43 | (import 44 | (rnrs base) 45 | (rnrs control) 46 | (rnrs exceptions) 47 | (rnrs io simple) 48 | (rnrs lists) 49 | (rename (rnrs eval) (eval rnrs:eval)) 50 | (rnrs mutable-pairs) 51 | (srfi :0 cond-expand) 52 | (only (srfi :1 lists) reverse!) 53 | (srfi :6 basic-string-ports) 54 | (srfi :9 records) 55 | (srfi :39 parameters) 56 | (srfi :23 error tricks) 57 | (srfi private include)) 58 | 59 | (define (eval form) 60 | (rnrs:eval form (environment '(rnrs) 61 | '(rnrs eval) 62 | '(rnrs mutable-pairs) 63 | '(rnrs mutable-strings) 64 | '(rnrs r5rs)))) 65 | 66 | (define %test-log-to-file 67 | (case-lambda 68 | (() test-log-to-file) 69 | ((val) (set! test-log-to-file val)))) 70 | 71 | (SRFI-23-error->R6RS "(library (srfi :64 testing))" 72 | (include/resolve ("srfi" "%3a64") "testing.scm")) 73 | ) 74 | -------------------------------------------------------------------------------- /srfi/%3a67.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :67) 4 | (export 5 | </<=? 6 | </<? 7 | <=/<=? 8 | <=/<? 9 | <=? 10 | <? 11 | =? 12 | >/>=? 13 | >/>? 14 | >=/>=? 15 | >=/>? 16 | >=? 17 | >? 18 | boolean-compare 19 | chain<=? 20 | chain<? 21 | chain=? 22 | chain>=? 23 | chain>? 24 | char-compare 25 | char-compare-ci 26 | compare-by< 27 | compare-by<= 28 | compare-by=/< 29 | compare-by=/> 30 | compare-by> 31 | compare-by>= 32 | complex-compare 33 | cond-compare 34 | debug-compare 35 | default-compare 36 | if-not=? 37 | if3 38 | if<=? 39 | if<? 40 | if=? 41 | if>=? 42 | if>? 43 | integer-compare 44 | kth-largest 45 | list-compare 46 | list-compare-as-vector 47 | max-compare 48 | min-compare 49 | not=? 50 | number-compare 51 | pair-compare 52 | pair-compare-car 53 | pair-compare-cdr 54 | pairwise-not=? 55 | rational-compare 56 | real-compare 57 | refine-compare 58 | select-compare 59 | string-compare 60 | string-compare-ci 61 | symbol-compare 62 | vector-compare 63 | vector-compare-as-list) 64 | (import (srfi :67 compare-procedures)) 65 | ) 66 | -------------------------------------------------------------------------------- /srfi/%3a67/compare-procedures.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :67 compare-procedures) 8 | (export </<=? </<? <=/<=? <=/<? <=? <? =? 9 | >/>=? >/>? >=/>=? >=/>? >=? >? 10 | boolean-compare chain<=? chain<? chain=? chain>=? chain>? 11 | char-compare char-compare-ci 12 | compare-by< compare-by<= compare-by=/< compare-by=/> compare-by> 13 | compare-by>= complex-compare cond-compare 14 | debug-compare default-compare 15 | if-not=? if3 if<=? if<? if=? if>=? if>? integer-compare 16 | kth-largest list-compare list-compare-as-vector 17 | max-compare min-compare not=? number-compare 18 | pair-compare pair-compare-car pair-compare-cdr 19 | pairwise-not=? rational-compare real-compare 20 | refine-compare select-compare string-compare string-compare-ci 21 | symbol-compare vector-compare vector-compare-as-list) 22 | 23 | (import (rnrs) 24 | (rnrs r5rs) ; for modulo 25 | (srfi :27 random-bits) ; for random-integer 26 | (srfi :23 error tricks) 27 | (srfi private include)) 28 | 29 | (SRFI-23-error->R6RS "(library (srfi :67 compare-procedures))" 30 | (include/resolve ("srfi" "%3a67") "compare.ss")) 31 | ) 32 | -------------------------------------------------------------------------------- /srfi/%3a69.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :69) 4 | (export 5 | alist->hash-table 6 | hash 7 | hash-by-identity 8 | hash-table->alist 9 | hash-table-copy 10 | hash-table-delete! 11 | hash-table-equivalence-function 12 | hash-table-exists? 13 | hash-table-fold 14 | hash-table-hash-function 15 | hash-table-keys 16 | hash-table-merge! 17 | hash-table-ref 18 | hash-table-ref/default 19 | hash-table-set! 20 | hash-table-size 21 | hash-table-update! 22 | hash-table-update!/default 23 | hash-table-values 24 | hash-table-walk 25 | hash-table? 26 | make-hash-table 27 | string-ci-hash 28 | string-hash) 29 | (import (srfi :69 basic-hash-tables)) 30 | ) 31 | -------------------------------------------------------------------------------- /srfi/%3a69/basic-hash-tables.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (C) 2009 Andreas Rottmann. All rights reserved. Licensed 3 | ;; under an MIT-style license. See the file LICENSE in the original 4 | ;; collection this file is distributed with. 5 | 6 | (library (srfi :69 basic-hash-tables) 7 | (export 8 | ;; Type constructors and predicate 9 | make-hash-table hash-table? alist->hash-table 10 | 11 | ;; Reflective queries 12 | hash-table-equivalence-function hash-table-hash-function 13 | 14 | ;; Dealing with single elements 15 | hash-table-ref hash-table-ref/default hash-table-set! 16 | hash-table-delete! hash-table-exists? 17 | hash-table-update! hash-table-update!/default 18 | 19 | ;; Dealing with the whole contents 20 | hash-table-size hash-table-keys hash-table-values hash-table-walk 21 | hash-table-fold hash-table->alist hash-table-copy hash-table-merge! 22 | 23 | ;; Hashing 24 | hash string-hash string-ci-hash hash-by-identity) 25 | (import 26 | (rename (rnrs) 27 | (string-hash rnrs:string-hash) 28 | (string-ci-hash rnrs:string-ci-hash))) 29 | 30 | (define make-hash-table 31 | (case-lambda 32 | ((eql? hash) 33 | (make-hashtable hash eql?)) 34 | ((eql?) 35 | (cond ((eq? eql? eq?) 36 | (make-eq-hashtable)) 37 | ((eq? eql? eqv?) 38 | (make-eqv-hashtable)) 39 | ((eq? eql? equal?) 40 | (make-hashtable equal-hash eql?)) 41 | ((eq? eql? string=?) 42 | (make-hashtable rnrs:string-hash eql?)) 43 | ((eq? eql? string-ci=?) 44 | (make-hashtable rnrs:string-ci-hash eql?)) 45 | (else 46 | (assertion-violation 'make-hash-table 47 | "unrecognized equivalence predicate" eql?)))) 48 | (() 49 | (make-hashtable equal-hash equal?)))) 50 | 51 | (define hash-table? hashtable?) 52 | 53 | (define not-there (list 'not-there)) 54 | 55 | (define (alist->hash-table alist . args) 56 | (let ((table (apply make-hash-table args))) 57 | (for-each (lambda (entry) 58 | (hashtable-update! table 59 | (car entry) 60 | (lambda (x) 61 | (if (eq? x not-there) (cdr entry) x)) 62 | not-there)) 63 | alist) 64 | table)) 65 | 66 | (define hash-table-equivalence-function hashtable-equivalence-function) 67 | (define hash-table-hash-function hashtable-hash-function) 68 | 69 | (define (failure-thunk who key) 70 | (lambda () 71 | (assertion-violation who "no association for key" key))) 72 | 73 | (define hash-table-ref 74 | (case-lambda 75 | ((table key thunk) 76 | (let ((val (hashtable-ref table key not-there))) 77 | (if (eq? val not-there) 78 | (thunk) 79 | val))) 80 | ((table key) 81 | (hash-table-ref table key (failure-thunk 'hash-table-ref key))))) 82 | 83 | (define hash-table-ref/default hashtable-ref) 84 | (define hash-table-set! hashtable-set!) 85 | (define hash-table-delete! hashtable-delete!) 86 | (define hash-table-exists? hashtable-contains?) 87 | 88 | (define hash-table-update! 89 | (case-lambda 90 | ((table key proc thunk) 91 | (hashtable-update! table 92 | key 93 | (lambda (val) 94 | (if (eq? val not-there) 95 | (thunk) 96 | (proc val))) 97 | not-there)) 98 | ((table key proc) 99 | (hash-table-update! table key proc (failure-thunk 'hash-table-update! key))))) 100 | 101 | (define hash-table-update!/default hashtable-update!) 102 | 103 | (define hash-table-size hashtable-size) 104 | 105 | (define (hash-table-keys table) 106 | (vector->list (hashtable-keys table))) 107 | 108 | (define (hash-table-values table) 109 | (let-values (((keys values) (hashtable-entries table))) 110 | (vector->list values))) 111 | 112 | (define (hash-table-walk table proc) 113 | (let-values (((keys values) (hashtable-entries table))) 114 | (vector-for-each proc keys values))) 115 | 116 | (define (hash-table-fold table kons knil) 117 | (let-values (((keys values) (hashtable-entries table))) 118 | (let ((size (vector-length keys))) 119 | (let loop ((i 0) 120 | (val knil)) 121 | (if (>= i size) 122 | val 123 | (loop (+ i 1) 124 | (kons (vector-ref keys i) (vector-ref values i) val))))))) 125 | 126 | (define (hash-table->alist table) 127 | (hash-table-fold table 128 | (lambda (k v l) 129 | (cons (cons k v) l)) 130 | '())) 131 | 132 | (define hash-table-copy hashtable-copy) 133 | 134 | (define (hash-table-merge! table1 table2) 135 | (hash-table-walk table2 (lambda (k v) 136 | (hashtable-set! table1 k v))) 137 | table1) 138 | 139 | (define (make-hasher hash-proc) 140 | (case-lambda 141 | ((obj) 142 | ;; R6RS doesn't guarantee that the result of the hash procedure 143 | ;; is non-negative, so we use mod. 144 | (mod (hash-proc obj) (greatest-fixnum))) 145 | ((obj bound) 146 | (mod (hash-proc obj) bound)))) 147 | 148 | (define hash (make-hasher equal-hash)) 149 | (define hash-by-identity (make-hasher equal-hash)) ;; Very slow. 150 | (define string-hash (make-hasher rnrs:string-hash)) 151 | (define string-ci-hash (make-hasher rnrs:string-ci-hash)) 152 | 153 | ) 154 | -------------------------------------------------------------------------------- /srfi/%3a78.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :78) 4 | (export 5 | check 6 | check-ec 7 | check-passed? 8 | check-report 9 | check-reset! 10 | check-set-mode!) 11 | (import (srfi :78 lightweight-testing)) 12 | ) 13 | -------------------------------------------------------------------------------- /srfi/%3a78/lightweight-testing.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :78 lightweight-testing) 8 | (export 9 | check 10 | check-ec 11 | check-report 12 | check-set-mode! 13 | check-reset! 14 | check-passed?) 15 | (import 16 | (rnrs) 17 | (srfi :78 lightweight-testing compat) 18 | (srfi :39 parameters) 19 | (srfi private include) 20 | (srfi :23 error tricks) 21 | (srfi :42 eager-comprehensions)) 22 | 23 | (SRFI-23-error->R6RS "(library (srfi :78 lightweight-testing))" 24 | (include/resolve ("srfi" "%3a78") "check.scm")) 25 | ) 26 | -------------------------------------------------------------------------------- /srfi/%3a78/lightweight-testing/compat.ikarus.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :78 lightweight-testing compat) 7 | (export 8 | (rename (pretty-print check:write))) 9 | (import 10 | (only (ikarus) pretty-print)) 11 | ) 12 | -------------------------------------------------------------------------------- /srfi/%3a78/lightweight-testing/compat.larceny.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :78 lightweight-testing compat) 7 | (export 8 | (rename (pretty-print check:write))) 9 | (import 10 | (primitives pretty-print)) 11 | ) 12 | -------------------------------------------------------------------------------- /srfi/%3a78/lightweight-testing/compat.mzscheme.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :78 lightweight-testing compat) 8 | (export 9 | (rename (pretty-print check:write))) 10 | (import 11 | (only (scheme pretty) pretty-print)) 12 | ) 13 | -------------------------------------------------------------------------------- /srfi/%3a78/lightweight-testing/compat.ypsilon.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi :78 lightweight-testing compat) 7 | (export 8 | check:write) 9 | (import 10 | (rnrs) 11 | (only (core) pretty-print)) 12 | 13 | (define check:write 14 | (case-lambda 15 | ((x) (check:write x (current-output-port))) 16 | ((x p) 17 | (pretty-print x p) 18 | (newline p)))) 19 | ) 20 | -------------------------------------------------------------------------------- /srfi/%3a8.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :8) 4 | (export 5 | receive) 6 | (import (srfi :8 receive)) 7 | ) 8 | -------------------------------------------------------------------------------- /srfi/%3a8/receive.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :8 receive) 8 | (export receive) 9 | (import (rnrs)) 10 | 11 | (define-syntax receive 12 | (syntax-rules () 13 | [(_ formals expression b b* ...) 14 | (call-with-values 15 | (lambda () expression) 16 | (lambda formals b b* ...))])) 17 | 18 | ) 19 | -------------------------------------------------------------------------------- /srfi/%3a9.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :9) 4 | (export 5 | define-record-type) 6 | (import (srfi :9 records)) 7 | ) 8 | -------------------------------------------------------------------------------- /srfi/%3a9/records.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi :9 records) 8 | (export 9 | (rename (srfi:define-record-type define-record-type))) 10 | (import 11 | (rnrs)) 12 | 13 | (define-syntax srfi:define-record-type 14 | (lambda (stx) 15 | (syntax-case stx () 16 | [(_ type (constructor constructor-tag ...) 17 | predicate 18 | (field-tag accessor setter ...) ...) 19 | (and (for-all identifier? 20 | #'(type constructor predicate constructor-tag ... 21 | field-tag ... accessor ...)) 22 | (for-all (lambda (s) 23 | (or (and (= 1 (length s)) (identifier? (car s))) 24 | (= 0 (length s)))) 25 | #'((setter ...) ...)) 26 | (for-all (lambda (ct) 27 | (memp (lambda (ft) (bound-identifier=? ct ft)) 28 | #'(field-tag ...))) 29 | #'(constructor-tag ...))) 30 | (with-syntax ([(field-clause ...) 31 | (map (lambda (clause) 32 | (if (= 2 (length clause)) 33 | #`(immutable . #,clause) 34 | #`(mutable . #,clause))) 35 | #'((field-tag accessor setter ...) ...))] 36 | [(unspec-tag ...) 37 | (remp (lambda (ft) 38 | (memp (lambda (ct) (bound-identifier=? ft ct)) 39 | #'(constructor-tag ...))) 40 | #'(field-tag ...))]) 41 | #'(define-record-type (type constructor predicate) 42 | (sealed #t) 43 | (protocol (lambda (ctor) 44 | (lambda (constructor-tag ...) 45 | (define unspec-tag) 46 | ... 47 | (ctor field-tag ...)))) 48 | (fields field-clause ...)))]))) 49 | 50 | ) 51 | -------------------------------------------------------------------------------- /srfi/%3a98.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :98) 4 | (export 5 | get-environment-variable 6 | get-environment-variables) 7 | (import (srfi :98 os-environment-variables)) 8 | ) 9 | -------------------------------------------------------------------------------- /srfi/%3a98/os-environment-variables.ikarus.sls: -------------------------------------------------------------------------------- 1 | (library (srfi :98 os-environment-variables) 2 | (export 3 | (rename (getenv get-environment-variable) 4 | (environ get-environment-variables))) 5 | (import 6 | (only (ikarus) getenv environ))) 7 | -------------------------------------------------------------------------------- /srfi/%3a98/os-environment-variables.larceny.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | ;; NOTE: I believe this currently works only on Linux. 7 | ;; NOTE: If Larceny's FFI changes, this may no longer work. 8 | 9 | (library (srfi :98 os-environment-variables) 10 | (export 11 | get-environment-variable get-environment-variables) 12 | (import 13 | (rnrs base) 14 | (rnrs control) 15 | (rnrs bytevectors) 16 | (rnrs io ports) 17 | (primitives 18 | foreign-procedure #;foreign-variable foreign-null-pointer? sizeof:pointer 19 | %peek-pointer %peek8u void*->address ffi/dlopen ffi/dlsym) 20 | (srfi private feature-cond)) 21 | 22 | ;; TODO: Will the convenient string converters use the native transcoder in 23 | ;; the future? So that scheme-str->c-str-bv and c-str-ptr->scheme-str 24 | ;; won't be needed. 25 | 26 | (define (scheme-str->c-str-bv x) 27 | (let* ((bv (string->bytevector x (native-transcoder))) 28 | (len (bytevector-length bv)) 29 | (bv/z (make-bytevector (+ 1 len)))) 30 | (bytevector-copy! bv 0 bv/z 0 len) 31 | (bytevector-u8-set! bv/z len 0) 32 | bv/z)) 33 | 34 | (define (c-str-ptr->scheme-str x) 35 | (let loop ((x x) (a '())) 36 | (let ((b (%peek8u x))) 37 | (if (zero? b) 38 | (bytevector->string (u8-list->bytevector (reverse a)) 39 | (native-transcoder)) 40 | (loop (+ 1 x) (cons b a)))))) 41 | 42 | (define getenv 43 | (foreign-procedure "getenv" '(boxed) 'void*)) 44 | 45 | (define (get-environment-variable name) 46 | (unless (string? name) 47 | (assertion-violation 'get-environment-variable "not a string" name)) 48 | (let ((p (getenv (scheme-str->c-str-bv name)))) 49 | (and p 50 | (c-str-ptr->scheme-str (void*->address p))))) 51 | 52 | ;; TODO: Will foreign-variable support a pointer type in the future? 53 | ;; Would this be the correct way to use it? 54 | #;(define environ 55 | (foreign-variable "environ" 'void*)) 56 | 57 | ;; TODO: Is (ffi/dlopen "") okay? It works for me on Ubuntu Linux 8.10. 58 | (define environ 59 | (feature-cond 60 | (linux 61 | (%peek-pointer (ffi/dlsym (ffi/dlopen "") "environ"))))) 62 | 63 | (define (get-environment-variables) 64 | (define (entry->pair x) 65 | (let* ((s (c-str-ptr->scheme-str x)) 66 | (len (string-length s))) 67 | (let loop ((i 0)) 68 | (if (< i len) 69 | (if (char=? #\= (string-ref s i)) 70 | (cons (substring s 0 i) 71 | (substring s (+ 1 i) len)) 72 | (loop (+ 1 i))) 73 | (cons s #F))))) 74 | (let loop ((e environ) (a '())) 75 | (let ((entry (%peek-pointer e))) 76 | (if (foreign-null-pointer? entry) 77 | a 78 | (loop (+ sizeof:pointer e) 79 | (cons (entry->pair entry) a)))))) 80 | ) 81 | -------------------------------------------------------------------------------- /srfi/%3a98/os-environment-variables.mzscheme.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | ;; Inspired by Danny Yoo's get-environment PLaneT package. 7 | 8 | #!r6rs 9 | (library (srfi :98 os-environment-variables) 10 | (export 11 | (rename (getenv get-environment-variable)) 12 | get-environment-variables) 13 | (import 14 | (rnrs base) 15 | (only (scheme base) getenv) 16 | (scheme foreign)) 17 | 18 | (unsafe!) 19 | 20 | (define environ (get-ffi-obj "environ" (ffi-lib #F) _pointer)) 21 | 22 | (define (get-environment-variables) 23 | (let loop ((i 0) (accum '())) 24 | (let ((next (ptr-ref environ _string/locale i))) 25 | (if next 26 | (loop (+ 1 i) 27 | (cons (let loop ((i 0) (len (string-length next))) 28 | (if (< i len) 29 | (if (char=? #\= (string-ref next i)) 30 | (cons (substring next 0 i) 31 | (substring next (+ 1 i) len)) 32 | (loop (+ 1 i) len)) 33 | (cons next #F))) 34 | accum)) 35 | accum)))) 36 | ) 37 | -------------------------------------------------------------------------------- /srfi/%3a98/os-environment-variables.ypsilon.sls: -------------------------------------------------------------------------------- 1 | (library (srfi :98 os-environment-variables) 2 | (export 3 | (rename (lookup-process-environment get-environment-variable) 4 | (process-environment->alist get-environment-variables))) 5 | (import 6 | (only (core) lookup-process-environment process-environment->alist))) 7 | -------------------------------------------------------------------------------- /srfi/%3a99.sls: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by private/make-aliased-libraries.sps 2 | #!r6rs 3 | (library (srfi :99) 4 | (export 5 | define-record-type 6 | make-rtd 7 | record-rtd 8 | record? 9 | rtd-accessor 10 | rtd-all-field-names 11 | rtd-constructor 12 | rtd-field-mutable? 13 | rtd-field-names 14 | rtd-mutator 15 | rtd-name 16 | rtd-parent 17 | rtd-predicate 18 | rtd?) 19 | (import (srfi :99 records)) 20 | ) 21 | -------------------------------------------------------------------------------- /srfi/%3a99/records.sls: -------------------------------------------------------------------------------- 1 | (library (srfi :99 records) 2 | (export 3 | make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator 4 | record? record-rtd rtd-name rtd-parent 5 | rtd-field-names rtd-all-field-names rtd-field-mutable? 6 | define-record-type) 7 | (import (srfi :99 records procedural) 8 | (srfi :99 records inspection) 9 | (srfi :99 records syntactic))) 10 | -------------------------------------------------------------------------------- /srfi/%3a99/records/helper.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (C) William D Clinger 2008. All Rights Reserved. 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 4 | ;; of this software and associated documentation files (the "Software"), to deal 5 | ;; in the Software without restriction, including without limitation the rights 6 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | ;; copies of the Software, and to permit persons to whom the Software is 8 | ;; furnished to do so, subject to the following conditions: 9 | ;; 10 | ;; The above copyright notice and this permission notice shall be included in 11 | ;; all copies or substantial portions of the Software. 12 | ;; 13 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. REMEMBER, THERE IS NO 16 | ;; SCHEME UNDERGROUND. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 17 | ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF 18 | ;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 19 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 20 | 21 | ; This library breaks a circular interdependence between the 22 | ; procedural and inspection libraries. 23 | 24 | #!r6rs 25 | (library (srfi :99 records helper) 26 | (export 27 | rtd?) 28 | (import 29 | (rnrs base) 30 | (rnrs records procedural)) 31 | 32 | (define rtd? record-type-descriptor?) 33 | ) 34 | -------------------------------------------------------------------------------- /srfi/%3a99/records/inspection.larceny.sls: -------------------------------------------------------------------------------- 1 | (library (srfi :99 records inspection) 2 | (export 3 | record? record-rtd rtd-name rtd-parent 4 | rtd-field-names rtd-all-field-names rtd-field-mutable?) 5 | (import (err5rs records inspection))) 6 | -------------------------------------------------------------------------------- /srfi/%3a99/records/inspection.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (C) William D Clinger 2008. All Rights Reserved. 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 4 | ;; of this software and associated documentation files (the "Software"), to deal 5 | ;; in the Software without restriction, including without limitation the rights 6 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | ;; copies of the Software, and to permit persons to whom the Software is 8 | ;; furnished to do so, subject to the following conditions: 9 | ;; 10 | ;; The above copyright notice and this permission notice shall be included in 11 | ;; all copies or substantial portions of the Software. 12 | ;; 13 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. REMEMBER, THERE IS NO 16 | ;; SCHEME UNDERGROUND. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 17 | ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF 18 | ;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 19 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 20 | 21 | #!r6rs 22 | (library (srfi :99 records inspection) 23 | 24 | (export record? record-rtd 25 | rtd-name rtd-parent 26 | rtd-field-names rtd-all-field-names rtd-field-mutable?) 27 | 28 | (import (rnrs base) 29 | (rnrs lists) 30 | (rnrs records inspection) 31 | (srfi :99 records helper)) 32 | 33 | ; The record? predicate is already defined by (rnrs records inspection). 34 | 35 | ; The record-rtd procedure is already defined by (rnrs records inspection). 36 | 37 | (define rtd-name record-type-name) 38 | 39 | (define rtd-parent record-type-parent) 40 | 41 | (define rtd-field-names record-type-field-names) 42 | 43 | (define (rtd-all-field-names rtd) 44 | (define (loop rtd othernames) 45 | (let ((parent (rtd-parent rtd)) 46 | (names (append (vector->list 47 | (rtd-field-names rtd)) 48 | othernames))) 49 | (if parent 50 | (loop parent names) 51 | (list->vector names)))) 52 | (loop rtd '())) 53 | 54 | (define (rtd-field-mutable? rtd0 fieldname) 55 | (define (loop rtd) 56 | (if (rtd? rtd) 57 | (let* ((names (vector->list (rtd-field-names rtd))) 58 | (probe (memq fieldname names))) 59 | (if probe 60 | (record-field-mutable? rtd (- (length names) (length probe))) 61 | (loop (rtd-parent rtd)))) 62 | (assertion-violation 'rtd-field-mutable? 63 | "illegal argument" rtd0 fieldname))) 64 | (loop rtd0)) 65 | 66 | ) 67 | -------------------------------------------------------------------------------- /srfi/%3a99/records/procedural.larceny.sls: -------------------------------------------------------------------------------- 1 | (library (srfi :99 records procedural) 2 | (export 3 | make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator) 4 | (import (err5rs records procedural))) 5 | -------------------------------------------------------------------------------- /srfi/%3a99/records/procedural.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (C) William D Clinger 2008. All Rights Reserved. 2 | ;; 3 | ;; Permission is hereby granted, free of charge, to any person obtaining a copy 4 | ;; of this software and associated documentation files (the "Software"), to deal 5 | ;; in the Software without restriction, including without limitation the rights 6 | ;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | ;; copies of the Software, and to permit persons to whom the Software is 8 | ;; furnished to do so, subject to the following conditions: 9 | ;; 10 | ;; The above copyright notice and this permission notice shall be included in 11 | ;; all copies or substantial portions of the Software. 12 | ;; 13 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. REMEMBER, THERE IS NO 16 | ;; SCHEME UNDERGROUND. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 17 | ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF 18 | ;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 19 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 20 | 21 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 22 | ; 23 | ; ERR5RS Records. 24 | ; 25 | ; This is a quick-and-dirty reference implementation that favors 26 | ; simplicity over quality error messages and performance. It is 27 | ; implemented using the R6RS procedural and inspection layers, 28 | ; with which it interoperates nicely. 29 | ; 30 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 31 | 32 | #!r6rs 33 | (library (srfi :99 records procedural) 34 | 35 | (export make-rtd rtd? rtd-constructor 36 | rtd-predicate rtd-accessor rtd-mutator) 37 | 38 | (import (rnrs base) 39 | (rnrs lists) 40 | (rnrs records procedural) 41 | (srfi :99 records inspection)) 42 | 43 | ; Note: the options are permitted by ERR5RS, 44 | ; but are not part of ERR5RS. 45 | 46 | (define (make-rtd name fieldspecs . rest) 47 | (let* ((parent (if (null? rest) #f (car rest))) 48 | (options (if (null? rest) '() (cdr rest))) 49 | (sealed? (and (memq 'sealed options) #t)) 50 | (opaque? (and (memq 'opaque options) #t)) 51 | (uid (let ((probe (memq 'uid options))) 52 | (if (and probe (not (null? (cdr probe)))) 53 | (cadr probe) 54 | #f)))) 55 | (make-record-type-descriptor 56 | name 57 | parent 58 | uid 59 | sealed? 60 | opaque? 61 | (vector-map (lambda (fieldspec) 62 | (if (symbol? fieldspec) 63 | (list 'mutable fieldspec) 64 | fieldspec)) 65 | fieldspecs)))) 66 | 67 | (define rtd? record-type-descriptor?) 68 | 69 | (define (rtd-constructor rtd . rest) 70 | 71 | ; Computes permutation and allocates permutation buffer 72 | ; when the constructor is created, not when the constructor 73 | ; is called. More error checking is recommended. 74 | 75 | (define (make-constructor fieldspecs allnames maker) 76 | (let* ((k (length fieldspecs)) 77 | (n (length allnames)) 78 | (buffer (make-vector n)) 79 | (reverse-all-names (reverse allnames))) 80 | 81 | (define (position fieldname) 82 | (let ((names (memq fieldname reverse-all-names))) 83 | (assert names) 84 | (- (length names) 1))) 85 | 86 | (let ((indexes (map position fieldspecs))) 87 | 88 | ; The following can be made quite efficient by 89 | ; hand-coding it in some lower-level language, 90 | ; e.g. Larceny's mal. Even case-lambda would 91 | ; be good enough in most systems. 92 | 93 | (lambda args 94 | (assert (= (length args) k)) 95 | (for-each (lambda (arg posn) 96 | (vector-set! buffer posn arg)) 97 | args indexes) 98 | (apply maker (vector->list buffer)))))) 99 | 100 | (if (null? rest) 101 | (record-constructor 102 | (make-record-constructor-descriptor rtd #f #f)) 103 | (begin (assert (null? (cdr rest))) 104 | (make-constructor 105 | (vector->list (car rest)) 106 | (vector->list (rtd-all-field-names rtd)) 107 | (record-constructor 108 | (make-record-constructor-descriptor rtd #f #f)))))) 109 | 110 | (define rtd-predicate record-predicate) 111 | 112 | (define (rtd-accessor rtd0 fieldname) 113 | (define (loop rtd) 114 | (if (rtd? rtd) 115 | (let* ((names (vector->list (rtd-field-names rtd))) 116 | (probe (memq fieldname names))) 117 | (if probe 118 | (record-accessor rtd (- (length names) (length probe))) 119 | (loop (rtd-parent rtd)))) 120 | (assertion-violation 'rtd-accessor 121 | "illegal argument" rtd0 fieldname))) 122 | (loop rtd0)) 123 | 124 | (define (rtd-mutator rtd0 fieldname) 125 | (define (loop rtd) 126 | (if (rtd? rtd) 127 | (let* ((names (vector->list (rtd-field-names rtd))) 128 | (probe (memq fieldname names))) 129 | (if probe 130 | (record-mutator rtd (- (length names) (length probe))) 131 | (loop (rtd-parent rtd)))) 132 | (assertion-violation 'rtd-mutator 133 | "illegal argument" rtd0 fieldname))) 134 | (loop rtd0)) 135 | 136 | ) 137 | -------------------------------------------------------------------------------- /srfi/%3a99/records/syntactic.larceny.sls: -------------------------------------------------------------------------------- 1 | (library (srfi :99 records syntactic) 2 | (export define-record-type) 3 | (import (err5rs records syntactic))) 4 | -------------------------------------------------------------------------------- /srfi/:0: -------------------------------------------------------------------------------- 1 | %3a0 -------------------------------------------------------------------------------- /srfi/:0.sls: -------------------------------------------------------------------------------- 1 | %3a0.sls -------------------------------------------------------------------------------- /srfi/:1: -------------------------------------------------------------------------------- 1 | %3a1 -------------------------------------------------------------------------------- /srfi/:1.sls: -------------------------------------------------------------------------------- 1 | %3a1.sls -------------------------------------------------------------------------------- /srfi/:11: -------------------------------------------------------------------------------- 1 | %3a11 -------------------------------------------------------------------------------- /srfi/:11.sls: -------------------------------------------------------------------------------- 1 | %3a11.sls -------------------------------------------------------------------------------- /srfi/:13: -------------------------------------------------------------------------------- 1 | %3a13 -------------------------------------------------------------------------------- /srfi/:13.sls: -------------------------------------------------------------------------------- 1 | %3a13.sls -------------------------------------------------------------------------------- /srfi/:14: -------------------------------------------------------------------------------- 1 | %3a14 -------------------------------------------------------------------------------- /srfi/:14.sls: -------------------------------------------------------------------------------- 1 | %3a14.sls -------------------------------------------------------------------------------- /srfi/:16: -------------------------------------------------------------------------------- 1 | %3a16 -------------------------------------------------------------------------------- /srfi/:16.sls: -------------------------------------------------------------------------------- 1 | %3a16.sls -------------------------------------------------------------------------------- /srfi/:19: -------------------------------------------------------------------------------- 1 | %3a19 -------------------------------------------------------------------------------- /srfi/:19.sls: -------------------------------------------------------------------------------- 1 | %3a19.sls -------------------------------------------------------------------------------- /srfi/:2: -------------------------------------------------------------------------------- 1 | %3a2 -------------------------------------------------------------------------------- /srfi/:2.sls: -------------------------------------------------------------------------------- 1 | %3a2.sls -------------------------------------------------------------------------------- /srfi/:23: -------------------------------------------------------------------------------- 1 | %3a23 -------------------------------------------------------------------------------- /srfi/:23.sls: -------------------------------------------------------------------------------- 1 | %3a23.sls -------------------------------------------------------------------------------- /srfi/:25: -------------------------------------------------------------------------------- 1 | %3a25 -------------------------------------------------------------------------------- /srfi/:25.sls: -------------------------------------------------------------------------------- 1 | %3a25.sls -------------------------------------------------------------------------------- /srfi/:26: -------------------------------------------------------------------------------- 1 | %3a26 -------------------------------------------------------------------------------- /srfi/:26.sls: -------------------------------------------------------------------------------- 1 | %3a26.sls -------------------------------------------------------------------------------- /srfi/:27: -------------------------------------------------------------------------------- 1 | %3a27 -------------------------------------------------------------------------------- /srfi/:27.sls: -------------------------------------------------------------------------------- 1 | %3a27.sls -------------------------------------------------------------------------------- /srfi/:31: -------------------------------------------------------------------------------- 1 | %3a31 -------------------------------------------------------------------------------- /srfi/:31.sls: -------------------------------------------------------------------------------- 1 | %3a31.sls -------------------------------------------------------------------------------- /srfi/:37: -------------------------------------------------------------------------------- 1 | %3a37 -------------------------------------------------------------------------------- /srfi/:37.sls: -------------------------------------------------------------------------------- 1 | %3a37.sls -------------------------------------------------------------------------------- /srfi/:39: -------------------------------------------------------------------------------- 1 | %3a39 -------------------------------------------------------------------------------- /srfi/:39.sls: -------------------------------------------------------------------------------- 1 | %3a39.sls -------------------------------------------------------------------------------- /srfi/:41: -------------------------------------------------------------------------------- 1 | %3a41 -------------------------------------------------------------------------------- /srfi/:41.sls: -------------------------------------------------------------------------------- 1 | %3a41.sls -------------------------------------------------------------------------------- /srfi/:42: -------------------------------------------------------------------------------- 1 | %3a42 -------------------------------------------------------------------------------- /srfi/:42.sls: -------------------------------------------------------------------------------- 1 | %3a42.sls -------------------------------------------------------------------------------- /srfi/:43: -------------------------------------------------------------------------------- 1 | %3a43 -------------------------------------------------------------------------------- /srfi/:43.sls: -------------------------------------------------------------------------------- 1 | %3a43.sls -------------------------------------------------------------------------------- /srfi/:6: -------------------------------------------------------------------------------- 1 | %3a6 -------------------------------------------------------------------------------- /srfi/:6.sls: -------------------------------------------------------------------------------- 1 | %3a6.sls -------------------------------------------------------------------------------- /srfi/:64: -------------------------------------------------------------------------------- 1 | %3a64 -------------------------------------------------------------------------------- /srfi/:64.sls: -------------------------------------------------------------------------------- 1 | %3a64.sls -------------------------------------------------------------------------------- /srfi/:69: -------------------------------------------------------------------------------- 1 | %3a69 -------------------------------------------------------------------------------- /srfi/:69.sls: -------------------------------------------------------------------------------- 1 | %3a69.sls -------------------------------------------------------------------------------- /srfi/:8: -------------------------------------------------------------------------------- 1 | %3a8 -------------------------------------------------------------------------------- /srfi/:8.sls: -------------------------------------------------------------------------------- 1 | %3a8.sls -------------------------------------------------------------------------------- /srfi/:9: -------------------------------------------------------------------------------- 1 | %3a9 -------------------------------------------------------------------------------- /srfi/:9.sls: -------------------------------------------------------------------------------- 1 | %3a9.sls -------------------------------------------------------------------------------- /srfi/LICENSE: -------------------------------------------------------------------------------- 1 | The following license applies to all files written by Derick Eddington, 2 | unless otherwise stated. 3 | 4 | =========================================================================== 5 | Copyright (c) 2008-2009 Derick Eddington 6 | 7 | Permission is hereby granted, free of charge, to any person obtaining a 8 | copy of this software and associated documentation files (the "Software"), 9 | to deal in the Software without restriction, including without limitation 10 | the rights to use, copy, modify, merge, publish, distribute, sublicense, 11 | and/or sell copies of the Software, and to permit persons to whom the 12 | Software is furnished to do so, subject to the following conditions: 13 | 14 | The above copyright notice and this permission notice shall be included in 15 | all copies or substantial portions of the Software. 16 | 17 | Except as contained in this notice, the name(s) of the above copyright 18 | holders shall not be used in advertising or otherwise to promote the sale, 19 | use or other dealings in this Software without prior written authorization. 20 | 21 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 22 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 23 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 24 | THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 25 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 26 | FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 27 | DEALINGS IN THE SOFTWARE. 28 | =========================================================================== 29 | 30 | 31 | Files written by others retain any copyright, license, and/or other notice 32 | they originally had. 33 | -------------------------------------------------------------------------------- /srfi/README: -------------------------------------------------------------------------------- 1 | Scheme Requests for Implementation (SRFIs) for R6RS 2 | --------------------------------------------------- 3 | 4 | A basic framework for SRFIs made into R6RS libraries. The libraries' names 5 | conform to SRFI 97: SRFI Libraries. There is a registry of available SRFIs (and 6 | other platform features) which works alongside SRFI 0: Feature-Based Conditional 7 | Expansion. The porting done so far is mostly just taking the reference 8 | implementations from http://srfi.schemers.org and wrapping them in libraries and 9 | tweaking the few things needed to make them work in R6RS libraries and with 10 | implementations' functionality. Supporting any R6RS implementation supporting 11 | the *.IMPL.sls convention is easy. The ports and the framework started as just 12 | an exercise in using R6RS. If you have other ideas, let's see if we can 13 | collaborate. 14 | 15 | These SRFIs are available: 16 | (srfi :0 cond-expand) 17 | (srfi :1 lists) 18 | (srfi :2 and-let*) 19 | (srfi :6 basic-string-ports) 20 | (srfi :8 receive) 21 | (srfi :9 records) 22 | (srfi :11 let-values) 23 | (srfi :13 strings) 24 | (srfi :14 char-sets) 25 | (srfi :16 case-lambda) 26 | (srfi :19 time) 27 | (srfi :23 error) 28 | (srfi :25 multi-dimensional-arrays) 29 | (srfi :26 cut) 30 | (srfi :27 random-bits) 31 | (srfi :31 rec) 32 | (srfi :37 args-fold) 33 | (srfi :38 with-shared-structure) 34 | (srfi :39 parameters) 35 | (srfi :41 streams) 36 | (srfi :42 eager-comprehensions) 37 | (srfi :43 vectors) 38 | (srfi :48 intermediate-format-strings) 39 | (srfi :61 cond) 40 | (srfi :64 testing) 41 | (srfi :67 compare-procedures) 42 | (srfi :69 basic-hash-tables) 43 | (srfi :78 lightweight-testing) 44 | (srfi :98 os-environment-variables) 45 | (srfi :99 records) 46 | 47 | Currently supported systems are: Ikarus, Larceny, and Ypsilon. PLT Scheme is 48 | not supported because it has its own "srfi" directory which conflicts with 49 | having another "srfi" directory. 50 | 51 | For the latest development version, go to: 52 | 53 | https://code.launchpad.net/~scheme-libraries-team/scheme-libraries/srfi 54 | 55 | If you already have ported SRFIs to R6RS, we'd love to assimilate them. You 56 | can let us know by "asking a question" at the Scheme Libraries project page: 57 | 58 | https://launchpad.net/scheme-libraries 59 | 60 | Bug Reporting: 61 | -------------- 62 | Submit bug reports at: 63 | 64 | https://bugs.launchpad.net/scheme-libraries/+filebug 65 | -------------------------------------------------------------------------------- /srfi/compile-all.ikarus.sps: -------------------------------------------------------------------------------- 1 | ;; Automatically generated by ../xitomatl/utils/make-compile-all.sps 2 | ;; Do: ikarus --compile-dependencies compile-all.ikarus.sps 3 | (import 4 | (only (srfi :0)) 5 | (only (srfi :0 cond-expand)) 6 | (only (srfi :1)) 7 | (only (srfi :1 lists)) 8 | (only (srfi :11)) 9 | (only (srfi :11 let-values)) 10 | (only (srfi :13)) 11 | (only (srfi :13 strings)) 12 | (only (srfi :14)) 13 | (only (srfi :14 char-sets)) 14 | (only (srfi :16)) 15 | (only (srfi :16 case-lambda)) 16 | (only (srfi :19)) 17 | (only (srfi :19 time)) 18 | (only (srfi :19 time compat)) 19 | (only (srfi :2)) 20 | (only (srfi :2 and-let*)) 21 | (only (srfi :23)) 22 | (only (srfi :23 error)) 23 | (only (srfi :23 error tricks)) 24 | (only (srfi :25)) 25 | (only (srfi :25 multi-dimensional-arrays)) 26 | (only (srfi :25 multi-dimensional-arrays all)) 27 | (only (srfi :25 multi-dimensional-arrays arlib)) 28 | (only (srfi :26)) 29 | (only (srfi :26 cut)) 30 | (only (srfi :27)) 31 | (only (srfi :27 random-bits)) 32 | (only (srfi :31)) 33 | (only (srfi :31 rec)) 34 | (only (srfi :37)) 35 | (only (srfi :37 args-fold)) 36 | (only (srfi :38)) 37 | (only (srfi :38 with-shared-structure)) 38 | (only (srfi :39)) 39 | (only (srfi :39 parameters)) 40 | (only (srfi :41)) 41 | (only (srfi :41 streams)) 42 | (only (srfi :41 streams derived)) 43 | (only (srfi :41 streams primitive)) 44 | (only (srfi :42)) 45 | (only (srfi :42 eager-comprehensions)) 46 | (only (srfi :43)) 47 | (only (srfi :43 vectors)) 48 | (only (srfi :48)) 49 | (only (srfi :48 intermediate-format-strings)) 50 | (only (srfi :48 intermediate-format-strings compat)) 51 | (only (srfi :6)) 52 | (only (srfi :6 basic-string-ports)) 53 | (only (srfi :6 basic-string-ports compat)) 54 | (only (srfi :61)) 55 | (only (srfi :61 cond)) 56 | (only (srfi :64)) 57 | (only (srfi :64 testing)) 58 | (only (srfi :67)) 59 | (only (srfi :67 compare-procedures)) 60 | (only (srfi :69)) 61 | (only (srfi :69 basic-hash-tables)) 62 | (only (srfi :78)) 63 | (only (srfi :78 lightweight-testing)) 64 | (only (srfi :78 lightweight-testing compat)) 65 | (only (srfi :8)) 66 | (only (srfi :8 receive)) 67 | (only (srfi :9)) 68 | (only (srfi :9 records)) 69 | (only (srfi :98)) 70 | (only (srfi :98 os-environment-variables)) 71 | (only (srfi :99)) 72 | (only (srfi :99 records)) 73 | (only (srfi :99 records helper)) 74 | (only (srfi :99 records inspection)) 75 | (only (srfi :99 records procedural)) 76 | (only (srfi :99 records syntactic)) 77 | (only (srfi private OS-id-features)) 78 | (only (srfi private feature-cond)) 79 | (only (srfi private include)) 80 | (only (srfi private include compat)) 81 | (only (srfi private let-opt)) 82 | (only (srfi private platform-features)) 83 | (only (srfi private registry)) 84 | (only (srfi private vanish)) 85 | ) 86 | -------------------------------------------------------------------------------- /srfi/private/OS-id-features.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi private OS-id-features) 8 | (export 9 | OS-id-features) 10 | (import 11 | (rnrs)) 12 | 13 | (define (OS-id-features OS-id features-alist) 14 | (define OS-id-len (string-length OS-id)) 15 | (define (OS-id-contains? str) 16 | (define str-len (string-length str)) 17 | (let loop ((i 0)) 18 | (and (<= (+ i str-len) OS-id-len) 19 | (or (string-ci=? str (substring OS-id i (+ i str-len))) 20 | (loop (+ 1 i)))))) 21 | (apply append 22 | (map cdr (filter (lambda (x) (OS-id-contains? (car x))) 23 | features-alist)))) 24 | ) 25 | -------------------------------------------------------------------------------- /srfi/private/feature-cond.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 3 | ;; MIT-style license. My license is in the file named LICENSE from the original 4 | ;; collection this file is distributed with. If this file is redistributed with 5 | ;; some other collection, my license must also be included. 6 | 7 | (library (srfi private feature-cond) 8 | (export 9 | feature-cond) 10 | (import 11 | (rnrs) 12 | (srfi private registry)) 13 | 14 | (define-syntax feature-cond 15 | (lambda (stx) 16 | (define (identifier?/name=? x n) 17 | (and (identifier? x) 18 | (symbol=? n (syntax->datum x)))) 19 | (define (make-test t) 20 | (define (invalid-test) 21 | (syntax-violation #F "invalid test syntax" stx t)) 22 | (syntax-case t () 23 | ((c x ...) 24 | (identifier?/name=? (syntax c) (quote and)) 25 | (cons (syntax and) (map make-test (syntax (x ...))))) 26 | ((c x ...) 27 | (identifier?/name=? (syntax c) (quote or)) 28 | (cons (syntax or) (map make-test (syntax (x ...))))) 29 | ((c x ...) 30 | (identifier?/name=? (syntax c) (quote not)) 31 | (if (= 1 (length (syntax (x ...)))) 32 | (list (syntax not) (make-test (car (syntax (x ...))))) 33 | (invalid-test))) 34 | (datum 35 | (not (and (identifier? (syntax datum)) 36 | (memq (syntax->datum (syntax datum)) 37 | (quote (and or not else))))) 38 | (syntax (and (member (quote datum) available-features) #T))) 39 | (_ (invalid-test)))) 40 | (syntax-case stx () 41 | ((_ (test . exprs) ... (e . eexprs)) 42 | (identifier?/name=? (syntax e) (quote else)) 43 | (with-syntax (((clause ...) 44 | (map cons (map make-test (syntax (test ...))) 45 | (syntax (exprs ...))))) 46 | (syntax (cond clause ... (else . eexprs))))) 47 | ((kw (test . exprs) ...) 48 | (syntax (kw (test . exprs) ... (else (no-clause-true)))))))) 49 | 50 | (define (no-clause-true) 51 | (assertion-violation (quote feature-cond) "no clause true")) 52 | ) 53 | -------------------------------------------------------------------------------- /srfi/private/include.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi private include) 8 | (export 9 | include/resolve) 10 | (import 11 | (rnrs) 12 | (for (srfi private include compat) expand)) 13 | 14 | (define-syntax include/resolve 15 | (lambda (stx) 16 | (define (include/lexical-context ctxt filename) 17 | (with-exception-handler 18 | (lambda (ex) 19 | (raise 20 | (condition 21 | (make-error) 22 | (make-who-condition 'include/resolve) 23 | (make-message-condition "error while trying to include") 24 | (make-irritants-condition (list filename)) 25 | (if (condition? ex) ex (make-irritants-condition (list ex)))))) 26 | (lambda () 27 | (call-with-input-file filename 28 | (lambda (fip) 29 | (let loop ([a '()]) 30 | (let ([x (read fip)]) 31 | (if (eof-object? x) 32 | (cons #'begin (datum->syntax ctxt (reverse a))) 33 | (loop (cons x a)))))))))) 34 | (syntax-case stx () 35 | [(ctxt (lib-path* ...) file-path) 36 | (for-all (lambda (s) (and (string? s) (positive? (string-length s)))) 37 | (syntax->datum #'(lib-path* ... file-path))) 38 | (let ([p (apply string-append 39 | (map (lambda (ps) (string-append "/" ps)) 40 | (syntax->datum #'(lib-path* ... file-path))))] 41 | [sp (search-paths)]) 42 | (let loop ([search sp]) 43 | (if (null? search) 44 | (error 'include/resolve "cannot find file in search paths" 45 | (substring p 1 (string-length p)) sp) 46 | (let ([full (string-append (car search) p)]) 47 | (if (file-exists? full) 48 | (include/lexical-context #'ctxt full) 49 | (loop (cdr search)))))))]))) 50 | ) 51 | -------------------------------------------------------------------------------- /srfi/private/include/compat.chezscheme.sls: -------------------------------------------------------------------------------- 1 | 2 | (library (srfi private include compat) 3 | 4 | (export search-paths) 5 | 6 | (import (chezscheme)) 7 | 8 | (define (search-paths) 9 | (map car (library-directories))) 10 | 11 | ) -------------------------------------------------------------------------------- /srfi/private/include/compat.ikarus.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi private include compat) 7 | (export 8 | search-paths) 9 | (import 10 | (rnrs base) 11 | (only (ikarus) library-path)) 12 | 13 | (define (search-paths) 14 | (library-path)) 15 | ) 16 | -------------------------------------------------------------------------------- /srfi/private/include/compat.larceny.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi private include compat) 7 | (export 8 | search-paths) 9 | (import 10 | (rnrs base) 11 | (primitives current-require-path getenv absolute-path-string?)) 12 | 13 | (define (search-paths) 14 | (let ([larceny-root (getenv "LARCENY_ROOT")]) 15 | (map (lambda (crp) 16 | (if (absolute-path-string? crp) 17 | crp 18 | (string-append larceny-root "/" crp))) 19 | (current-require-path)))) 20 | 21 | ) 22 | -------------------------------------------------------------------------------- /srfi/private/include/compat.mzscheme.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi private include compat) 8 | (export 9 | search-paths) 10 | (import 11 | (rnrs base) 12 | (only (scheme base) current-library-collection-paths path->string) 13 | (only (scheme mpair) list->mlist)) 14 | 15 | (define (search-paths) 16 | (map path->string 17 | (list->mlist (current-library-collection-paths)))) 18 | ) 19 | -------------------------------------------------------------------------------- /srfi/private/include/compat.ypsilon.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi private include compat) 7 | (export 8 | search-paths) 9 | (import 10 | (rnrs base) 11 | (only (core) scheme-library-paths)) 12 | 13 | (define (search-paths) 14 | (scheme-library-paths)) 15 | ) 16 | -------------------------------------------------------------------------------- /srfi/private/let-opt.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;;; LET-OPTIONALS macros 3 | ;;; Copyright (c) 2001 by Olin Shivers. 4 | 5 | ;;; Copyright (c) 1993-2003 Richard Kelsey and Jonathan Rees 6 | ;;; Copyright (c) 1994-2003 by Olin Shivers and Brian D. Carlstrom. 7 | ;;; Copyright (c) 1999-2003 by Martin Gasbichler. 8 | ;;; Copyright (c) 2001-2003 by Michael Sperber. 9 | ;;; 10 | ;;; All rights reserved. 11 | ;;; 12 | ;;; Redistribution and use in source and binary forms, with or without 13 | ;;; modification, are permitted provided that the following conditions 14 | ;;; are met: 15 | ;;; 1. Redistributions of source code must retain the above copyright 16 | ;;; notice, this list of conditions and the following disclaimer. 17 | ;;; 2. Redistributions in binary form must reproduce the above copyright 18 | ;;; notice, this list of conditions and the following disclaimer in the 19 | ;;; documentation and/or other materials provided with the distribution. 20 | ;;; 3. The name of the authors may not be used to endorse or promote products 21 | ;;; derived from this software without specific prior written permission. 22 | ;;; 23 | ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 24 | ;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 25 | ;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 26 | ;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, 27 | ;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 28 | ;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 29 | ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 30 | ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 31 | ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 32 | ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 33 | 34 | ;;; Made into an R6RS library by Derick Eddington. 35 | 36 | (library (srfi private let-opt) 37 | (export 38 | let-optionals* :optional) 39 | (import 40 | (rnrs)) 41 | 42 | ;;; (:optional rest-arg default-exp [test-pred]) 43 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 44 | ;;; This form is for evaluating optional arguments and their defaults 45 | ;;; in simple procedures that take a *single* optional argument. It is 46 | ;;; a macro so that the default will not be computed unless it is needed. 47 | ;;; 48 | ;;; REST-ARG is a rest list from a lambda -- e.g., R in 49 | ;;; (lambda (a b . r) ...) 50 | ;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that. 51 | ;;; - If REST-ARG has 1 element, return that element. 52 | ;;; - If REST-ARG has >1 element, error. 53 | ;;; 54 | ;;; If there is an TEST-PRED form, it is a predicate that is used to test 55 | ;;; a non-default value. If the predicate returns false, an error is raised. 56 | 57 | (define-syntax :optional 58 | (syntax-rules () 59 | ([_ rest default-exp] 60 | (let ((maybe-arg rest)) 61 | (if (pair? maybe-arg) 62 | (if (null? (cdr maybe-arg)) (car maybe-arg) 63 | (error ':optional "too many optional arguments" maybe-arg)) 64 | default-exp))) 65 | ([_ rest default-exp arg-test] 66 | (let ((maybe-arg rest)) 67 | (if (pair? maybe-arg) 68 | (if (null? (cdr maybe-arg)) 69 | (let ((val (car maybe-arg))) 70 | (if (arg-test val) val 71 | (error ':optional "optional argument failed test" val))) 72 | (error ':optional "too many optional arguments" maybe-arg)) 73 | default-exp))))) 74 | ; erutcurts-enifed 75 | 76 | ;;; Here is a simpler but less-efficient version of LET-OPTIONALS*. 77 | ;;; It redundantly performs end-of-list checks for every optional var, 78 | ;;; even after the list runs out. 79 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 80 | 81 | (define-syntax let-optionals* 82 | (syntax-rules () 83 | ((let-optionals* arg (opt-clause ...) body ...) 84 | (let ((rest arg)) 85 | (%let-optionals* rest (opt-clause ...) body ...))))) 86 | 87 | ;;; The arg-list expression *must* be a variable. 88 | ;;; (Or must be side-effect-free, in any event.) 89 | 90 | (define-syntax %let-optionals* 91 | (syntax-rules () 92 | ((%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...) 93 | (call-with-values (lambda () (xparser arg)) 94 | (lambda (rest var ...) 95 | (%let-optionals* rest (opt-clause ...) body ...)))) 96 | 97 | ((%let-optionals* arg ((var default) opt-clause ...) body ...) 98 | (call-with-values (lambda () (if (null? arg) (values default '()) 99 | (values (car arg) (cdr arg)))) 100 | (lambda (var rest) 101 | (%let-optionals* rest (opt-clause ...) body ...)))) 102 | 103 | ((%let-optionals* arg ((var default test) opt-clause ...) body ...) 104 | (call-with-values (lambda () 105 | (if (null? arg) (values default '()) 106 | (let ((var (car arg))) 107 | (if test (values var (cdr arg)) 108 | (error 'let-optionals* "arg failed LET-OPT test" var))))) 109 | (lambda (var rest) 110 | (%let-optionals* rest (opt-clause ...) body ...)))) 111 | 112 | ((%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...) 113 | (call-with-values (lambda () 114 | (if (null? arg) (values default #f '()) 115 | (let ((var (car arg))) 116 | (if test (values var #t (cdr arg)) 117 | (error 'let-optionals* "arg failed LET-OPT test" var))))) 118 | (lambda (var supplied? rest) 119 | (%let-optionals* rest (opt-clause ...) body ...)))) 120 | 121 | ((%let-optionals* arg (rest) body ...) 122 | (let ((rest arg)) body ...)) 123 | 124 | ((%let-optionals* arg () body ...) 125 | (if (null? arg) (begin body ...) 126 | (error 'let-optionals* "too many arguments in let-opt" arg))))) 127 | ; erutcurts-enifed 128 | 129 | ) 130 | -------------------------------------------------------------------------------- /srfi/private/make-aliased-libraries.sps: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (import 3 | (rnrs) 4 | (only (srfi private registry) available-features) 5 | (only (xitomatl lists) map/filter) 6 | (only (xitomatl match) match-lambda) 7 | (only (xitomatl common) format fprintf printf) 8 | (only (xitomatl strings) string-intersperse) 9 | (only (xitomatl predicates) symbol<?) 10 | (only (xitomatl environments) environment environment-symbols)) 11 | 12 | (define srfi-libraries/mnemonics 13 | (map/filter (match-lambda 14 | ;; NOTE: Uses only the 3-element names. 15 | ((:and ('srfi (:symbol ":(\\d+)" num) _) 16 | name) 17 | (list (string->number (symbol->string num)) 18 | name)) 19 | (_ #F)) 20 | available-features)) 21 | 22 | (define alias-template 23 | ";; Automatically generated by ~a 24 | #!r6rs 25 | (library ~s 26 | (export 27 | ~a) 28 | (import ~s) 29 | ) 30 | ") 31 | 32 | (define program-name (car (command-line))) 33 | 34 | (for-each 35 | (lambda (x) 36 | (let* ((srfi-num (car x)) 37 | (lib-name (cadr x)) 38 | (exports (list-sort symbol<? 39 | (environment-symbols (environment lib-name)))) 40 | (alias-name `(srfi ,(string->symbol (format ":~d" srfi-num)))) 41 | (out-file (format "~d.sls" srfi-num))) 42 | (cond 43 | ((file-exists? out-file) 44 | (printf "Skipping ~a because it already exists.\n" out-file)) 45 | (else 46 | (call-with-output-file out-file 47 | (lambda (fop) 48 | (fprintf fop alias-template 49 | program-name 50 | alias-name 51 | (string-intersperse (map symbol->string exports) "\n ") 52 | lib-name))) 53 | (printf "~a\n" out-file))))) 54 | srfi-libraries/mnemonics) 55 | -------------------------------------------------------------------------------- /srfi/private/platform-features.chezscheme.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi private platform-features) 7 | (export 8 | OS-features 9 | implementation-features) 10 | (import 11 | (rnrs) 12 | (only (chezscheme) machine-type) 13 | (srfi private OS-id-features)) 14 | 15 | (define (OS-features) 16 | (OS-id-features 17 | (symbol->string (machine-type)) 18 | '(("i3la" linux posix)))) 19 | 20 | (define (implementation-features) 21 | '(chezscheme)) 22 | ) 23 | -------------------------------------------------------------------------------- /srfi/private/platform-features.ikarus.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi private platform-features) 7 | (export 8 | OS-features 9 | implementation-features) 10 | (import 11 | (rnrs) 12 | (only (ikarus) host-info) 13 | (srfi private OS-id-features)) 14 | 15 | (define (OS-features) 16 | (OS-id-features 17 | (host-info) 18 | '(("linux" linux posix) 19 | ("solaris" solaris posix) 20 | ("darwin" darwin posix) 21 | ("bsd" bsd) 22 | ("freebsd" freebsd posix) 23 | ("openbsd" openbsd posix) 24 | ("cygwin" cygwin posix) ;; correct? 25 | ("gnu" gnu)))) 26 | 27 | (define (implementation-features) 28 | '(ikarus)) 29 | ) 30 | -------------------------------------------------------------------------------- /srfi/private/platform-features.larceny.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi private platform-features) 7 | (export 8 | OS-features 9 | implementation-features) 10 | (import 11 | (rnrs base) 12 | (rnrs lists) 13 | (primitives system-features) 14 | (srfi private OS-id-features)) 15 | 16 | (define (OS-features) 17 | (OS-id-features 18 | (cdr (assq 'os-name (system-features))) 19 | '(("linux" linux posix) 20 | ("solaris" solaris posix) 21 | ("darwin" darwin posix) 22 | ("bsd" bsd) 23 | ("freebsd" freebsd posix) 24 | ("openbsd" openbsd posix) 25 | ("windows" windows)))) 26 | 27 | (define (implementation-features) 28 | '(larceny)) 29 | ) 30 | -------------------------------------------------------------------------------- /srfi/private/platform-features.mzscheme.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi private platform-features) 8 | (export 9 | OS-features 10 | implementation-features) 11 | (import 12 | (rnrs) 13 | (only (scheme base) system-type) 14 | (srfi private OS-id-features)) 15 | 16 | (define (OS-features) 17 | (OS-id-features 18 | (string-append (symbol->string (system-type 'os)) 19 | " " (system-type 'machine)) 20 | '(("linux" linux posix) 21 | ("macosx" mac-os-x darwin posix) 22 | ("solaris" solaris posix) 23 | ("gnu" gnu) 24 | ("bsd" bsd) 25 | ("freebsd" freebsd posix) 26 | ("openbsd" openbsd posix) 27 | ("windows" windows)))) 28 | 29 | (define (implementation-features) 30 | '(mzscheme)) 31 | ) 32 | -------------------------------------------------------------------------------- /srfi/private/platform-features.ypsilon.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | (library (srfi private platform-features) 7 | (export 8 | OS-features 9 | implementation-features) 10 | (import 11 | (rnrs) 12 | (only (core) architecture-feature) 13 | (srfi private OS-id-features)) 14 | 15 | (define (OS-features) 16 | (OS-id-features 17 | (architecture-feature 'operating-system) 18 | '(("linux" linux posix) 19 | ("solaris" solaris posix) 20 | ("darwin" darwin posix) 21 | ("bsd" bsd) 22 | ("freebsd" freebsd posix) 23 | ("openbsd" openbsd posix) 24 | ("windows" windows)))) 25 | 26 | (define (implementation-features) 27 | '(ypsilon)) 28 | ) 29 | -------------------------------------------------------------------------------- /srfi/private/registry.sls: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (library (srfi private registry) 8 | (export 9 | available-features) 10 | (import 11 | (rnrs) 12 | (srfi private platform-features)) 13 | 14 | (define available-features 15 | (let-syntax 16 | ((SRFI-features 17 | (lambda (stx) 18 | (define SRFIs 19 | '((0 cond-expand) 20 | (1 lists) 21 | (2 and-let*) 22 | #;(5 let) 23 | (6 basic-string-ports) 24 | (8 receive) 25 | (9 records) 26 | (11 let-values) 27 | (13 strings) 28 | (14 char-sets) 29 | (16 case-lambda) 30 | #;(17 generalized-set!) 31 | #;(18 multithreading) 32 | (19 time) 33 | #;(21 real-time-multithreading) 34 | (23 error) 35 | (25 multi-dimensional-arrays) 36 | (26 cut) 37 | (27 random-bits) 38 | #;(28 basic-format-strings) 39 | #;(29 localization) 40 | (31 rec) 41 | (37 args-fold) 42 | (38 with-shared-structure) 43 | (39 parameters) 44 | (41 streams) 45 | (42 eager-comprehensions) 46 | (43 vectors) 47 | #;(44 collections) 48 | #;(45 lazy) 49 | #;(46 syntax-rules) 50 | #;(47 arrays) 51 | (48 intermediate-format-strings) 52 | #;(51 rest-values) 53 | #;(54 cat) 54 | #;(57 records) 55 | #;(59 vicinities) 56 | #;(60 integer-bits) 57 | (61 cond) 58 | #;(63 arrays) 59 | (64 testing) 60 | #;(66 octet-vectors) 61 | (67 compare-procedures) 62 | (69 basic-hash-tables) 63 | #;(71 let) 64 | #;(74 blobs) 65 | (78 lightweight-testing) 66 | #;(86 mu-and-nu) 67 | #;(87 case) 68 | #;(95 sorting-and-merging) 69 | (98 os-environment-variables) 70 | (99 records))) 71 | (define (make-feature-names x) 72 | (define number car) 73 | (define mnemonic cdr) 74 | (define (make-symbol . args) 75 | (string->symbol (apply string-append 76 | (map (lambda (a) 77 | (if (symbol? a) 78 | (symbol->string a) 79 | a)) 80 | args)))) 81 | (let* ((n-str (number->string (number x))) 82 | (colon-n (make-symbol ":" n-str)) 83 | (srfi-n (make-symbol "srfi-" n-str)) 84 | (srfi-n-m (apply make-symbol srfi-n 85 | (map (lambda (m) (make-symbol "-" m)) 86 | (mnemonic x))))) 87 | ;; The first two are recommended by SRFI-97. 88 | ;; The last two are the two types of SRFI-97 library name. 89 | (list srfi-n 90 | srfi-n-m 91 | `(srfi ,colon-n) 92 | `(srfi ,colon-n . ,(mnemonic x))))) 93 | (syntax-case stx () 94 | ((kw) 95 | #`(quote #,(datum->syntax #'kw 96 | (apply append (map make-feature-names SRFIs))))))))) 97 | `(,@(OS-features) 98 | ,@(implementation-features) 99 | ,@(SRFI-features) 100 | r6rs))) 101 | 102 | ) 103 | -------------------------------------------------------------------------------- /srfi/private/vanish.sls: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 3 | ;; MIT-style license. My license is in the file named LICENSE from the original 4 | ;; collection this file is distributed with. If this file is redistributed with 5 | ;; some other collection, my license must also be included. 6 | 7 | (library (srfi private vanish) 8 | (export 9 | vanish-define) 10 | (import 11 | (rnrs) 12 | (for (only (rnrs base) begin) (meta -1))) 13 | 14 | #;(define (show stx) 15 | (display (make-string 60 #\-)) (newline) 16 | (write (syntax->datum stx)) (newline)) 17 | 18 | (define-syntax vanish-define 19 | (lambda (stx) 20 | (syntax-case stx () 21 | ((_ def (vanish ...)) 22 | (for-all identifier? #'(vanish ...)) 23 | #'(make-vanish-define (syntax def) (syntax vanish) ...))))) 24 | 25 | (define (make-vanish-define def . to-vanish) 26 | (lambda (stx) 27 | (define (vanish? id) 28 | (memp (lambda (x) (free-identifier=? id x)) 29 | to-vanish)) 30 | #;(show stx) 31 | (syntax-case stx () 32 | ((_ name . _) 33 | (and (identifier? #'name) 34 | (vanish? #'name)) 35 | #'(begin)) 36 | ((_ (name . _) . _) 37 | (and (identifier? #'name) 38 | (vanish? #'name)) 39 | #'(begin)) 40 | ((_ . r) 41 | (cons def #'r))))) 42 | ) 43 | -------------------------------------------------------------------------------- /srfi/tests/and-let*.sps: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (import 8 | (rnrs) 9 | (rnrs eval) 10 | (srfi :2 and-let*) 11 | (srfi :78 lightweight-testing)) 12 | 13 | (define-syntax expect 14 | (syntax-rules () 15 | [(_ expr result) 16 | (check expr => result)])) 17 | 18 | (define-syntax must-be-a-syntax-error 19 | (syntax-rules () 20 | [(_ expr) 21 | (check 22 | (guard (ex [#t (syntax-violation? ex)]) 23 | (eval 'expr (environment '(rnrs) '(srfi :2 and-let*)))) 24 | => #t)])) 25 | 26 | ;; Taken straight from the reference implementation tests 27 | 28 | (expect (and-let* () 1) 1) 29 | (expect (and-let* () 1 2) 2) 30 | (expect (and-let* () ) #t) 31 | 32 | (expect (let ((x #f)) (and-let* (x))) #f) 33 | (expect (let ((x 1)) (and-let* (x))) 1) 34 | (expect (and-let* ((x #f)) ) #f) 35 | (expect (and-let* ((x 1)) ) 1) 36 | (must-be-a-syntax-error (and-let* ( #f (x 1))) ) 37 | (expect (and-let* ( (#f) (x 1)) ) #f) 38 | (must-be-a-syntax-error (and-let* (2 (x 1))) ) 39 | (expect (and-let* ( (2) (x 1)) ) 1) 40 | (expect (and-let* ( (x 1) (2)) ) 2) 41 | (expect (let ((x #f)) (and-let* (x) x)) #f) 42 | (expect (let ((x "")) (and-let* (x) x)) "") 43 | (expect (let ((x "")) (and-let* (x) )) "") 44 | (expect (let ((x 1)) (and-let* (x) (+ x 1))) 2) 45 | (expect (let ((x #f)) (and-let* (x) (+ x 1))) #f) 46 | (expect (let ((x 1)) (and-let* (((positive? x))) (+ x 1))) 2) 47 | (expect (let ((x 1)) (and-let* (((positive? x))) )) #t) 48 | (expect (let ((x 0)) (and-let* (((positive? x))) (+ x 1))) #f) 49 | (expect (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1))) (+ x 1))) 3) 50 | ;; This next one is from the reference implementation tests 51 | ;; but I can't see how it "must be a syntax-error". 52 | #;(must-be-a-syntax-error 53 | (let ((x 1)) (and-let* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))) 54 | 55 | (expect (let ((x 1)) (and-let* (x ((positive? x))) (+ x 1))) 2) 56 | (expect (let ((x 1)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) 2) 57 | (expect (let ((x 0)) (and-let* (x ((positive? x))) (+ x 1))) #f) 58 | (expect (let ((x #f)) (and-let* (x ((positive? x))) (+ x 1))) #f) 59 | (expect (let ((x #f)) (and-let* ( ((begin x)) ((positive? x))) (+ x 1))) #f) 60 | 61 | (expect (let ((x 1)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f) 62 | (expect (let ((x 0)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f) 63 | (expect (let ((x #f)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) #f) 64 | (expect (let ((x 3)) (and-let* (x (y (- x 1)) ((positive? y))) (/ x y))) 3/2) 65 | 66 | (check-report) 67 | -------------------------------------------------------------------------------- /srfi/tests/cut.sps: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ; CONFIDENCE TEST FOR IMPLEMENTATION OF SRFI-26 3 | ; ============================================= 4 | ; 5 | ; Sebastian.Egner@philips.com, 3-Jun-2002. 6 | ; 7 | ; This file checks a few assertions about the implementation. 8 | ; If you run it and no error message is issued, the implementation 9 | ; is correct on the cases that have been tested. 10 | ; 11 | ; compliance: 12 | ; Scheme R5RS with 13 | ; SRFI-23: error 14 | ; 15 | ; loading this file into Scheme 48 0.57 after 'cut.scm' has been loaded: 16 | ; ,open srfi-23 17 | ; ,load check.scm 18 | 19 | ; (check expr) 20 | ; evals expr and issues an error if it is not #t. 21 | 22 | ;; Extended by Derick Eddington to test free-identifier=? of <> and <...>. 23 | 24 | (import 25 | (rnrs) 26 | (rnrs eval)) 27 | 28 | (define (check expr) 29 | (if (not (eq? (eval expr (environment '(rnrs) '(srfi :26 cut))) 30 | #t)) 31 | (assertion-violation 'check "check failed" expr))) 32 | 33 | ; (check-all) 34 | ; runs several tests on cut and reports. 35 | 36 | (define (check-all) 37 | (for-each 38 | check 39 | '( ; cuts 40 | (equal? ((cut list)) '()) 41 | (equal? ((cut list <...>)) '()) 42 | (equal? ((cut list 1)) '(1)) 43 | (equal? ((cut list <>) 1) '(1)) 44 | (equal? ((cut list <...>) 1) '(1)) 45 | (equal? ((cut list 1 2)) '(1 2)) 46 | (equal? ((cut list 1 <>) 2) '(1 2)) 47 | (equal? ((cut list 1 <...>) 2) '(1 2)) 48 | (equal? ((cut list 1 <...>) 2 3 4) '(1 2 3 4)) 49 | (equal? ((cut list 1 <> 3 <>) 2 4) '(1 2 3 4)) 50 | (equal? ((cut list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6)) 51 | (equal? (let* ((x 'wrong) (y (cut list x))) (set! x 'ok) (y)) '(ok)) 52 | (equal? 53 | (let ((a 0)) 54 | (map (cut + (begin (set! a (+ a 1)) a) <>) 55 | '(1 2)) 56 | a) 57 | 2) 58 | (equal? 59 | (let* ((<> 'wrong) (f (cut list <> <...>))) 60 | (set! <> 'ok) 61 | (f 1 2)) 62 | '(ok 1 2)) 63 | (equal? 64 | (let* ((<...> 'wrong) (f (cut list <> <...>))) 65 | (set! <...> 'ok) 66 | (f 1)) 67 | '(1 ok)) 68 | ; cutes 69 | (equal? ((cute list)) '()) 70 | (equal? ((cute list <...>)) '()) 71 | (equal? ((cute list 1)) '(1)) 72 | (equal? ((cute list <>) 1) '(1)) 73 | (equal? ((cute list <...>) 1) '(1)) 74 | (equal? ((cute list 1 2)) '(1 2)) 75 | (equal? ((cute list 1 <>) 2) '(1 2)) 76 | (equal? ((cute list 1 <...>) 2) '(1 2)) 77 | (equal? ((cute list 1 <...>) 2 3 4) '(1 2 3 4)) 78 | (equal? ((cute list 1 <> 3 <>) 2 4) '(1 2 3 4)) 79 | (equal? ((cute list 1 <> 3 <...>) 2 4 5 6) '(1 2 3 4 5 6)) 80 | (equal? 81 | (let ((a 0)) 82 | (map (cute + (begin (set! a (+ a 1)) a) <>) 83 | '(1 2)) 84 | a) 85 | 1) 86 | (equal? 87 | (let* ((<> 'ok) (f (cute list <> <...>))) 88 | (set! <> 'wrong) 89 | (f 1 2)) 90 | '(ok 1 2)) 91 | (equal? 92 | (let* ((<...> 'ok) (f (cute list <> <...>))) 93 | (set! <...> 'wrong) 94 | (f 1)) 95 | '(1 ok)) 96 | ))) 97 | 98 | ; run the checks when loading 99 | (check-all) 100 | (display "passed") 101 | (newline) 102 | -------------------------------------------------------------------------------- /srfi/tests/intermediate-format-strings.sps: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (import 3 | (rnrs) 4 | (rnrs mutable-pairs) 5 | (srfi :48 intermediate-format-strings) 6 | (srfi :78 lightweight-testing)) 7 | 8 | #;(define (format-lots n f fmt-str . args) 9 | (let loop ([i 0] [r #f]) 10 | (if (= i n) 11 | r 12 | (loop (+ 1 i) (apply f fmt-str args))))) 13 | 14 | (define-syntax expect 15 | (syntax-rules () 16 | [(_ expected expr) 17 | (check expr => expected)])) 18 | 19 | ;;;=================================================== 20 | 21 | (expect (format "test ~s" 'me) (format #f "test ~a" "me")) 22 | 23 | (check (format "~6,3F" 1/3) 24 | (=> member) 25 | '(" 0.333" " .333")) 26 | 27 | (expect " 12" (format "~4F" 12)) 28 | 29 | (expect " 12.346" (format "~8,3F" 12.3456)) 30 | 31 | (expect "123.346" (format "~6,3F" 123.3456)) 32 | 33 | (expect "123.346" (format "~4,3F" 123.3456)) 34 | 35 | (expect "0.000+1.949i" (format "~8,3F" (sqrt -3.8))) 36 | 37 | (expect " 32.00" (format "~6,2F" 32)) 38 | 39 | (expect " 32" (format "~6F" 32)) 40 | 41 | (check (format "~6F" 32.) 42 | ;; NB: (not (and (exact? 32.) (integer? 32.))) 43 | (=> member) 44 | '(" 32.0" " 32.")) 45 | 46 | (check (format "~8F" 32e45) 47 | (=> member) 48 | '(" 3.2e46" " 3.2e+46")) 49 | 50 | (expect " 3.2e-44" (format "~8,1F" 32e-45)) 51 | 52 | (check (format "~8F" 32e20) 53 | (=> member) 54 | '(" 3.2e21" " 3.2e+21")) 55 | 56 | (check (format "~8F" 32e5) 57 | (=> member) 58 | '("3200000.0" " 3.2e6" " 3.2e+6")) 59 | 60 | (check (format "~8F" 32e2) 61 | (=> member) 62 | '(" 3200.0" " 3200.")) 63 | 64 | (check (format "~8,2F" 32e10) 65 | (=> member) 66 | '(" 3.20e11" "3.20e+11" "320000000000.00")) 67 | 68 | (check (format "~0,3F" 20263/2813) 69 | (=> member) 70 | '( "7.203" )) 71 | 72 | (check (format "~0,2F" 20263/2813) 73 | (=> member) 74 | '( "7.20" )) 75 | 76 | 77 | (expect " 1.2345" (format "~12F" 1.2345)) 78 | 79 | (expect " 1.23" (format "~12,2F" 1.2345)) 80 | 81 | (expect " 1.234" (format "~12,3F" 1.2345)) ;; "round to even" 82 | 83 | (expect " 0.000+1.949i" (format "~20,3F" (sqrt -3.8))) 84 | 85 | (expect "0.000+1.949i" (format "~8,3F" (sqrt -3.8))) 86 | 87 | (check (format "~8,2F" 3.4567e11) 88 | (=> member) 89 | '(" 3.46e11" "3.46e+11" "345670000000.00")) 90 | 91 | 92 | (check (format "~w" (let ( (c (list 'a 'b 'c)) ) (set-cdr! (cddr c) c) c)) 93 | (=> member) 94 | '("#0=(a b c . #0#)" "#1=(a b c . #1#)")) 95 | 96 | (expect " 97 | " 98 | (format "~A~A~&" (list->string (list #\newline)) "")) 99 | 100 | (expect "a new test" 101 | (format "~a ~? ~a" 'a "~a" '(new) 'test)) 102 | 103 | (expect "a \"new\" test" 104 | (format "~a ~? ~a" 'a "~s" '("new") 'test)) 105 | 106 | ;; from SLIB 107 | 108 | (define-syntax test 109 | (syntax-rules () 110 | [(test <format-args> <expected>) 111 | (check (apply format <format-args>) => <expected>)])) 112 | 113 | (test '("abc") "abc") 114 | (test '("~a" 10) "10") 115 | (test '("~a" -1.2) "-1.2") 116 | (test '("~a" a) "a") 117 | (test '("~a" #t) "#t") 118 | (test '("~a" #f) "#f") 119 | (test '("~a" "abc") "abc") 120 | (test '("~a" #(1 2 3)) "#(1 2 3)") 121 | (test '("~a" ()) "()") 122 | (test '("~a" (a)) "(a)") 123 | (test '("~a" (a b)) "(a b)") 124 | (test '("~a" (a (b c) d)) "(a (b c) d)") 125 | (test '("~a" (a . b)) "(a . b)") 126 | (test '("~a" (a (b c . d))) "(a (b c . d))") 127 | 128 | ; # argument test 129 | 130 | (test '("~a ~a" 10 20) "10 20") 131 | (test '("~a abc ~a def" 10 20) "10 abc 20 def") 132 | 133 | ; numerical test 134 | 135 | (test '("~d" 100) "100") 136 | (test '("~x" 100) "64") 137 | (test '("~o" 100) "144") 138 | (test '("~b" 100) "1100100") 139 | 140 | 141 | ; character test 142 | 143 | (test '("~c" #\a) "a") 144 | 145 | 146 | ; tilde test 147 | 148 | (test '("~~~~") "~~") 149 | 150 | 151 | ; whitespace character test 152 | 153 | (test '("~%") " 154 | ") 155 | (test '("~&") " 156 | ") 157 | (test '("abc~&") "abc 158 | ") 159 | (test '("abc~&def") "abc 160 | def") 161 | (test '("~&") " 162 | ") 163 | (test '("~_~_~_") " ") 164 | 165 | 166 | 167 | ; indirection test 168 | 169 | (test '("~a ~? ~a" 10 "~a ~a" (20 30) 40) "10 20 30 40") 170 | 171 | 172 | 173 | ; slashify test 174 | 175 | (test '("~s" "abc") "\"abc\"") 176 | (test '("~s" "abc \\ abc") "\"abc \\\\ abc\"") 177 | (test '("~a" "abc \\ abc") "abc \\ abc") 178 | (test '("~s" "abc \" abc") "\"abc \\\" abc\"") 179 | (test '("~a" "abc \" abc") "abc \" abc") 180 | (test '("~s" #\space) "#\\space") 181 | ;(test '("~s" #\newline) "#\\newline") 182 | (test '("~s" #\a) "#\\a") 183 | (test '("~s" (a "b" c)) "(a \"b\" c)") 184 | (test '("~a" (a "b" c)) "(a b c)") 185 | 186 | 187 | ; fixed floating points 188 | 189 | (test '("~6,2f" 3.14159) " 3.14") 190 | (test '("~6,1f" 3.14159) " 3.1") 191 | (test '("~6,0f" 3.14159) " 3.") 192 | (test '("~5,1f" 0) " 0.0") 193 | (test '("~10,7f" 3.14159) " 3.1415900") 194 | (test '("~10,7f" -3.14159) "-3.1415900") 195 | (test '("~6,3f" 0.0) " 0.000") 196 | (check (format "~6,4f" 0.007) 197 | (=> member) 198 | '(" 7e-3" "0.0070" ".0070")) 199 | (check (format "~6,3f" 0.007) 200 | (=> member) 201 | '(" 7e-3" " 0.007")) 202 | (check (format "~6,2f" 0.007) 203 | (=> member) 204 | '(" 7e-3" " 0.01")) 205 | (check (format "~3,2f" 0.007) 206 | (=> member) 207 | '("7e-3" ".01" "0.01")) 208 | (check (format "~3,2f" -0.007) 209 | (=> member) 210 | '("-7e-3" "-.01" "-0.01")) 211 | (test '("~6,3f" 12345.6789) "12345.679") 212 | (test '("~6f" 23.4) " 23.4") 213 | (test '("~6f" 1234.5) "1234.5") 214 | (test '("~6f" 12345678) "12345678") 215 | (test '("~6,2f" 123.56789) "123.57") 216 | (test '("~6f" 123.0) " 123.0") 217 | (test '("~6f" -123.0) "-123.0") 218 | (test '("~6f" 0.0) " 0.0") 219 | (test '("~3,1f" 3.141) "3.1") 220 | (test '("~2,0f" 3.141) "3.") 221 | (test '("~1f" 3.141) "3.141") 222 | (test '("~f" 123.56789) "123.56789") 223 | (test '("~f" -314.0) "-314.0") 224 | (check (format "~f" 1e4) 225 | (=> member) 226 | '("1e4" "10000.0")) 227 | (check (format "~f" -1.23e10) 228 | (=> member) 229 | '("-1.23e10" "-1.23e+10" "-12300000000.0" "-12300000000.")) 230 | (check (format "~f" 1e-4) 231 | (=> member) 232 | '("1e-4" "0.0001" ".0001")) 233 | (check (format "~f" -1.23e-10) 234 | (=> member) 235 | '("-0.000000000123" "-1.23e-10")) 236 | 237 | 238 | (check-report) 239 | 240 | ;; #!eof 241 | -------------------------------------------------------------------------------- /srfi/tests/lightweight-testing.sps: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ; <PLAINTEXT> 3 | ; Copyright (c) 2005-2006 Sebastian Egner. 4 | ; 5 | ; Permission is hereby granted, free of charge, to any person obtaining 6 | ; a copy of this software and associated documentation files (the 7 | ; ``Software''), to deal in the Software without restriction, including 8 | ; without limitation the rights to use, copy, modify, merge, publish, 9 | ; distribute, sublicense, and/or sell copies of the Software, and to 10 | ; permit persons to whom the Software is furnished to do so, subject to 11 | ; the following conditions: 12 | ; 13 | ; The above copyright notice and this permission notice shall be 14 | ; included in all copies or substantial portions of the Software. 15 | ; 16 | ; THE SOFTWARE IS PROVIDED ``AS IS'', WITHOUT WARRANTY OF ANY KIND, 17 | ; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | ; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | ; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | ; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | ; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 23 | ; 24 | ; ----------------------------------------------------------------------- 25 | 26 | ; Lightweight testing (examples) 27 | ; ============================== 28 | ; 29 | ; Sebastian.Egner@philips.com 30 | ; in R5RS + SRFI 23 (error) + SRFI 42 (comprehensions) 31 | ; 32 | ; history of this file: 33 | ; SE, 25-Oct-2004: first version 34 | 35 | ; -- portability -- 36 | 37 | ; PLT: 38 | ; (require (lib "23.ss" "srfi") (lib "42.ss" "srfi")) (load "check.scm") 39 | ; (load "examples.scm") 40 | 41 | ; Scheme48: 42 | ; ,open srfi-23 srfi-42 43 | ; ,load check.scm examples.scm 44 | 45 | (import 46 | (rnrs) 47 | (rnrs r5rs) 48 | (srfi :42 eager-comprehensions) 49 | (srfi :78 lightweight-testing)) 50 | 51 | ; -- simple test -- 52 | 53 | (check (+ 1 1) => 2) 54 | (check (+ 1 1) => 3) ; fails 55 | 56 | ; -- different equality predicate -- 57 | 58 | (check (vector 1) => (vector 1)) 59 | (check (vector 1) (=> eq?) (vector 1)) ; fails 60 | 61 | ; -- parametric tests -- 62 | 63 | (check-ec (+ 1 1) => 2) 64 | 65 | (check-ec (: x 10) (+ x 1) => (+ x 1) (x)) 66 | 67 | (check-ec (: e 100) (positive? (expt 2 e)) => #t (e)) ; fails on fixnums 68 | 69 | (check-ec (: e 100) (:let x (expt 2.0 e)) (= (+ x 1) x) => #f (x)) ; fails 70 | 71 | (check-ec (: e 100) (:let x (expt 2.0 e)) (= (+ x 1) x) => #f) 72 | 73 | (check-ec (: x 10) (: y 10) (: z 10) 74 | (* x (+ y z)) => (+ (* x y) (* x z)) 75 | (x y z)) ; passes with 10^3 cases checked 76 | 77 | ; -- toy examples -- 78 | 79 | (define (fib n) 80 | (if (<= n 2) 1 (+ (fib (- n 1)) (fib (- n 2))))) 81 | 82 | (check (fib 1) => 1) 83 | (check (fib 2) => 1) 84 | (check-ec (: n 1 31) (even? (fib n)) => (= (modulo n 3) 0) (n)) 85 | 86 | ; -- reporting -- 87 | 88 | (check-report) 89 | -------------------------------------------------------------------------------- /srfi/tests/multi-dimensional-arrays--arlib.sps: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 3 | ;; MIT-style license. My license is in the file named LICENSE from the original 4 | ;; collection this file is distributed with. If this file is redistributed with 5 | ;; some other collection, my license must also be included. 6 | 7 | (import 8 | (rnrs) 9 | (srfi :25 multi-dimensional-arrays) 10 | (srfi :25 multi-dimensional-arrays arlib) 11 | (srfi :78 lightweight-testing) 12 | (srfi private include)) 13 | 14 | (define-syntax past (syntax-rules () ((_ . r) (begin)))) 15 | 16 | (let-syntax ((or 17 | (syntax-rules (error) 18 | ((_ expr (error msg)) 19 | (check expr => #T)) 20 | ((_ . r) (or . r))))) 21 | (include/resolve ("srfi" "%3a25") "list.scm")) 22 | 23 | (check-report) 24 | -------------------------------------------------------------------------------- /srfi/tests/multi-dimensional-arrays.sps: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 3 | ;; MIT-style license. My license is in the file named LICENSE from the original 4 | ;; collection this file is distributed with. If this file is redistributed with 5 | ;; some other collection, my license must also be included. 6 | 7 | (import 8 | (rnrs) 9 | (srfi :25 multi-dimensional-arrays) 10 | (srfi :78 lightweight-testing) 11 | (srfi private include)) 12 | 13 | (let-syntax ((or 14 | (syntax-rules (error) 15 | ((_ expr (error msg)) 16 | (check (and expr #T) => #T)) 17 | ((_ . r) (or . r)))) 18 | (past 19 | (syntax-rules () 20 | ((_ . r) (values))))) 21 | (include/resolve ("srfi" "%3a25") "test.scm")) 22 | 23 | (check-report) 24 | -------------------------------------------------------------------------------- /srfi/tests/os-environment-variables.sps: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (import 8 | (rename (rnrs) (for-all andmap)) 9 | (srfi :78 lightweight-testing) 10 | (srfi :98 os-environment-variables)) 11 | 12 | (check (list? (get-environment-variables)) 13 | => #T) 14 | (check (andmap (lambda (a) 15 | (and (pair? a) 16 | (string? (car a)) 17 | (positive? (string-length (car a))) 18 | (string? (cdr a)))) 19 | (get-environment-variables)) 20 | => #T) 21 | (check (andmap (lambda (a) 22 | (let ((v (get-environment-variable (car a)))) 23 | (and (string? v) 24 | (string=? v (cdr a))))) 25 | (get-environment-variables)) 26 | => #T) 27 | (assert (not (assoc "BLAH" (get-environment-variables)))) 28 | (check (get-environment-variable "BLAH") 29 | => #F) 30 | 31 | (check-report) 32 | -------------------------------------------------------------------------------- /srfi/tests/print-ascii.sps: -------------------------------------------------------------------------------- 1 | 2 | ;;; Test format import of implementation 3 | ;;; specific routine: pretty-print 4 | 5 | #| 6 | LARCENY USAGE: 7 | ==> larceny -r6rs -program print-ascii.ss 8 | 9 | IKARUS USAGE 10 | ==> ikarus --r6rs-script print-ascii.ss 11 | 12 | |# 13 | 14 | (import (rnrs (6)) 15 | (srfi :48 intermediate-format-strings)) 16 | 17 | (define pa 18 | '(define (print-ascii-chart . radix+port) 19 | (let ( (radix (if (null? radix+port) 16 (car radix+port))) 20 | (port (if (or (null? radix+port) (null? (cdr radix+port))) 21 | (current-output-port) 22 | (cadr radix+port))) 23 | (max-row 15) 24 | (max-col 7) 25 | (max-ascii 127) 26 | (max-control 31) ; [0..31] are control codes 27 | ) 28 | 29 | (define (printable? N) ; N.B.: integer input 30 | (< max-control N max-ascii)) ; control or DEL 31 | 32 | (define (print-a-char N) 33 | (if (printable? N) 34 | (begin 35 | (display #\' port) 36 | (display (integer->char N) port) 37 | (display #\' port) 38 | ) 39 | (cond ; print a control character 40 | ((= N max-ascii) (display "DEL" port)) 41 | (else 42 | (display #\^ port) 43 | (display (integer->char (+ (char->integer #\@) N)) port) 44 | ) ) ) 45 | (display " = " port) 46 | (display (number->string N radix) port) 47 | (display #\space port) 48 | (display #\space port) 49 | (display #\space port) 50 | ) 51 | 52 | ; output the chart... 53 | (newline port) 54 | (let row-loop ( (row 0) ) 55 | (if (> row max-row) 56 | (newline port) ; done 57 | (let column-loop ( (col 0) ) 58 | (print-a-char (+ row (* col (+ max-row 1)))) 59 | (if (< col max-col) 60 | (column-loop (+ col 1)) 61 | (begin 62 | (newline port) 63 | (row-loop (+ row 1)) 64 | ) ) 65 | ) ) 66 | )) ) 67 | ) 68 | 69 | (format #t "~Y~%" pa) 70 | 71 | ;; --- E O F --- ;; 72 | -------------------------------------------------------------------------------- /srfi/tests/random-conftest.sps: -------------------------------------------------------------------------------- 1 | #!r6rs 2 | (import (rnrs) (rnrs r5rs) (srfi :27 random-bits)) 3 | 4 | ; CONFIDENCE TESTS FOR SRFI-27 "Sources of Random Bits" 5 | ; ===================================================== 6 | ; 7 | ; Sebastian.Egner@philips.com, 2002. 8 | ; 9 | ; This file contains a small collection of checks for the 10 | ; implementation of SRFI-27. It is not meant to be complete 11 | ; or to test the actual properties of the underlying generator. 12 | ; It is merely meant to run the code and to check some of the 13 | ; assumptions made by specification. There is an interface to 14 | ; G. Marsaglia's DIEHARD battery of tests for random number 15 | ; generators, though. 16 | 17 | ; History of this file: 18 | ; SE, 19-Mar-2002: initial version, based on earlier tests 19 | ; SE, 22-Mar-2002: adapted to new procedure names 20 | ; SE, 25-Mar-2002: more descriptive output 21 | ; SE, 04-Apr-2002: some quick timings; check up 22 | 23 | ; (check expr) 24 | ; evals expr and issues an error if it is not #t. 25 | 26 | #; 27 | (define (check expr) 28 | (if (not (eq? (eval expr (interaction-environment)) #t)) 29 | (error "check failed" expr))) 30 | 31 | ; Basic Tests of the Interface 32 | ; ============================ 33 | 34 | (define (my-random-integer n) 35 | (let ((x (random-integer n))) 36 | (if (<= 0 x (- n 1)) 37 | x 38 | (error "(random-integer n) returned illegal value" x)))) 39 | 40 | (define (my-random-real) 41 | (let ((x (random-real))) 42 | (if (< 0 x 1) 43 | x 44 | (error "(random-real) returned illegal value" x)))) 45 | 46 | (define (check-basics-1) 47 | 48 | ; generate increasingly large numbers 49 | (display "; generating large numbers [bits]: ") 50 | (do ((k 0 (+ k 1)) 51 | (n 1 (* n 2))) 52 | ((> k 1024)) 53 | (display k) 54 | (display " ") 55 | (my-random-integer n)) 56 | (display "ok") 57 | (newline) 58 | 59 | ; generate some reals 60 | (display "; generating reals [1000 times]: ") 61 | (do ((k 0 (+ k 1)) 62 | (x (my-random-real) (+ x (my-random-real)))) 63 | ((= k 1000) 64 | x)) 65 | (display "ok") 66 | (newline) 67 | 68 | ; get/set the state 69 | (display "; get/set state: ") 70 | (let* ((state1 (random-source-state-ref default-random-source)) 71 | (x1 (my-random-integer (expt 2 32))) 72 | (state2 (random-source-state-ref default-random-source)) 73 | (x2 (my-random-integer (expt 2 32)))) 74 | (random-source-state-set! default-random-source state1) 75 | (let ((y1 (my-random-integer (expt 2 32)))) 76 | (if (not (= x1 y1)) 77 | (error "state get/set doesn't work" x1 y1 state1))) 78 | (random-source-state-set! default-random-source state2) 79 | (let ((y2 (my-random-integer (expt 2 32)))) 80 | (if (not (= x2 y2)) 81 | (error "state get/set doesn't work" x2 y2 state2)))) 82 | (display "ok") 83 | (newline) 84 | 85 | ; randomize! 86 | (display "; randomize!: ") 87 | (let* ((state1 (random-source-state-ref default-random-source)) 88 | (x1 (my-random-integer (expt 2 32)))) 89 | (random-source-state-set! default-random-source state1) 90 | (random-source-randomize! default-random-source) 91 | (let ((y1 (my-random-integer (expt 2 32)))) 92 | (if (= x1 y1) 93 | (error "random-source-randomize! didn't work" x1 state1)))) 94 | (display "ok") 95 | (newline) 96 | 97 | ; pseudo-randomize! 98 | (display "; pseudo-randomize!: ") 99 | (let* ((state1 (random-source-state-ref default-random-source)) 100 | (x1 (my-random-integer (expt 2 32)))) 101 | (random-source-state-set! default-random-source state1) 102 | (random-source-pseudo-randomize! default-random-source 0 1) 103 | (let ((y1 (my-random-integer (expt 2 32)))) 104 | (if (= x1 y1) 105 | (error "random-source-pseudo-randomize! didn't work" x1 state1))) 106 | (random-source-state-set! default-random-source state1) 107 | (random-source-pseudo-randomize! default-random-source 1 0) 108 | (let ((y1 (my-random-integer (expt 2 32)))) 109 | (if (= x1 y1) 110 | (error "random-source-pseudo-randomize! didn't work" x1 state1)))) 111 | (display "ok") 112 | (newline) 113 | (newline)) 114 | 115 | 116 | ; Testing the MRG32k3a Generator (if implemented) 117 | ; =============================================== 118 | 119 | ; (check-mrg32k3a) 120 | ; tests if the underlying generator is the MRG32k3a generator 121 | ; as implemented in the reference implementation. This function 122 | ; is useful to check whether the reference implementation computes 123 | ; the right numbers. 124 | 125 | (define (check-mrg32k3a) 126 | 127 | ; check if the initial state is A^16 * (1 0 0 1 0 0) 128 | (display "; check A^16 * (1 0 0 1 0 0)") 129 | (let* ((s (make-random-source)) 130 | (state1 (random-source-state-ref s)) 131 | (rand (random-source-make-reals s))) 132 | (random-source-state-set! s '(lecuyer-mrg32k3a 1 0 0 1 0 0)) 133 | (do ((k 0 (+ k 1))) 134 | ((= k 16) 135 | (let ((state2 (random-source-state-ref s))) 136 | (if (not (equal? state1 state2)) 137 | (error "16-th state after (1 0 0 1 0 0) is wrong")))) 138 | (rand))) 139 | (display "ok") 140 | (newline) 141 | 142 | ; check if pseudo-randomize! advances properly 143 | (display "; checking (random-source-pseudo-randomize! s 1 2)") 144 | (let ((s (make-random-source))) 145 | (random-source-pseudo-randomize! s 1 2) 146 | (if (not (equal? (random-source-state-ref s) 147 | '(lecuyer-mrg32k3a 148 | 1250826159 149 | 3004357423 150 | 431373563 151 | 3322526864 152 | 623307378 153 | 2983662421))) 154 | (error "pseudo-randomize! gives wrong result"))) 155 | (display "ok") 156 | (newline) 157 | 158 | ; run the check published by Pierre L'Ecuyer: 159 | ; Note that the reference implementation deals slightly different 160 | ; with reals mapping m1-1 into 1-1/(m1+1) and not into 0 as in 161 | ; L'Ecuyer's original proposal. However, for the first 10^7 reals 162 | ; that makes no difference as m1-1 is not generated. 163 | (display "; checking (random-source-pseudo-randomize! s 1 2)...") 164 | (let* ((x 0.0) 165 | (s (make-random-source)) 166 | (rand (random-source-make-reals s))) 167 | (random-source-state-set! 168 | s 169 | '(lecuyer-mrg32k3a 12345 12345 12345 12345 12345 12345)) 170 | (do ((k 0 (+ k 1))) 171 | ((= k 10000000) 172 | (if (not (< (abs (- x 5001090.95)) 0.01)) 173 | (error "bad sum over 10^7 reals" x))) 174 | (set! x (+ x (rand))))) 175 | (display "ok") 176 | (newline)) 177 | 178 | 179 | ; Writing Data to DIEHARD 180 | ; ======================= 181 | 182 | ; (write-diehard filename s bytes-per-call calls) 183 | ; creates a binary file to which bytes-per-call * calls bytes are 184 | ; written. The bytes are obtained from the random source s using 185 | ; the range n = (expt 256 bytes-per-call). 186 | ; The intention of write-diehard is to give implementors a 187 | ; '15 min.'-way of running their favourite random number generator 188 | ; through a pretty tough testsuite. 189 | ; 190 | ; try: For the reference implementation, the call 191 | ; 192 | ; (write-diehard "outfile" (make-random-source) 4 2867200) 193 | ; 194 | ; should create a file that looks as follows (od -A x -t x1 outfile): 195 | ; 196 | ; 0000000 92 bb 7e db 1b 14 f6 bb bb 54 a1 55 c2 3e cd ca 197 | ; 0000010 23 01 20 35 06 47 65 b0 52 4c b8 c0 21 48 af 67 198 | ; 0000020 63 a9 8c 78 50 73 29 08 62 d1 22 7f a6 89 96 77 199 | ; 0000030 98 28 65 2d 2d 8b f9 52 41 be 8e 3f c5 84 0f ca 200 | ; 0000040 c0 fa 03 d6 f0 65 9d 3a 9b ab 6f fe d1 aa 5f 92 201 | ; 0000050 0f ea f6 3b 78 b9 fe ad 63 5e 49 f1 9d c9 8e 2f 202 | ; 0000060 53 a9 5d 32 d4 20 51 1d 1c 2e 82 f0 8b 26 40 c0 203 | ; ...total length is 11468800 bytes. 204 | ; 205 | ; The message digest is md5sum = 4df554f56cb5ed251bd04b0d50767443. 206 | ; 207 | ; try: For the reference implementation, the call 208 | ; 209 | ; (write-diehard "outfile" (make-random-source) 3 3822934) 210 | ; 211 | ; should create a file that looks as follows (od -A x -t x1 outfile): 212 | ; 213 | ; 000000 bb 7e db 30 a3 49 14 f6 bb d0 f2 d0 54 a1 55 8b 214 | ; 000010 8c 03 3e cd ca a3 88 1d 01 20 35 e8 50 c8 47 65 215 | ; 000020 b0 e7 d9 28 4c b8 c0 f2 82 35 48 af 67 42 3e 8a 216 | ; 000030 a9 8c 78 12 ef b6 73 29 08 ff e9 71 d1 22 7f 52 217 | ; 000040 b8 f0 89 96 77 dc 71 86 28 65 2d c2 82 fc 8b f9 218 | ; 000050 52 d7 23 2a be 8e 3f 61 a8 99 84 0f ca 44 83 65 219 | ; 000060 fa 03 d6 c2 11 c0 65 9d 3a c2 7a dd ab 6f fe 1c 220 | ; ...total length is 11468802 bytes. 221 | ; 222 | ; The message digest is md5sum = 750ac219ff40c50bb2d04ff5eff9b24c. 223 | 224 | (define (write-diehard filename s bytes-per-call calls) 225 | (let ((port (open-output-file filename)) 226 | (rand (random-source-make-integers s)) 227 | (n (expt 256 bytes-per-call))) 228 | (do ((i 0 (+ i 1))) 229 | ((= i calls) 230 | (close-output-port port)) 231 | (let ((x (rand n))) 232 | (do ((k 0 (+ k 1))) ((= k bytes-per-call)) 233 | (put-u8 port (modulo x 256)) 234 | (set! x (quotient x 256))))))) 235 | 236 | ; run some tests 237 | (check-basics-1) 238 | (display "passed (check-basics-1)") 239 | (newline) 240 | 241 | (check-mrg32k3a) 242 | (display "passed (check-mrg32k3a)") 243 | (newline) 244 | 245 | ; (display "Generating diehard1 with expected MD5=4df554f56cb5ed251bd04b0d50767443\n") 246 | ; (write-diehard "diehard1" (make-random-source) 4 2867200) 247 | 248 | ;(display "Generating diehard2 with expected MD5=750ac219ff40c50bb2d04ff5eff9b24c\n") 249 | ; (display "Generating diehard2 with expected MD5=9c4cb1f6251efa301a98f226a76de5b9") 250 | ; (write-diehard "diehard2" (make-random-source) 3 3822934) 251 | -------------------------------------------------------------------------------- /srfi/tests/random.sps: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (import (rnrs) (srfi :27 random-bits)) 8 | 9 | (do ((i 0 (+ i 1))) 10 | ((= i 10) 'done) 11 | (display (random-integer 100)) 12 | (newline)) 13 | 14 | (do ((i 0 (+ i 1))) 15 | ((= i 10) 'done) 16 | (display (random-real)) 17 | (newline)) 18 | -------------------------------------------------------------------------------- /srfi/tests/rec-factorial.sps: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (import (rnrs) (srfi :31 rec)) 8 | 9 | (display 10 | ((rec (F N) 11 | (if (zero? N) 1 12 | (* N (F (- N 1))))) 13 | 10)) 14 | (newline) 15 | -------------------------------------------------------------------------------- /srfi/tests/records.sps: -------------------------------------------------------------------------------- 1 | ;; Copyright (c) 2009 Derick Eddington. All rights reserved. Licensed under an 2 | ;; MIT-style license. My license is in the file named LICENSE from the original 3 | ;; collection this file is distributed with. If this file is redistributed with 4 | ;; some other collection, my license must also be included. 5 | 6 | #!r6rs 7 | (import 8 | (rnrs base) ; no R6RS records 9 | (only (rnrs io simple) display write newline) 10 | (srfi :9 records)) 11 | 12 | (define-record-type thing 13 | (make-thing x) 14 | thing? 15 | (x thing-x) 16 | (y thing-y set-thing-y!)) 17 | 18 | (define t (make-thing 123)) 19 | (display "t => ") (write t) (newline) 20 | (set-thing-y! t 'blah) 21 | (display "t => ") (write t) (newline) 22 | -------------------------------------------------------------------------------- /srfi/tests/time.sps: -------------------------------------------------------------------------------- 1 | ;;; simple test procedures 2 | #!r6rs 3 | (import 4 | (rnrs) 5 | (rnrs mutable-pairs) 6 | (srfi :19 time) 7 | (srfi :48 intermediate-format-strings)) 8 | 9 | (define (printf fmt-str . args) 10 | (display (apply format fmt-str args))) 11 | 12 | (define s19-tests (list)) 13 | 14 | (define (define-s19-test! name thunk) 15 | (let ((name (if (symbol? name) name (string->symbol name))) 16 | (pr (assoc name s19-tests))) 17 | (if pr 18 | (set-cdr! pr thunk) 19 | (set! s19-tests (append s19-tests (list (cons name thunk))))))) 20 | 21 | (define (run-s19-test name thunk verbose) 22 | (if verbose (begin (display ";;; Running ") (display name))) 23 | (let ((result (thunk))) 24 | (if verbose (begin (display ": ") (display (not (not result))) (newline))) 25 | result)) 26 | 27 | (define (run-s19-tests . verbose) 28 | (let ((runs 0) (goods 0) (bads 0) (verbose (if (cdr verbose) (cdr verbose) #f))) 29 | (for-each (lambda (pr) 30 | (set! runs (+ runs 1)) 31 | (if (run-s19-test (car pr) (cdr pr) verbose) 32 | (set! goods (+ goods 1)) 33 | (set! bads (+ bads 1)))) 34 | s19-tests) 35 | (if verbose 36 | (begin 37 | (display ";;; Results: Runs: ") 38 | (display runs) 39 | (display "; Goods: ") 40 | (display goods) 41 | (display "; Bads: ") 42 | (display bads) 43 | (if (> runs 0) 44 | (begin 45 | (display "; Pass rate: ") 46 | (display (/ goods runs))) 47 | (display "; No tests.")) 48 | (newline))) 49 | (values runs goods bads))) 50 | 51 | (set! s19-tests (list)) 52 | 53 | (define-s19-test! "Creating time structures" 54 | (lambda () 55 | (not (null? (list (current-time 'time-tai) 56 | (current-time 'time-utc) 57 | (current-time 'time-monotonic) 58 | #|(current-time 'time-thread) 59 | (current-time 'time-process)|#))))) 60 | 61 | (define-s19-test! "Testing time resolutions" 62 | (lambda () 63 | (not (null? (list (time-resolution 'time-tai) 64 | (time-resolution 'time-utc) 65 | (time-resolution 'time-monotonic) 66 | #|(time-resolution 'time-thread) 67 | (time-resolution 'time-process)|#))))) 68 | 69 | (define-s19-test! "Time comparisons (time=?, etc.)" 70 | (lambda () 71 | (let ((t1 (make-time 'time-utc 0 1)) 72 | (t2 (make-time 'time-utc 0 1)) 73 | (t3 (make-time 'time-utc 0 2)) 74 | (t11 (make-time 'time-utc 1001 1)) 75 | (t12 (make-time 'time-utc 1001 1)) 76 | (t13 (make-time 'time-utc 1001 2)) 77 | ) 78 | (and (time=? t1 t2) 79 | (time>? t3 t2) 80 | (time<? t2 t3) 81 | (time>=? t1 t2) 82 | (time>=? t3 t2) 83 | (time<=? t1 t2) 84 | (time<=? t2 t3) 85 | (time=? t11 t12) 86 | (time>? t13 t12) 87 | (time<? t12 t13) 88 | (time>=? t11 t12) 89 | (time>=? t13 t12) 90 | (time<=? t11 t12) 91 | (time<=? t12 t13) 92 | )))) 93 | 94 | (define-s19-test! "Time difference" 95 | (lambda () 96 | (let ((t1 (make-time 'time-utc 0 3000)) 97 | (t2 (make-time 'time-utc 0 1000)) 98 | (t3 (make-time 'time-duration 0 2000)) 99 | (t4 (make-time 'time-duration 0 -2000))) 100 | (and 101 | (time=? t3 (time-difference t1 t2)) 102 | (time=? t4 (time-difference t2 t1)))))) 103 | 104 | 105 | (define-s19-test! "Time difference, nanoseconds" 106 | (lambda () 107 | (let ((t1 (make-time time-utc 1000 3000)) 108 | (t2 (make-time time-utc 0 3000)) 109 | (t3 (make-time time-duration 1000 0)) 110 | (t4 (make-time time-duration 999999000 -1))) 111 | (and 112 | (time=? t3 (time-difference t1 t2)) 113 | (time=? t4 (time-difference t2 t1)))))) 114 | 115 | (define (test-one-utc-tai-edge utc tai-diff tai-last-diff) 116 | (let* (;; right on the edge they should be the same 117 | (utc-basic (make-time 'time-utc 0 utc)) 118 | (tai-basic (make-time 'time-tai 0 (+ utc tai-diff))) 119 | (utc->tai-basic (time-utc->time-tai utc-basic)) 120 | (tai->utc-basic (time-tai->time-utc tai-basic)) 121 | ;; a second before they should be the old diff 122 | (utc-basic-1 (make-time 'time-utc 0 (- utc 1))) 123 | (tai-basic-1 (make-time 'time-tai 0 (- (+ utc tai-last-diff) 1))) 124 | (utc->tai-basic-1 (time-utc->time-tai utc-basic-1)) 125 | (tai->utc-basic-1 (time-tai->time-utc tai-basic-1)) 126 | ;; a second later they should be the new diff 127 | (utc-basic+1 (make-time 'time-utc 0 (+ utc 1))) 128 | (tai-basic+1 (make-time 'time-tai 0 (+ (+ utc tai-diff) 1))) 129 | (utc->tai-basic+1 (time-utc->time-tai utc-basic+1)) 130 | (tai->utc-basic+1 (time-tai->time-utc tai-basic+1)) 131 | ;; ok, let's move the clock half a month or so plus half a second 132 | (shy (* 15 24 60 60)) 133 | (hs (/ (expt 10 9) 2)) 134 | ;; a second later they should be the new diff 135 | (utc-basic+2 (make-time 'time-utc hs (+ utc shy))) 136 | (tai-basic+2 (make-time 'time-tai hs (+ (+ utc tai-diff) shy))) 137 | (utc->tai-basic+2 (time-utc->time-tai utc-basic+2)) 138 | (tai->utc-basic+2 (time-tai->time-utc tai-basic+2)) 139 | ) 140 | (and (time=? utc-basic tai->utc-basic) 141 | (time=? tai-basic utc->tai-basic) 142 | (time=? utc-basic-1 tai->utc-basic-1) 143 | (time=? tai-basic-1 utc->tai-basic-1) 144 | (time=? utc-basic+1 tai->utc-basic+1) 145 | (time=? tai-basic+1 utc->tai-basic+1) 146 | (time=? utc-basic+2 tai->utc-basic+2) 147 | (time=? tai-basic+2 utc->tai-basic+2) 148 | ))) 149 | 150 | (define-s19-test! "TAI-UTC Conversions" 151 | (lambda () 152 | (and 153 | (test-one-utc-tai-edge 915148800 32 31) 154 | (test-one-utc-tai-edge 867715200 31 30) 155 | (test-one-utc-tai-edge 820454400 30 29) 156 | (test-one-utc-tai-edge 773020800 29 28) 157 | (test-one-utc-tai-edge 741484800 28 27) 158 | (test-one-utc-tai-edge 709948800 27 26) 159 | (test-one-utc-tai-edge 662688000 26 25) 160 | (test-one-utc-tai-edge 631152000 25 24) 161 | (test-one-utc-tai-edge 567993600 24 23) 162 | (test-one-utc-tai-edge 489024000 23 22) 163 | (test-one-utc-tai-edge 425865600 22 21) 164 | (test-one-utc-tai-edge 394329600 21 20) 165 | (test-one-utc-tai-edge 362793600 20 19) 166 | (test-one-utc-tai-edge 315532800 19 18) 167 | (test-one-utc-tai-edge 283996800 18 17) 168 | (test-one-utc-tai-edge 252460800 17 16) 169 | (test-one-utc-tai-edge 220924800 16 15) 170 | (test-one-utc-tai-edge 189302400 15 14) 171 | (test-one-utc-tai-edge 157766400 14 13) 172 | (test-one-utc-tai-edge 126230400 13 12) 173 | (test-one-utc-tai-edge 94694400 12 11) 174 | (test-one-utc-tai-edge 78796800 11 10) 175 | (test-one-utc-tai-edge 63072000 10 0) 176 | (test-one-utc-tai-edge 0 0 0) ;; at the epoch 177 | (test-one-utc-tai-edge 10 0 0) ;; close to it ... 178 | (test-one-utc-tai-edge 1045789645 32 32) ;; about now ... 179 | ))) 180 | 181 | (define (tm:date= d1 d2) 182 | (and (= (date-year d1) (date-year d2)) 183 | (= (date-month d1) (date-month d2)) 184 | (= (date-day d1) (date-day d2)) 185 | (= (date-hour d1) (date-hour d2)) 186 | (= (date-second d1) (date-second d2)) 187 | (= (date-nanosecond d1) (date-nanosecond d2)) 188 | (= (date-zone-offset d1) (date-zone-offset d2)))) 189 | 190 | (define-s19-test! "TAI-Date Conversions" 191 | (lambda () 192 | (and 193 | (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 29)) 0) 194 | (make-date 0 58 59 23 31 12 1998 0)) 195 | (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 30)) 0) 196 | (make-date 0 59 59 23 31 12 1998 0)) 197 | (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 31)) 0) 198 | (make-date 0 60 59 23 31 12 1998 0)) 199 | (tm:date= (time-tai->date (make-time time-tai 0 (+ 915148800 32)) 0) 200 | (make-date 0 0 0 0 1 1 1999 0))))) 201 | 202 | (define-s19-test! "Date-UTC Conversions" 203 | (lambda () 204 | (and 205 | (time=? (make-time time-utc 0 (- 915148800 2)) 206 | (date->time-utc (make-date 0 58 59 23 31 12 1998 0))) 207 | (time=? (make-time time-utc 0 (- 915148800 1)) 208 | (date->time-utc (make-date 0 59 59 23 31 12 1998 0))) 209 | ;; yes, I think this is acutally right. 210 | (time=? (make-time time-utc 0 (- 915148800 0)) 211 | (date->time-utc (make-date 0 60 59 23 31 12 1998 0))) 212 | (time=? (make-time time-utc 0 (- 915148800 0)) 213 | (date->time-utc (make-date 0 0 0 0 1 1 1999 0))) 214 | (time=? (make-time time-utc 0 (+ 915148800 1)) 215 | (date->time-utc (make-date 0 1 0 0 1 1 1999 0)))))) 216 | 217 | (define-s19-test! "TZ Offset conversions" 218 | (lambda () 219 | (let ((ct-utc (make-time time-utc 6320000 1045944859)) 220 | (ct-tai (make-time time-tai 6320000 1045944891)) 221 | (cd (make-date 6320000 19 14 15 22 2 2003 -18000))) 222 | (and 223 | (time=? ct-utc (date->time-utc cd)) 224 | (time=? ct-tai (date->time-tai cd)))))) 225 | 226 | (begin (newline) (run-s19-tests #t)) 227 | 228 | 229 | (define (date->string/all-formats) 230 | ;; TODO: figure out why ~f isn't working 231 | ;; TODO: figure out why ~x and ~X aren't doing what the srfi-19 doc says they do 232 | (define fs 233 | '("~~" "~a" "~A" "~b" "~B" "~c" "~d" "~D" "~e" #;"~f" "~h" "~H" 234 | "~I" "~j" "~k" "~l" "~m" "~M" "~n" "~N" "~p" "~r" "~s" 235 | "~S" "~t" "~T" "~U" "~V" "~w" "~W" "~x" "~X" "~y" "~Y" 236 | "~z" "~Z" "~1" "~2" "~3" "~4" "~5")) 237 | (define cd (current-date)) 238 | (display "\n;;; Running date->string format exercise\n") 239 | (printf "(current-date)\n => ~s\n" cd) 240 | (for-each 241 | (lambda (f) 242 | (printf "\n--- Format: ~a ----------------------------------------\n" f) 243 | (display (date->string cd f)) (newline)) 244 | fs)) 245 | 246 | ;;TODO 247 | #;(define (string->date/all-formats) 248 | ) 249 | 250 | (date->string/all-formats) 251 | #;(string->date/all-formats) 252 | --------------------------------------------------------------------------------