Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Making libraries portable where possible.

Browse source 
Many still import (chibi), and as (scheme base) is somewhat more
expensive to load at present these are changed to cond-expand.
Many libraries also rely on (srfi 33), and these have been changed
to a cond-expand first trying (srfi 60) where available.
Also fixing a few portability concerns (duplicate imports of the
same binding), and adding a few libraries missing from lib-tests.scm.
This commit is contained in:
Alex Shinn 2015-04-26 16:17:38 +09:00
parent 12c9dc1038
commit 00691b64f1
40 changed files with 336 additions and 160 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
lib/chibi/binary-record.sld
View file

@ -1,8 +1,11 @@
(define-library (chibi binary-record)
(import (scheme base)
(srfi 1) (srfi 9) (srfi 33)
(srfi 1) (srfi 9)
(chibi io) (chibi string)
(only (chibi) identifier? er-macro-transformer))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (import (srfi 33))))
(export define-binary-record-type)
(include "binary-record.scm"))

5
lib/chibi/bytevector.sld
View file

@ -7,5 +7,8 @@
integer->bytevector bytevector->integer
integer->hex-string hex-string->integer
bytevector->hex-string hex-string->bytevector)
(import (scheme base) (srfi 33))
(import (scheme base))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (import (srfi 33))))
(include "bytevector.scm"))

5
lib/chibi/channel.sld
View file

@ -1,6 +1,9 @@
(define-library (chibi channel)
(import (chibi) (srfi 9) (srfi 18))
(cond-expand
(chibi (import (chibi) (srfi 9)))
(else (import (scheme base))))
(import (srfi 18))
(export Channel make-channel channel? channel-empty?
channel-send! channel-receive!)
(include "channel.scm"))

2
lib/chibi/char-set.sld
View file

@ -1,6 +1,6 @@
(define-library (chibi char-set)
(import (chibi) (chibi char-set base) (chibi char-set extras))
(import (chibi char-set base) (chibi char-set extras))
(export
Char-Set char-set? char-set-contains?
char-set ucs-range->char-set char-set-copy char-set-size

19
lib/chibi/char-set/base.sld
View file

@ -1,14 +1,23 @@
(define-library (chibi char-set base)
(import (chibi) (chibi iset base))
(cond-expand
(chibi
(import (chibi))
(begin
(define-syntax immutable-char-set
(sc-macro-transformer
(lambda (expr use-env)
(eval (cadr expr) use-env))))))
(else
(import (scheme base))
(begin
(define-syntax immutable-char-set
(syntax-rules () ((immutable-char-set cs) cs))))))
(import (chibi iset base))
(export (rename Integer-Set Char-Set)
(rename iset? char-set?)
immutable-char-set
char-set-contains?)
(begin
(define-syntax immutable-char-set
(sc-macro-transformer
(lambda (expr use-env)
(eval (cadr expr) use-env))))
(define (char-set-contains? cset ch)
(iset-contains? cset (char->integer ch)))))

8
lib/chibi/char-set/boundary.sld
View file

@ -4,10 +4,12 @@
(define-library (chibi char-set boundary)
(cond-expand
(chibi
(import (chibi) (chibi char-set)))
(chibi (import (chibi)))
(else (import (scheme base))))
(cond-expand
((library (chibi char-set)) (import (chibi char-set)))
(else
(import (scheme base) (srfi 14))
(import (srfi 14))
(begin (define (immutable-char-set cs) cs))))
(export char-set:regional-indicator
char-set:extend-or-spacing-mark

5
lib/chibi/char-set/extras.sld
View file

@ -1,6 +1,9 @@
(define-library (chibi char-set extras)
(import (chibi) (chibi iset) (chibi char-set base))
(cond-expand
(chibi (import (chibi)))
(else (import (scheme base))))
(import (chibi iset) (chibi char-set base))
(include "extras.scm")
(export
char-set ucs-range->char-set char-set-copy char-set-size

5
lib/chibi/crypto/md5.sld
View file

@ -1,5 +1,8 @@
(define-library (chibi crypto md5)
(import (scheme base) (srfi 33) (chibi bytevector))
(import (scheme base) (chibi bytevector))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (import (srfi 33))))
(export md5)
(include "md5.scm"))

5
lib/chibi/crypto/rsa.sld
View file

@ -1,7 +1,10 @@
(define-library (chibi crypto rsa)
(import (scheme base) (srfi 27) (srfi 33)
(import (scheme base) (srfi 27)
(chibi bytevector) (chibi math prime))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (import (srfi 33))))
(export make-rsa-key rsa-key-gen rsa-key-gen-from-primes rsa-pub-key
rsa-encrypt rsa-decrypt rsa-sign rsa-verify rsa-verify?
rsa-key? rsa-key-bits rsa-key-n rsa-key-e rsa-key-d

5
lib/chibi/crypto/sha2.sld
View file

@ -7,7 +7,10 @@
(include "sha2-native.scm")
(include-shared "crypto"))
(else
(import (srfi 33) (chibi bytevector))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (import (srfi 33))))
(import (chibi bytevector))
(include "sha2.scm"))))
;;> \procedure{(sha-224 src)}

4
lib/chibi/filesystem-test.sld
View file

@ -3,13 +3,13 @@
(import (chibi) (chibi io) (chibi filesystem) (chibi test) (srfi 33))
(begin
(define (run-tests)
(test-begin "filesystem")
(define tmp-file "/tmp/chibi-fs-test-0123456789")
(define tmp-file2 "/tmp/chibi-fs-test-0123456789-2")
(define tmp-link "/tmp/chibi-fs-test-0123456789-link")
(define tmp-dir "/tmp/chibi-fs-test-0123456789-dir")
(test-begin "filesystem")
(call-with-output-file tmp-file
(lambda (out) (display "0123456789" out)))

2
lib/chibi/generic-test.sld
View file

@ -1,4 +1,4 @@
(define-library (chibi filesystem-test)
(define-library (chibi generic-test)
(export run-tests)
(import (chibi) (chibi generic) (chibi test))
(begin

27
lib/chibi/iset-test.sld
View file

@ -1,16 +1,19 @@
(define-library (chibi iset-test)
(export run-tests)
(import (chibi) (chibi iset) (chibi iset optimize) (srfi 1) (chibi test))
(import (scheme base) (scheme write)
(except (srfi 1) make-list list-copy)
(chibi iset) (chibi iset optimize)
(chibi test))
(begin
(define (run-tests)
(define (test-name iset op)
(call-with-output-string
(lambda (out)
(let* ((ls (iset->list iset))
(ls (if (> (length ls) 10)
`(,@(take ls 5) ... ,@(take-right ls 5))
ls)))
(write `(,(car op) (iset ,@ls) ,@(cdr op)) out)))))
(let ((out (open-output-string)))
(let* ((ls (iset->list iset))
(ls (if (> (length ls) 10)
`(,@(take ls 5) ... ,@(take-right ls 5))
ls)))
(write `(,(car op) (iset ,@ls) ,@(cdr op)) out)
(get-output-string out))))
(test-begin "iset")
@ -122,10 +125,10 @@
;; initial creation and sanity checks
(test-assert (lset= equal? ls2 (iset->list is)))
(test (length ls2) (iset-size is))
(test-assert (call-with-output-string
(lambda (out)
(display "init: " out)
(write ls out)))
(test-assert (let ((out (open-output-string)))
(display "init: " out)
(write ls out)
(get-output-string out))
(every
(lambda (x) (iset-contains? is x))
ls))

2
lib/chibi/iset.sld
View file

@ -68,7 +68,7 @@
(chibi iset constructors))
(export
%make-iset make-iset iset? iset-contains? Integer-Set
iset iset-copy list->iset list->iset! iset-map
iset iset-copy list->iset list->iset!
iset-adjoin iset-adjoin! iset-delete iset-delete!
iset-union iset-union! iset-intersection iset-intersection!
iset-difference iset-difference!

7
lib/chibi/iset/base.sld
View file

@ -1,6 +1,11 @@
(define-library (chibi iset base)
(import (chibi) (srfi 9) (srfi 33))
(cond-expand
(chibi (import (chibi) (srfi 9)))
(else (import (scheme base))))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (import (srfi 33))))
(include "base.scm")
(export
%make-iset make-iset iset? iset-contains? Integer-Set

8
lib/chibi/iset/constructors.sld
View file

@ -1,6 +1,12 @@
(define-library (chibi iset constructors)
(import (chibi) (srfi 33) (chibi iset base) (chibi iset iterators))
(cond-expand
(chibi (import (chibi)))
(else (import (scheme base))))
(import (chibi iset base) (chibi iset iterators))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (import (srfi 33))))
(include "constructors.scm")
(export
iset iset-copy list->iset list->iset! iset-map

8
lib/chibi/iset/iterators.sld
View file

@ -1,6 +1,12 @@
(define-library (chibi iset iterators)
(import (chibi) (srfi 9) (srfi 33) (chibi iset base))
(cond-expand
(chibi (import (chibi) (srfi 9)))
(else (import (scheme base))))
(import (chibi iset base))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (import (srfi 33))))
(include "iterators.scm")
(export
iset-empty? iset-fold iset-fold-node iset-for-each iset-for-each-node

14
lib/chibi/iset/optimize.sld
View file

@ -1,9 +1,19 @@
(define-library (chibi iset optimize)
(import (chibi) (srfi 9) (srfi 33)
(chibi iset base)
(cond-expand
(chibi (import (chibi) (srfi 9)))
(else (import (scheme base))))
(import (chibi iset base)
(chibi iset iterators)
(chibi iset constructors))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else
(import (srfi 33))
(begin
(define (%mask size) (bitwise-not (arithmetic-shift -1 size)))
(define (extract-bit-field size position n)
(bitwise-and (%mask size) (arithmetic-shift n (- position)))))))
(include "optimize.scm")
(export
iset-balance iset-balance! iset-optimize iset-optimize! iset->code))

5
lib/chibi/math/prime.sld
View file

@ -1,6 +1,9 @@
(define-library (chibi math prime)
(import (scheme base) (scheme inexact) (srfi 27) (srfi 33))
(import (scheme base) (scheme inexact) (srfi 27))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (import (srfi 33))))
(export prime? nth-prime prime-above prime-below factor perfect?
totient aliquot
provable-prime? probable-prime?

127
lib/chibi/parse-test.sld
View file

@ -1,8 +1,10 @@
(define-library (chibi parse-test)
(export run-tests)
(import (chibi) (chibi test)
(chibi char-set) (chibi char-set ascii)
(chibi parse) (chibi parse common))
(import (scheme base) (scheme char)
(chibi test) (chibi parse) (chibi parse common))
(cond-expand
(chibi (import (chibi char-set) (chibi char-set ascii)))
(else (import (srfi 14))))
(begin
(define (run-tests)
(test-begin "parse")
@ -73,68 +75,73 @@
;; partial match (grammar isn't checking end)
(test 42 (parse term "42*")))
(define calculator
(grammar expr
(space ((: ,char-set:whitespace ,space))
(() #f))
(digit ((=> d ,char-set:digit) d))
(number ((=> n (+ ,digit))
(string->number (list->string n))))
(simple ((=> n ,number) n)
((: "(" (=> e1 ,expr) ")") e1))
(term-op ("*" *)
("/" /)
("%" modulo))
(term ((: (=> e1 ,simple) ,space (=> op ,term-op) ,space (=> e2 ,term))
(op e1 e2))
((=> e1 ,simple)
e1))
(expr-op ("+" +) ("-" -))
(expr ((: ,space (=> e1 ,term) ,space (=> op ,expr-op) ,space (=> e2 ,expr))
(op e1 e2))
((: ,space (=> e1 ,term))
e1))))
(let ()
(define calculator
(grammar expr
(space ((: ,char-set:whitespace ,space))
(() #f))
(digit ((=> d ,char-set:digit) d))
(number ((=> n (+ ,digit))
(string->number (list->string n))))
(simple ((=> n ,number) n)
((: "(" (=> e1 ,expr) ")") e1))
(term-op ("*" *)
("/" /)
("%" modulo))
(term ((: (=> e1 ,simple) ,space (=> op ,term-op) ,space
(=> e2 ,term))
(op e1 e2))
((=> e1 ,simple)
e1))
(expr-op ("+" +) ("-" -))
(expr ((: ,space (=> e1 ,term) ,space (=> op ,expr-op) ,space
(=> e2 ,expr))
(op e1 e2))
((: ,space (=> e1 ,term))
e1))))
(test 42 (parse calculator "42"))
(test 4 (parse calculator "2 + 2"))
(test 23 (parse calculator "2 + 2*10 + 1"))
(test 25 (parse calculator "2+2 * 10+1 * 3"))
(test 41 (parse calculator "(2 + 2) * 10 + 1"))
(test 42 (parse calculator "42"))
(test 4 (parse calculator "2 + 2"))
(test 23 (parse calculator "2 + 2*10 + 1"))
(test 25 (parse calculator "2+2 * 10+1 * 3"))
(test 41 (parse calculator "(2 + 2) * 10 + 1")))
(define prec-calc
(grammar expr
(simple (,(parse-integer))
((: "(" (=> e1 ,expr) ")") e1))
(op
("+" '+) ("-" '-) ("*" '*) ("/" '/) ("^" '^))
(expr
(,(parse-binary-op op
`((+ 5) (- 5) (* 3) (/ 3) (^ 1 right))
simple)))))
(let ()
(define prec-calc
(grammar expr
(simple (,(parse-integer))
((: "(" (=> e1 ,expr) ")") e1))
(op
("+" '+) ("-" '-) ("*" '*) ("/" '/) ("^" '^))
(expr
(,(parse-binary-op op
`((+ 5) (- 5) (* 3) (/ 3) (^ 1 right))
simple)))))
(test 42 (parse prec-calc "42"))
(test '(+ 2 2) (parse prec-calc "2 + 2"))
(test '(+ (+ 2 2) 2) (parse prec-calc "2 + 2 + 2"))
(test '(+ (+ 2 (* 2 10)) 1) (parse prec-calc "2 + 2*10 + 1"))
(test '(+ (+ 2 (* 2 10)) (* 1 3)) (parse prec-calc "2+2 * 10+1 * 3"))
(test '(+ (* (+ 2 2) 10) 1) (parse prec-calc "(2 + 2) * 10 + 1"))
(test '(^ 2 (^ 2 2)) (parse prec-calc "2 ^ 2 ^ 2"))
(test '(+ (+ (+ 1 (* (* 2 (^ 3 (^ 4 5))) 6)) (^ 7 8)) 9)
(parse prec-calc "1 + 2 * 3 ^ 4 ^ 5 * 6 + 7 ^ 8 + 9"))
(test 42 (parse prec-calc "42"))
(test '(+ 2 2) (parse prec-calc "2 + 2"))
(test '(+ (+ 2 2) 2) (parse prec-calc "2 + 2 + 2"))
(test '(+ (+ 2 (* 2 10)) 1) (parse prec-calc "2 + 2*10 + 1"))
(test '(+ (+ 2 (* 2 10)) (* 1 3)) (parse prec-calc "2+2 * 10+1 * 3"))
(test '(+ (* (+ 2 2) 10) 1) (parse prec-calc "(2 + 2) * 10 + 1"))
(test '(^ 2 (^ 2 2)) (parse prec-calc "2 ^ 2 ^ 2"))
(test '(+ (+ (+ 1 (* (* 2 (^ 3 (^ 4 5))) 6)) (^ 7 8)) 9)
(parse prec-calc "1 + 2 * 3 ^ 4 ^ 5 * 6 + 7 ^ 8 + 9")))
;; this takes exponential time without memoization
(define explode
(grammar start
(start ((: ,S eos) #t))
(S ((+ ,A) #t))
(A ((: "a" ,S "b") #t)
((: "a" ,S "c") #t)
((: "a") #t))))
(let ()
(define explode
(grammar start
(start ((: ,S eos) #t))
(S ((+ ,A) #t))
(A ((: "a" ,S "b") #t)
((: "a" ,S "c") #t)
((: "a") #t))))
(test-assert (parse explode "aaabb"))
(test-not (parse explode "bbaa"))
(test-assert
(parse explode
(string-append (make-string 10 #\a) (make-string 8 #\c))))
(test-assert (parse explode "aaabb"))
(test-not (parse explode "bbaa"))
(test-assert
(parse explode
(string-append (make-string 10 #\a) (make-string 8 #\c)))))
(test-end))))

8
lib/chibi/parse.sld
View file

@ -14,15 +14,13 @@
parse-string parse-token parse-sre
parse-beginning parse-end
parse-beginning-of-line parse-end-of-line
parse-beginning-of-line parse-end-of-line
parse-beginning-of-word parse-end-of-word
parse-word parse-word+
parse-with-failure-reason
make-parse-stream)
(import (chibi) (chibi char-set) (srfi 9))
(include "parse/parse.scm")
(cond-expand
(chibi
(import (chibi) (chibi char-set) (srfi 9))
(begin
(define-syntax grammar-bind
(er-macro-transformer
@ -59,6 +57,7 @@
(cons (list name new-tmp) bindings))))
(append k (list f bindings)))))))))
(else
(import (scheme base) (scheme char) (scheme file) (srfi 14))
(begin
(define-syntax grammar-bind
(syntax-rules ()
@ -77,4 +76,5 @@
(lambda (r s i fk) (set! new-tmp r) (sk r s i fk))
(lambda (s i r) (set! new-tmp save-tmp) (fk s i r)))))
((var tmp) ... (name new-tmp)))
(k ... f ((var tmp) ...)))))))))))
(k ... f ((var tmp) ...))))))))))
(include "parse/parse.scm"))

5
lib/chibi/parse/common.sld
View file

@ -7,5 +7,8 @@
parse-ipv4-address parse-ipv6-address parse-ip-address
parse-domain parse-common-domain parse-email parse-uri
char-hex-digit? char-octal-digit?)
(import (chibi) (chibi parse))
(cond-expand
(chibi (import (chibi)))
(else (import (scheme base) (scheme char))))
(import (chibi parse))
(include "common.scm"))

2
lib/chibi/pathname-test.sld
View file

@ -1,6 +1,6 @@
(define-library (chibi pathname-test)
(export run-tests)
(import (chibi) (chibi pathname) (chibi test))
(import (scheme base) (chibi pathname) (chibi test))
(begin
(define (run-tests)
(test-begin "pathname")

2
lib/chibi/pathname.scm
View file

@ -80,7 +80,7 @@
(define (path-strip-leading-parents path)
(if (string-prefix? "../" path)
(path-strip-leading-parents (substring path 3))
(path-strip-leading-parents (substring-cursor path 3))
(if (equal? path "..") "" path)))
;;> Returns \scheme{#t} iff \var{path} is an absolute path,

5
lib/chibi/pathname.sld
View file

@ -4,5 +4,8 @@
path-extension path-strip-extension path-replace-extension
path-absolute? path-relative? path-strip-leading-parents
path-relative-to path-resolve path-normalize make-path)
(import (chibi) (chibi string))
(cond-expand
(chibi (import (chibi)))
(else (import (except (scheme base) string-map string-for-each))))
(import (chibi string))
(include "pathname.scm"))

5
lib/chibi/regexp.sld
View file

@ -8,7 +8,10 @@
regexp-match-submatch regexp-match-submatch/list
regexp-match-submatch-start regexp-match-submatch-end
regexp-match->list regexp-match->sexp)
(import (srfi 33) (srfi 69))
(import (srfi 69))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (import (srfi 33))))
;; Chibi's char-set library is more factored than SRFI-14.
(cond-expand
(chibi

5
lib/chibi/regexp/pcre.sld
View file

@ -2,6 +2,9 @@
(define-library (chibi regexp pcre)
(export pcre->sre pcre->regexp)
(import (scheme base) (scheme char) (scheme cxr)
(srfi 1) (srfi 33)
(srfi 1)
(chibi string) (chibi regexp))
(cond-expand
((library (srfi 60)) (import (srfi 60)))
(else (import (srfi 33))))
(include "pcre.scm"))

18
lib/chibi/scribble-test.sld
View file

@ -1,16 +1,22 @@
(define-library (chibi scribble-test)
(export run-tests)
(import (chibi) (chibi scribble) (only (chibi test) test-begin test test-end))
(import (scheme base) (scheme write) (chibi scribble)
(only (chibi test) test-begin test test-end))
(begin
(define (call-with-output-string proc)
(let ((out (open-output-string)))
(proc out)
(get-output-string out)))
(define (call-with-input-string str proc)
(proc (open-input-string str)))
(define (test-scribble expect str)
(test (call-with-output-string (lambda (out) (write str out)))
expect
(call-with-input-string str scribble-parse)))
(define (run-tests)
(test-begin "scribble")
(define (test-scribble expect str)
(test (call-with-output-string (lambda (out) (write str out)))
expect
(call-with-input-string str scribble-parse)))
(test-scribble '((foo "blah blah blah")) "\\foo{blah blah blah}")
(test-scribble '((foo "blah \"blah\" (`blah'?)")) "\\foo{blah \"blah\" (`blah'?)}")
(test-scribble '((foo 1 2 "3 4")) "\\foo[1 2]{3 4}")

2
lib/chibi/scribble.scm
View file

@ -67,7 +67,7 @@
((eqv? #\. ch)
(read-char in)
(if (= base 10)
(begin (read-char in) (read-float-tail in (exact->inexact acc)))
(begin (read-char in) (read-float-tail in (inexact acc)))
(error "non-base-10 floating point")))
(else (error "invalid numeric syntax"))))))

2
lib/chibi/scribble.sld
View file

@ -1,5 +1,5 @@
(define-library (chibi scribble)
(export scribble-parse scribble-read)
(import (chibi))
(import (scheme base) (scheme char) (scheme read))
(include "scribble.scm"))

4
lib/chibi/show-test.sld
View file

@ -311,11 +311,11 @@
delightful
wubbleflubbery)\n")
(test-pretty
'(test-pretty
"#(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
26 27 28 29 30 31 32 33 34 35 36 37)\n")
(test-pretty
'(test-pretty
"(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25
26 27 28 29 30 31 32 33 34 35 36 37)\n")

12
lib/chibi/string-test.sld
View file

@ -1,8 +1,13 @@
(define-library (chibi string-test)
(export run-tests)
(import (only (chibi test) test-begin test test-end)
(import (scheme base) (scheme char)
(only (chibi test) test-begin test test-end)
(chibi string))
(begin
(define (digit-value ch)
(case ch
((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4)
((#\5) 5) ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9) (else #f)))
(define (run-tests)
(test-begin "strings")
@ -14,11 +19,6 @@
(test #f (string-every char-alphabetic? " abc"))
(test #f (string-every char-alphabetic? "a.c"))
(define (digit-value ch)
(case ch
((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4)
((#\5) 5) ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9) (else #f)))
(test 3 (string-any digit-value "a3c"))
(test #f (string-any digit-value "abc"))

22
lib/chibi/string.scm
View file

@ -1,5 +1,5 @@
;; strings.scm -- cursor-oriented string library
;; Copyright (c) 2012 Alex Shinn. All rights reserved.
;; Copyright (c) 2012-2015 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
(define (string-null? str)
@ -164,26 +164,6 @@
(let ((pred (make-char-predicate x)))
(string-fold (lambda (ch count) (if (pred ch) (+ count 1) count)) 0 str)))
(define (string-for-each proc str . los)
(if (null? los)
(string-fold (lambda (ch a) (proc ch)) #f str)
(let ((los (cons str los)))
(let lp ((is (map string-cursor-start los)))
(cond
((any (lambda (str i)
(string-cursor>=? i (string-cursor-end str)))
los is))
(else
(apply proc (map string-cursor-ref los is))
(lp (map string-cursor-next los is))))))))
(define (string-map proc str . los)
(call-with-output-string
(lambda (out)
(apply string-for-each
(lambda args (write-char (apply proc args) out))
str los))))
(define (make-string-searcher needle)
(lambda (haystack) (string-contains haystack needle)))

59
lib/chibi/string.sld
View file

@ -13,5 +13,62 @@
string-fold string-fold-right string-map string-for-each
string-contains make-string-searcher
string-downcase-ascii string-upcase-ascii)
(import (chibi) (chibi ast) (chibi char-set base))
(cond-expand
(chibi
(import (chibi) (chibi ast) (chibi char-set base))
(begin
(define (string-for-each proc str . los)
(if (null? los)
(string-fold (lambda (ch a) (proc ch)) #f str)
(let ((los (cons str los)))
(let lp ((is (map string-cursor-start los)))
(cond
((any (lambda (str i)
(string-cursor>=? i (string-cursor-end str)))
los is))
(else
(apply proc (map string-cursor-ref los is))
(lp (map string-cursor-next los is))))))))
(define (string-map proc str . los)
(call-with-output-string
(lambda (out)
(apply string-for-each
(lambda args (write-char (apply proc args) out))
str los))))))
(else
(import (scheme base) (scheme char) (srfi 14)
(except (srfi 1) make-list list-copy))
(begin
(define string-cursor<? <)
(define string-cursor>? >)
(define string-cursor=? =)
(define string-cursor<=? <=)
(define string-cursor>=? >=)
(define string-cursor-ref string-ref)
(define (string-cursor-start s) 0)
(define string-cursor-end string-length)
(define (string-cursor-next s i) (+ i 1))
(define (string-cursor-prev s i) (- i 1))
(define (substring-cursor s start . o)
(substring s start (if (pair? o) (car o) (string-length s))))
(define (string-concatenate ls) (apply string-append ls))
(define string-size string-length)
(define (call-with-output-string proc)
(let ((out (open-output-string)))
(proc out)
(get-output-string out))))))
(cond-expand
(chibi)
((library (srfi 13))
(import (only (srfi 13) string-contains)))
(else
(begin
(define (string-contains a b)
(let ((alen (string-length a))
(blen (string-length b)))
(let lp ((i 0))
(and (<= (+ i blen) alen)
(if (string=? b (substring a i (+ i blen)))
i
(lp (+ i 1))))))))))
(include "string.scm"))

8
lib/chibi/term/ansi.scm
View file

@ -64,7 +64,7 @@
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 5)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B[38;5;"
"\x1B;[38;5;"
(number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
"m"))
@ -78,7 +78,7 @@
(define (gray-escape gray-level)
(when (not (and (exact-integer? gray-level) (<= 0 gray-level 23)))
(error "invalid gray-level value" gray-level))
(string-append "\x1B[38;5;"
(string-append "\x1B;[38;5;"
(number->string (+ gray-level 232))
"m"))
@ -196,7 +196,7 @@
(when (not (and (exact-integer? blue-level) (<= 0 blue-level 5)))
(error "invalid blue-level value" blue-level))
(string-append
"\x1B[48;5;"
"\x1B;[48;5;"
(number->string (+ (* 36 red-level) (* 6 green-level) blue-level 16))
"m"))
@ -210,7 +210,7 @@
(define (gray-background-escape gray-level)
(when (not (and (exact-integer? gray-level) (<= 0 gray-level 23)))
(error "invalid gray-level value" gray-level))
(string-append "\x1B[48;5;"
(string-append "\x1B;[48;5;"
(number->string (+ gray-level 232))
"m"))

10
lib/chibi/test.sld
View file

@ -5,22 +5,20 @@
test-group current-test-group
test-begin test-end test-syntax-error test-propagate-info
test-vars test-run test-exit
current-test-verbosity current-test-epsilon current-test-comparator
current-test-verbosity
current-test-applier current-test-handler current-test-skipper
current-test-group-reporter test-failure-count
current-test-epsilon current-test-comparator)
(import (scheme write)
(import (scheme base)
(scheme write)
(scheme complex)
(scheme process-context)
(scheme time)
(chibi term ansi))
(cond-expand
(chibi
(import (except (scheme base) guard)
(rename (only (chibi) pair-source print-exception protect)
(protect guard))))
(import (only (chibi) pair-source print-exception protect)))
(else
(import (scheme base))
(begin
(define (pair-source x) #f)
(define print-exception write))))

2
lib/chibi/uri-test.sld
View file

@ -1,6 +1,6 @@
(define-library (chibi uri-test)
(export run-tests)
(import (chibi) (chibi test) (chibi uri))
(import (scheme base) (chibi test) (chibi uri))
(begin
(define (run-tests)
(test-begin "uri")

11
lib/chibi/uri.sld
View file

@ -5,5 +5,14 @@
uri-with-scheme uri-with-user uri-with-host uri-with-path
uri-with-query uri-with-fragment uri-resolve
uri-encode uri-decode uri-query->alist uri-alist->query)
(import (chibi) (chibi string) (chibi pathname) (srfi 9))
(cond-expand
(chibi
(import (chibi) (srfi 9)))
(else
(import (except (scheme base) string-map string-for-each)
(scheme char))
(begin
(define (string-concatenate ls)
(apply string-append ls)))))
(import (chibi string) (chibi pathname))
(include "uri.scm"))

35
lib/srfi/1.sld
View file

@ -18,7 +18,39 @@
lset<= lset= lset-adjoin lset-union lset-union! lset-intersection
lset-intersection! lset-difference lset-difference! lset-xor lset-xor!
lset-diff+intersection lset-diff+intersection!)
(import (chibi))
(cond-expand
(chibi
(import (chibi)))
(else
(import (scheme base))
(begin
(define reverse! reverse)
(define (find-tail pred ls)
(and (pair? ls) (if (pred (car ls)) ls (find-tail pred (cdr ls)))))
(define (find pred ls)
(cond ((find-tail pred ls) => car) (else #f)))
(define (any pred ls . lol)
(define (any1 pred ls)
(if (pair? (cdr ls))
((lambda (x) (if x x (any1 pred (cdr ls)))) (pred (car ls)))
(pred (car ls))))
(define (anyn pred lol)
(if (every pair? lol)
((lambda (x) (if x x (anyn pred (map cdr lol))))
(apply pred (map car lol)))
#f))
(if (null? lol)
(if (pair? ls) (any1 pred ls) #f)
(anyn pred (cons ls lol))))
(define (every pred ls . lol)
(define (every1 pred ls)
(if (null? (cdr ls))
(pred (car ls))
(if (pred (car ls)) (every1 pred (cdr ls)) #f)))
(if (null? lol)
(if (pair? ls) (every1 pred ls) #t)
(not (apply any (lambda xs (not (apply pred xs))) ls lol))))
)))
(include "1/predicates.scm"
"1/selectors.scm"
"1/search.scm"
@ -28,4 +60,3 @@
"1/deletion.scm"
"1/alists.scm"
"1/lset.scm"))

11
tests/lib-tests.scm
View file

@ -15,20 +15,27 @@
(rename (chibi crypto md5-test) (run-tests run-md5-tests))
(rename (chibi crypto rsa-test) (run-tests run-rsa-tests))
(rename (chibi crypto sha2-test) (run-tests run-sha2-tests))
;;(rename (chibi filesystem-test) (run-tests run-filesystem-tests))
(rename (chibi generic-test) (run-tests run-generic-tests))
(rename (chibi io-test) (run-tests run-io-tests))
(rename (chibi iset-test) (run-tests run-iset-tests))
(rename (chibi loop-test) (run-tests run-loop-tests))
(rename (chibi match-test) (run-tests run-match-tests))
(rename (chibi math prime-test) (run-tests run-prime-tests))
;;(rename (chibi memoize-test) (run-tests run-memoize-tests))
(rename (chibi mime-test) (run-tests run-mime-tests))
(rename (chibi parse-test) (run-tests run-parse-tests))
(rename (chibi pathname-test) (run-tests run-pathname-tests))
(rename (chibi process-test) (run-tests run-process-tests))
(rename (chibi regexp-test) (run-tests run-regexp-tests))
(rename (chibi scribble-test) (run-tests run-scribble-tests))
(rename (chibi show-test) (run-tests run-show-tests))
(rename (chibi string-test) (run-tests run-string-tests))
(rename (chibi system-test) (run-tests run-system-tests))
(rename (chibi tar-test) (run-tests run-tar-tests))
(rename (chibi term ansi-test) (run-tests run-term-ansi-tests))
(rename (chibi uri-test) (run-tests run-uri-tests))
;;(rename (chibi weak-test) (run-tests run-weak-tests))
)
(test-begin "libraries")
@ -44,6 +51,7 @@
(run-srfi-95-tests)
(run-srfi-99-tests)
(run-base64-tests)
(run-generic-tests)
(run-io-tests)
(run-iset-tests)
(run-loop-tests)
@ -51,12 +59,15 @@
(run-md5-tests)
(run-mime-tests)
(run-parse-tests)
(run-pathname-tests)
(run-prime-tests)
(run-process-tests)
(run-regexp-tests)
(run-rsa-tests)
(run-scribble-tests)
(run-string-tests)
(run-sha2-tests)
(run-show-tests)
(run-system-tests)
(run-tar-tests)
(run-term-ansi-tests)