92 lines
3.3 KiB
Scheme
92 lines
3.3 KiB
Scheme
;; -*- mode: scheme; coding: utf-8 -*-
|
|
;; Copyright © 2018 Göran Weinholt <goran@weinholt.se>
|
|
;; SPDX-License-Identifier: (MIT OR BSD-3-Clause OR LicenseRef-LICENSE)
|
|
#!r6rs
|
|
|
|
(library (srfi :14 char-sets)
|
|
(export
|
|
; Predicates & comparison
|
|
char-set? char-set= char-set<= char-set-hash
|
|
; Iterating over character sets
|
|
char-set-cursor char-set-ref char-set-cursor-next end-of-char-set?
|
|
char-set-fold char-set-unfold char-set-unfold!
|
|
char-set-for-each char-set-map
|
|
; Creating character sets
|
|
char-set-copy char-set
|
|
list->char-set string->char-set
|
|
list->char-set! string->char-set!
|
|
char-set-filter ucs-range->char-set
|
|
char-set-filter! ucs-range->char-set!
|
|
(rename (x->char-set ->char-set))
|
|
; Querying character sets
|
|
char-set->list char-set->string
|
|
char-set-size char-set-count char-set-contains?
|
|
char-set-every char-set-any
|
|
; Character-set algebra
|
|
char-set-adjoin char-set-delete
|
|
char-set-adjoin! char-set-delete!
|
|
char-set-complement char-set-union char-set-intersection
|
|
char-set-complement! char-set-union! char-set-intersection!
|
|
char-set-difference char-set-xor char-set-diff+intersection
|
|
char-set-difference! char-set-xor! char-set-diff+intersection!
|
|
; Standard character sets
|
|
char-set:lower-case char-set:upper-case char-set:title-case
|
|
char-set:letter char-set:digit char-set:letter+digit
|
|
char-set:graphic char-set:printing char-set:whitespace
|
|
char-set:iso-control char-set:punctuation char-set:symbol
|
|
char-set:hex-digit char-set:blank char-set:ascii
|
|
char-set:empty char-set:full)
|
|
(import
|
|
(except (rnrs) define-record-type)
|
|
(rnrs mutable-strings)
|
|
(rnrs r5rs)
|
|
(rename (only (srfi :1 lists) partition)
|
|
(partition partition-list))
|
|
(srfi :9 records)
|
|
(srfi private include)
|
|
(srfi private let-opt)
|
|
(srfi :14 char-sets inversion-list))
|
|
|
|
(define-syntax define-record-discloser
|
|
(syntax-rules ()
|
|
((_ type discloser)
|
|
(define dummy #f))))
|
|
|
|
(define (make-immutable! obj)
|
|
#f)
|
|
|
|
(define char->scalar-value char->integer)
|
|
(define scalar-value->char integer->char)
|
|
|
|
(define make-byte-vector make-bytevector)
|
|
(define byte-vector-ref bytevector-u8-ref)
|
|
(define byte-vector-set! bytevector-u8-set!)
|
|
(define byte-vector=? bytevector=?)
|
|
(define copy-bytes! bytevector-copy!)
|
|
(define byte-vector-length bytevector-length)
|
|
|
|
(define (unspecific) (if #f #f))
|
|
|
|
(define-syntax opt-lambda
|
|
(lambda (x)
|
|
(define (split-args args)
|
|
(syntax-case args ()
|
|
[(name . rest)
|
|
(identifier? #'name)
|
|
(let-values (((names opt-args) (split-args #'rest)))
|
|
(values (cons #'name names) opt-args))]
|
|
[(opt-args ...)
|
|
(values '() #'(opt-args ...))]))
|
|
|
|
(syntax-case x ()
|
|
[(_ (args ...) body ...)
|
|
(let-values (((fixed-args opt-args) (split-args #'(args ...))))
|
|
(with-syntax (((fixed-args ...) fixed-args)
|
|
((opt-args ...) opt-args))
|
|
#'(lambda (fixed-args ... . rest)
|
|
(let-optionals* rest (opt-args ...) body ...))))])))
|
|
|
|
(include/resolve ("srfi" "%3a14") "srfi-14.scm")
|
|
(include/resolve ("srfi" "%3a14") "srfi-14-base-char-sets.scm")
|
|
(include/resolve ("srfi" "%3a14") "srfi-14-char-sets.scm"))
|