Skip to content

Commit 23c1e35

Browse files
Göran Weinholtarcfide
Göran Weinholt
authored and
arcfide
committed
SRFI-14 implementation from Scheme 48 with Unicode support (arcfide#13)
* SRFI-14 implementation from Scheme 48 with Unicode support We previously carried the reference implementation of SRFI-14, which only supports the latin-1 character set. This commit switches us to the implementation in Scheme 48, which supports Unicode. The files are from Scheme 48 version 1.9.2. Fixes arcfide#9. * SRFI-14: Remove vararg.scm and add a simpler opt-lambda macro
1 parent a19b1eb commit 23c1e35

11 files changed

+3506
-741
lines changed

‎%3a14/COPYING

Lines changed: 39 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,39 @@
1+
The *.scm files in the SRFI-14 implementation are from Scheme 48. This
2+
is an excerpt from Scheme 48's COPYING file.
3+
4+
It is distributed under the following terms:
5+
6+
Copyright � 1986-2001 Richard Kelsey and Jonathan Rees.
7+
Copyright � 2001-2007 Michael Sperber and Martin Gasbichler.
8+
Copyright � 2007-2012 Michael Sperber and Marcus Crestani.
9+
All rights reserved.
10+
11+
Redistribution and use in source and binary forms, with or without
12+
modification, are permitted provided that the following conditions
13+
are met:
14+
1. Redistributions of source code must retain the above copyright
15+
notices, this list of conditions and the following disclaimer.
16+
2. Redistributions in binary form must reproduce the above copyright
17+
notices, this list of conditions and the following disclaimer in the
18+
documentation and/or other materials provided with the distribution.
19+
3. The name of the authors may not be used to endorse or promote products
20+
derived from this software without specific prior written permission.
21+
22+
THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
23+
IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
24+
OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
25+
IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
26+
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
27+
NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
28+
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
29+
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
30+
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
31+
THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32+
33+
Scheme 48 1.9 derives from Scheme 48 0.58, which was developed by
34+
Richard Kelsey and Jonathan Rees and incorporates PreScheme 0.5 by
35+
Richard Kelsey.
36+
37+
This distribution includes code for processing Unicode text
38+
contributed by Basis Technology Corporation, otherwise distributed
39+
under the license above.

‎%3a14/char-sets.sls

Lines changed: 50 additions & 19 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,7 @@
1+
;; -*- mode: scheme; coding: utf-8 -*-
2+
;; Copyright © 2018 Göran Weinholt <goran@weinholt.se>
3+
;; SPDX-License-Identifier: (MIT OR BSD-3-Clause OR LicenseRef-LICENSE)
14
#!r6rs
2-
;; Copyright 2010 Derick Eddington. My MIT-style license is in the file named
3-
;; LICENSE from the original collection this file is distributed with.
4-
5-
;; TODO: Are there any issues w.r.t. R6RS Unicode support when using the
6-
;; pre-R6RS reference implementation? I suspect there are.
75

86
(library (srfi :14 char-sets)
97
(export
@@ -19,7 +17,7 @@
1917
list->char-set! string->char-set!
2018
char-set-filter ucs-range->char-set
2119
char-set-filter! ucs-range->char-set!
22-
->char-set
20+
(rename (x->char-set ->char-set))
2321
; Querying character sets
2422
char-set->list char-set->string
2523
char-set-size char-set-count char-set-contains?
@@ -37,24 +35,57 @@
3735
char-set:graphic char-set:printing char-set:whitespace
3836
char-set:iso-control char-set:punctuation char-set:symbol
3937
char-set:hex-digit char-set:blank char-set:ascii
40-
char-set:empty char-set:full
41-
)
38+
char-set:empty char-set:full)
4239
(import
4340
(except (rnrs) define-record-type)
4441
(rnrs mutable-strings)
4542
(rnrs r5rs)
46-
(srfi :23 error tricks)
43+
(rename (only (srfi :1 lists) partition)
44+
(partition partition-list))
4745
(srfi :9 records)
48-
(srfi private check-arg)
46+
(srfi private include)
4947
(srfi private let-opt)
50-
(srfi private include))
48+
(srfi :14 char-sets inversion-list))
49+
50+
(define-syntax define-record-discloser
51+
(syntax-rules ()
52+
((_ type discloser)
53+
(define dummy #f))))
54+
55+
(define (make-immutable! obj)
56+
#f)
57+
58+
(define char->scalar-value char->integer)
59+
(define scalar-value->char integer->char)
60+
61+
(define make-byte-vector make-bytevector)
62+
(define byte-vector-ref bytevector-u8-ref)
63+
(define byte-vector-set! bytevector-u8-set!)
64+
(define byte-vector=? bytevector=?)
65+
(define copy-bytes! bytevector-copy!)
66+
(define byte-vector-length bytevector-length)
67+
68+
(define (unspecific) (if #f #f))
69+
70+
(define-syntax opt-lambda
71+
(lambda (x)
72+
(define (split-args args)
73+
(syntax-case args ()
74+
[(name . rest)
75+
(identifier? #'name)
76+
(let-values (((names opt-args) (split-args #'rest)))
77+
(values (cons #'name names) opt-args))]
78+
[(opt-args ...)
79+
(values '() #'(opt-args ...))]))
5180

52-
;; TODO: FIXME: These two seem incorrect.
53-
(define (%latin1->char i)
54-
(integer->char i))
55-
(define (%char->latin1 c)
56-
(char->integer c))
81+
(syntax-case x ()
82+
[(_ (args ...) body ...)
83+
(let-values (((fixed-args opt-args) (split-args #'(args ...))))
84+
(with-syntax (((fixed-args ...) fixed-args)
85+
((opt-args ...) opt-args))
86+
#'(lambda (fixed-args ... . rest)
87+
(let-optionals* rest (opt-args ...) body ...))))])))
5788

58-
(SRFI-23-error->R6RS "(library (srfi :14 char-sets))"
59-
(include/resolve ("srfi" "%3a14") "srfi-14.scm"))
60-
)
89+
(include/resolve ("srfi" "%3a14") "srfi-14.scm")
90+
(include/resolve ("srfi" "%3a14") "srfi-14-base-char-sets.scm")
91+
(include/resolve ("srfi" "%3a14") "srfi-14-char-sets.scm"))

‎%3a14/char-sets/inversion-list-check.scm

Lines changed: 151 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,151 @@
1+
; Part of Scheme 48 1.9. See file COPYING for notices and license.
2+
3+
; Authors: Mike Sperber
4+
5+
(define-test-suite inversion-lists-tests)
6+
7+
(define-test-case creation/membership inversion-lists-tests
8+
(check-that (inversion-list-member? 5 (make-empty-inversion-list 0 1000)) (is-false))
9+
(check (inversion-list-member? 5 (number->inversion-list 0 1000 5)))
10+
(check-that (inversion-list-member? 4 (number->inversion-list 0 1000 5)) (is-false))
11+
(check-that (inversion-list-member? 6 (number->inversion-list 0 1000 5)) (is-false))
12+
(check-that (inversion-list-member? 6 (range->inversion-list 0 1000 500 1000)) (is-false))
13+
(check-that (inversion-list-member? 499 (range->inversion-list 0 1000 500 1000)) (is-false))
14+
(check (inversion-list-member? 500 (range->inversion-list 0 1000 500 1000)))
15+
(check (inversion-list-member? 1000 (range->inversion-list 0 1000 500 1000))))
16+
17+
(define-test-case complement/1 inversion-lists-tests
18+
(check-that
19+
(inversion-list-complement
20+
(inversion-list-complement
21+
(range->inversion-list 0 1000 5 10)))
22+
(is inversion-list=?
23+
(range->inversion-list 0 1000 5 10))))
24+
25+
(define-test-case complement/2 inversion-lists-tests
26+
(check-that
27+
(inversion-list-complement
28+
(inversion-list-complement
29+
(range->inversion-list 0 1000 0 1000)))
30+
(is inversion-list=?
31+
(range->inversion-list 0 1000 0 1000))))
32+
33+
(define-test-case union/1 inversion-lists-tests
34+
(check-that
35+
(inversion-list-union (range->inversion-list 0 1000 5 10)
36+
(range->inversion-list 0 1000 20 30))
37+
(is inversion-list=?
38+
(ranges->inversion-list 0 1000 '(5 . 10) '(20 . 30)))))
39+
40+
(define-test-case union/2 inversion-lists-tests
41+
(check-that
42+
(inversion-list-union (range->inversion-list 0 1000 5 10)
43+
(range->inversion-list 0 1000 7 8))
44+
(is inversion-list=?
45+
(range->inversion-list 0 1000 5 10))))
46+
47+
(define-test-case union/3 inversion-lists-tests
48+
(check-that
49+
(inversion-list-union (range->inversion-list 0 1000 5 10)
50+
(range->inversion-list 0 1000 7 15))
51+
(is inversion-list=?
52+
(range->inversion-list 0 1000 5 15))))
53+
54+
(define-test-case union/4 inversion-lists-tests
55+
(check-that
56+
(inversion-list-union (range->inversion-list 0 1000 500 1000)
57+
(range->inversion-list 0 1000 0 500))
58+
(is inversion-list=?
59+
(range->inversion-list 0 1000 0 1000))))
60+
61+
(define-test-case intersection/1 inversion-lists-tests
62+
(check-that
63+
(inversion-list-intersection (range->inversion-list 0 1000 5 10)
64+
(range->inversion-list 0 1000 20 30))
65+
(is inversion-list=?
66+
(make-empty-inversion-list 0 1000))))
67+
68+
(define-test-case intersection/2 inversion-lists-tests
69+
(check-that
70+
(inversion-list-intersection (range->inversion-list 0 1000 5 10)
71+
(range->inversion-list 0 1000 7 8))
72+
(is inversion-list=?
73+
(range->inversion-list 0 1000 7 8))))
74+
75+
(define-test-case intersection/3 inversion-lists-tests
76+
(check-that
77+
(inversion-list-intersection (range->inversion-list 0 1000 5 10)
78+
(range->inversion-list 0 1000 7 15))
79+
(is inversion-list=?
80+
(range->inversion-list 0 1000 7 10))))
81+
82+
(define-test-case intersection/4 inversion-lists-tests
83+
(check-that
84+
(inversion-list-intersection (range->inversion-list 0 1000 500 1000)
85+
(range->inversion-list 0 1000 0 501))
86+
(is inversion-list=?
87+
(range->inversion-list 0 1000 500 501))))
88+
89+
(define-test-case intersection/5 inversion-lists-tests
90+
(check-that
91+
(inversion-list-intersection (range->inversion-list 0 1000 500 1000)
92+
(range->inversion-list 0 1000 501 505))
93+
(is inversion-list=?
94+
(range->inversion-list 0 1000 501 505))))
95+
96+
(define-test-case adjoin inversion-lists-tests
97+
(check-that
98+
(inversion-list-adjoin (range->inversion-list 0 1000 0 999) 999)
99+
(is inversion-list=?
100+
(range->inversion-list 0 1000 0 1000))))
101+
102+
(define-test-case remove inversion-lists-tests
103+
(check-that
104+
(inversion-list-remove (range->inversion-list 0 1000 0 1000) 999)
105+
(is inversion-list=?
106+
(range->inversion-list 0 1000 0 999))))
107+
108+
(define-test-case size inversion-lists-tests
109+
(check
110+
(inversion-list-size
111+
(ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000)))
112+
=> 510))
113+
114+
(define-test-case copy inversion-lists-tests
115+
(check-that
116+
(inversion-list-copy
117+
(ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000)))
118+
(is inversion-list=?
119+
(ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000)))))
120+
121+
(define-test-case fold/done? inversion-lists-tests
122+
(check
123+
(inversion-list-fold/done?
124+
(lambda (n sum)
125+
(+ n sum))
126+
0
127+
(lambda (sum)
128+
(> sum 250000))
129+
(ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000)))
130+
=>
131+
250781))
132+
133+
(define (i-list-sum i-list)
134+
(let loop ((cursor (inversion-list-cursor i-list))
135+
(sum 0))
136+
(if (inversion-list-cursor-at-end? cursor)
137+
sum
138+
(loop (inversion-list-cursor-next i-list cursor)
139+
(+ (inversion-list-cursor-ref cursor)
140+
sum)))))
141+
142+
(define-test-case cursor inversion-lists-tests
143+
(check
144+
(i-list-sum (ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000)))
145+
=> 374870))
146+
147+
(define-test-case hash inversion-lists-tests
148+
(check-that
149+
(inversion-list-hash (ranges->inversion-list 0 1000 '(5 . 10) '(15 . 20) '(500 . 1000)) 1031)
150+
(opposite (is =
151+
(inversion-list-hash (ranges->inversion-list 0 1000 '(5 . 10) '(500 . 1000)) 1031)))))

0 commit comments

Comments
 (0)