Remove the old LIST-LIB, STRING-LIB, and CHAR-SET-LIB libraries, now
that the corresponding SRFIs are in the Scheme 48 core. All this hopefully preserving backwards compatibility.
This commit is contained in:
sperber
parent
4b9e07bc44
commit
7f1879b497
|
|
@ -307,7 +307,7 @@
|
|||
(let-optionals args ((delims default-record-delims)
|
||||
(elide? #f)
|
||||
(handle-delim 'trim))
|
||||
(let ((delims (->char-set delims)))
|
||||
(let ((delims (x->char-set delims)))
|
||||
|
||||
(case handle-delim
|
||||
((trim) ; TRIM-delimiter reader.
|
||||
|
|
|
|||
|
|
@ -93,13 +93,13 @@
|
|||
))
|
||||
|
||||
(define-structure ccp-lib ccp-lib-interface
|
||||
(open char-set-lib
|
||||
(open srfi-14
|
||||
ascii
|
||||
defrec-package
|
||||
string-lib
|
||||
srfi-13
|
||||
let-opt
|
||||
receiving
|
||||
list-lib ; EVERY
|
||||
(subset srfi-1 (every fold))
|
||||
error-package
|
||||
scheme)
|
||||
(files ccp)
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@
|
|||
(define-structure char-predicates-lib char-predicates-interface
|
||||
(open error-package ; ERROR
|
||||
scsh-utilities ; DEPRECATED-PROC
|
||||
char-set-lib
|
||||
srfi-14
|
||||
scheme)
|
||||
|
||||
(begin
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,804 +0,0 @@
|
|||
;;; SRFI-14 character-sets library -*- Scheme -*-
|
||||
;;;
|
||||
;;; - Ported from MIT Scheme runtime by Brian D. Carlstrom.
|
||||
;;; - Massively rehacked & extended by Olin Shivers 6/98.
|
||||
;;; - Massively redesigned and rehacked 5/2000 during SRFI process.
|
||||
;;; At this point, the code bears the following relationship to the
|
||||
;;; MIT Scheme code: "This is my grandfather's axe. My father replaced
|
||||
;;; the head, and I have replaced the handle." Nonetheless, we preserve
|
||||
;;; the MIT Scheme copyright:
|
||||
;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology
|
||||
;;; The MIT Scheme license is a "free software" license. See the end of
|
||||
;;; this file for the tedious details.
|
||||
|
||||
;;; Exports:
|
||||
;;; char-set? char-set= char-set<=
|
||||
;;; char-set-hash
|
||||
;;; 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
|
||||
;;; char-set-copy char-set
|
||||
;;;
|
||||
;;; list->char-set string->char-set
|
||||
;;; list->char-set! string->char-set!
|
||||
;;;
|
||||
;;; filterchar-set ucs-range->char-set ->char-set
|
||||
;;; filterchar-set! ucs-range->char-set!
|
||||
;;;
|
||||
;;; char-set->list char-set->string
|
||||
;;;
|
||||
;;; char-set-size char-set-count char-set-contains?
|
||||
;;; char-set-every char-set-any
|
||||
;;;
|
||||
;;; 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!
|
||||
;;;
|
||||
;;; 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
|
||||
|
||||
;;; Imports
|
||||
;;; This code has the following non-R5RS dependencies:
|
||||
;;; - ERROR
|
||||
;;; - %LATIN1->CHAR %CHAR->LATIN1
|
||||
;;; - LET-OPTIONALS* and :OPTIONAL macros for parsing, checking & defaulting
|
||||
;;; optional arguments from rest lists.
|
||||
;;; - BITWISE-AND for CHAR-SET-HASH
|
||||
;;; - The SRFI-19 DEFINE-RECORD-TYPE record macro
|
||||
;;; - A simple CHECK-ARG procedure:
|
||||
;;; (lambda (pred val caller) (if (not (pred val)) (error val caller)))
|
||||
|
||||
;;; This is simple code, not great code. Char sets are represented as 256-char
|
||||
;;; strings. If char I is ASCII/Latin-1 0, then it isn't in the set; if char I
|
||||
;;; is ASCII/Latin-1 1, then it is in the set.
|
||||
;;; - Should be rewritten to use bit strings or byte vecs.
|
||||
;;; - Is Latin-1 specific. Would certainly have to be rewritten for Unicode.
|
||||
|
||||
;;; See the end of the file for porting and performance-tuning notes.
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-record-type :char-set
|
||||
(make-char-set s)
|
||||
char-set?
|
||||
(s char-set:s))
|
||||
|
||||
|
||||
(define (%string-copy s) (substring s 0 (string-length s)))
|
||||
|
||||
;;; Parse, type-check & default a final optional BASE-CS parameter from
|
||||
;;; a rest argument. Return a *fresh copy* of the underlying string.
|
||||
;;; The default is the empty set. The PROC argument is to help us
|
||||
;;; generate informative error exceptions.
|
||||
|
||||
(define (%default-base maybe-base proc)
|
||||
(if (pair? maybe-base)
|
||||
(let ((bcs (car maybe-base))
|
||||
(tail (cdr maybe-base)))
|
||||
(if (null? tail)
|
||||
(if (char-set? bcs) (%string-copy (char-set:s bcs))
|
||||
(error "BASE-CS parameter not a char-set" proc bcs))
|
||||
(error "Expected final base char set -- too many parameters"
|
||||
proc maybe-base)))
|
||||
(make-string 256 (%latin1->char 0))))
|
||||
|
||||
;;; If CS is really a char-set, do CHAR-SET:S, otw report an error msg on
|
||||
;;; behalf of our caller, PROC. This procedure exists basically to provide
|
||||
;;; explicit error-checking & reporting.
|
||||
|
||||
(define (%char-set:s/check cs proc)
|
||||
(let lp ((cs cs))
|
||||
(if (char-set? cs) (char-set:s cs)
|
||||
(lp (error "Not a char-set" cs proc)))))
|
||||
|
||||
|
||||
|
||||
;;; These internal functions hide a lot of the dependency on the
|
||||
;;; underlying string representation of char sets. They should be
|
||||
;;; inlined if possible.
|
||||
|
||||
(define (si=0? s i) (zero? (%char->latin1 (string-ref s i))))
|
||||
(define (si=1? s i) (not (si=0? s i)))
|
||||
(define c0 (%latin1->char 0))
|
||||
(define c1 (%latin1->char 1))
|
||||
(define (si s i) (%char->latin1 (string-ref s i)))
|
||||
(define (%set0! s i) (string-set! s i c0))
|
||||
(define (%set1! s i) (string-set! s i c1))
|
||||
|
||||
;;; These do various "s[i] := s[i] op val" operations -- see
|
||||
;;; %CHAR-SET-ALGEBRA. They are used to implement the various
|
||||
;;; set-algebra procedures.
|
||||
(define (setv! s i v) (string-set! s i (%latin1->char v))) ; SET to a Value.
|
||||
(define (%not! s i v) (setv! s i (- 1 v)))
|
||||
(define (%and! s i v) (if (zero? v) (%set0! s i)))
|
||||
(define (%or! s i v) (if (not (zero? v)) (%set1! s i)))
|
||||
(define (%minus! s i v) (if (not (zero? v)) (%set0! s i)))
|
||||
(define (%xor! s i v) (if (not (zero? v)) (setv! s i (- 1 (si s i)))))
|
||||
|
||||
|
||||
(define (char-set-copy cs)
|
||||
(make-char-set (%string-copy (%char-set:s/check cs char-set-copy))))
|
||||
|
||||
(define (char-set= . rest)
|
||||
(or (null? rest)
|
||||
(let* ((cs1 (car rest))
|
||||
(rest (cdr rest))
|
||||
(s1 (%char-set:s/check cs1 char-set=)))
|
||||
(let lp ((rest rest))
|
||||
(or (not (pair? rest))
|
||||
(and (string=? s1 (%char-set:s/check (car rest) char-set=))
|
||||
(lp (cdr rest))))))))
|
||||
|
||||
(define (char-set<= . rest)
|
||||
(or (null? rest)
|
||||
(let ((cs1 (car rest))
|
||||
(rest (cdr rest)))
|
||||
(let lp ((s1 (%char-set:s/check cs1 char-set<=)) (rest rest))
|
||||
(or (not (pair? rest))
|
||||
(let ((s2 (%char-set:s/check (car rest) char-set<=))
|
||||
(rest (cdr rest)))
|
||||
(if (eq? s1 s2) (lp s2 rest) ; Fast path
|
||||
(let lp2 ((i 255)) ; Real test
|
||||
(if (< i 0) (lp s2 rest)
|
||||
(and (<= (si s1 i) (si s2 i))
|
||||
(lp2 (- i 1))))))))))))
|
||||
|
||||
;;; Hash
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND, with sleaze thrown in
|
||||
;;; to keep the intermediate values small. (We do the calculation with just
|
||||
;;; enough bits to represent BOUND, masking off high bits at each step in
|
||||
;;; calculation. If this screws up any important properties of the hash
|
||||
;;; function I'd like to hear about it. -Olin)
|
||||
;;;
|
||||
;;; If you keep BOUND small enough, the intermediate calculations will
|
||||
;;; always be fixnums. How small is dependent on the underlying Scheme system;
|
||||
;;; we use a default BOUND of 2^22 = 4194304, which should hack it in
|
||||
;;; Schemes that give you at least 29 signed bits for fixnums. The core
|
||||
;;; calculation that you don't want to overflow is, worst case,
|
||||
;;; (+ 65535 (* 37 (- bound 1)))
|
||||
;;; where 65535 is the max character code. Choose the default BOUND to be the
|
||||
;;; biggest power of two that won't cause this expression to fixnum overflow,
|
||||
;;; and everything will be copacetic.
|
||||
|
||||
(define (char-set-hash cs . maybe-bound)
|
||||
(let* ((bound (:optional maybe-bound 4194304 (lambda (n) (and (integer? n)
|
||||
(exact? n)
|
||||
(<= 0 n)))))
|
||||
(bound (if (zero? bound) 4194304 bound)) ; 0 means default.
|
||||
(s (%char-set:s/check cs char-set-hash))
|
||||
;; Compute a 111...1 mask that will cover BOUND-1:
|
||||
(mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh?
|
||||
(if (>= i bound) (- i 1) (lp (+ i i))))))
|
||||
|
||||
(let lp ((i 255) (ans 0))
|
||||
(if (< i 0) (modulo ans bound)
|
||||
(lp (- i 1)
|
||||
(if (si=0? s i) ans
|
||||
(bitwise-and mask (+ (* 37 ans) i))))))))
|
||||
|
||||
|
||||
(define (char-set-contains? cs char)
|
||||
(si=1? (%char-set:s/check cs char-set-contains?)
|
||||
(%char->latin1 (check-arg char? char char-set-contains?))))
|
||||
|
||||
(define (char-set-size cs)
|
||||
(let ((s (%char-set:s/check cs char-set-size)))
|
||||
(let lp ((i 255) (size 0))
|
||||
(if (< i 0) size
|
||||
(lp (- i 1) (+ size (si s i)))))))
|
||||
|
||||
(define (char-set-count pred cset)
|
||||
(check-arg procedure? pred char-set-count)
|
||||
(let ((s (%char-set:s/check cset char-set-count)))
|
||||
(let lp ((i 255) (count 0))
|
||||
(if (< i 0) count
|
||||
(lp (- i 1)
|
||||
(if (and (si=1? s i) (pred (%latin1->char i)))
|
||||
(+ count 1)
|
||||
count))))))
|
||||
|
||||
|
||||
;;; -- Adjoin & delete
|
||||
|
||||
(define (%set-char-set set proc cs chars)
|
||||
(let ((s (%string-copy (%char-set:s/check cs proc))))
|
||||
(for-each (lambda (c) (set s (%char->latin1 c)))
|
||||
chars)
|
||||
(make-char-set s)))
|
||||
|
||||
(define (%set-char-set! set proc cs chars)
|
||||
(let ((s (%char-set:s/check cs proc)))
|
||||
(for-each (lambda (c) (set s (%char->latin1 c)))
|
||||
chars))
|
||||
cs)
|
||||
|
||||
(define (char-set-adjoin cs . chars)
|
||||
(%set-char-set %set1! char-set-adjoin cs chars))
|
||||
(define (char-set-adjoin! cs . chars)
|
||||
(%set-char-set! %set1! char-set-adjoin! cs chars))
|
||||
(define (char-set-delete cs . chars)
|
||||
(%set-char-set %set0! char-set-delete cs chars))
|
||||
(define (char-set-delete! cs . chars)
|
||||
(%set-char-set! %set0! char-set-delete! cs chars))
|
||||
|
||||
|
||||
;;; Cursors
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Simple implementation. A cursors is an integer index into the
|
||||
;;; mark vector, and -1 for the end-of-char-set cursor.
|
||||
;;;
|
||||
;;; If we represented char sets as a bit set, we could do the following
|
||||
;;; trick to pick the lowest bit out of the set:
|
||||
;;; (count-bits (xor (- cset 1) cset))
|
||||
;;; (But first mask out the bits already scanned by the cursor first.)
|
||||
|
||||
(define (char-set-cursor cset)
|
||||
(%char-set-cursor-next cset 256 char-set-cursor))
|
||||
|
||||
(define (end-of-char-set? cursor) (< cursor 0))
|
||||
|
||||
(define (char-set-ref cset cursor) (%latin1->char cursor))
|
||||
|
||||
(define (char-set-cursor-next cset cursor)
|
||||
(check-arg (lambda (i) (and (integer? i) (exact? i) (<= 0 i 255))) cursor
|
||||
char-set-cursor-next)
|
||||
(%char-set-cursor-next cset cursor char-set-cursor-next))
|
||||
|
||||
(define (%char-set-cursor-next cset cursor proc) ; Internal
|
||||
(let ((s (%char-set:s/check cset proc)))
|
||||
(let lp ((cur cursor))
|
||||
(let ((cur (- cur 1)))
|
||||
(if (or (< cur 0) (si=1? s cur)) cur
|
||||
(lp cur))))))
|
||||
|
||||
|
||||
;;; -- for-each map fold unfold every any
|
||||
|
||||
(define (char-set-for-each proc cs)
|
||||
(check-arg procedure? proc char-set-for-each)
|
||||
(let ((s (%char-set:s/check cs char-set-for-each)))
|
||||
(let lp ((i 255))
|
||||
(cond ((>= i 0)
|
||||
(if (si=1? s i) (proc (%latin1->char i)))
|
||||
(lp (- i 1)))))))
|
||||
|
||||
(define (char-set-map proc cs)
|
||||
(check-arg procedure? proc char-set-map)
|
||||
(let ((s (%char-set:s/check cs char-set-map))
|
||||
(ans (make-string 256 c0)))
|
||||
(let lp ((i 255))
|
||||
(cond ((>= i 0)
|
||||
(if (si=1? s i)
|
||||
(%set1! ans (%char->latin1 (proc (%latin1->char i)))))
|
||||
(lp (- i 1)))))
|
||||
(make-char-set ans)))
|
||||
|
||||
(define (char-set-fold kons knil cs)
|
||||
(check-arg procedure? kons char-set-fold)
|
||||
(let ((s (%char-set:s/check cs char-set-fold)))
|
||||
(let lp ((i 255) (ans knil))
|
||||
(if (< i 0) ans
|
||||
(lp (- i 1)
|
||||
(if (si=0? s i) ans
|
||||
(kons (%latin1->char i) ans)))))))
|
||||
|
||||
(define (char-set-every pred cs)
|
||||
(check-arg procedure? pred char-set-every)
|
||||
(let ((s (%char-set:s/check cs char-set-every)))
|
||||
(let lp ((i 255))
|
||||
(or (< i 0)
|
||||
(and (or (si=0? s i) (pred (%latin1->char i)))
|
||||
(lp (- i 1)))))))
|
||||
|
||||
(define (char-set-any pred cs)
|
||||
(check-arg procedure? pred char-set-any)
|
||||
(let ((s (%char-set:s/check cs char-set-any)))
|
||||
(let lp ((i 255))
|
||||
(and (>= i 0)
|
||||
(or (and (si=1? s i) (pred (%latin1->char i)))
|
||||
(lp (- i 1)))))))
|
||||
|
||||
|
||||
(define (%char-set-unfold! proc p f g s seed)
|
||||
(check-arg procedure? p proc)
|
||||
(check-arg procedure? f proc)
|
||||
(check-arg procedure? g proc)
|
||||
(let lp ((seed seed))
|
||||
(cond ((not (p seed)) ; P says we are done.
|
||||
(%set1! s (%char->latin1 (f seed))) ; Add (F SEED) to set.
|
||||
(lp (g seed)))))) ; Loop on (G SEED).
|
||||
|
||||
(define (char-set-unfold p f g seed . maybe-base)
|
||||
(let ((bs (%default-base maybe-base char-set-unfold)))
|
||||
(%char-set-unfold! char-set-unfold p f g bs seed)
|
||||
(make-char-set bs)))
|
||||
|
||||
(define (char-set-unfold! p f g seed base-cset)
|
||||
(%char-set-unfold! char-set-unfold! p f g
|
||||
(%char-set:s/check base-cset char-set-unfold!)
|
||||
seed)
|
||||
base-cset)
|
||||
|
||||
|
||||
|
||||
;;; list <--> char-set
|
||||
|
||||
(define (%list->char-set! chars s)
|
||||
(for-each (lambda (char) (%set1! s (%char->latin1 char)))
|
||||
chars))
|
||||
|
||||
(define (char-set . chars)
|
||||
(let ((s (make-string 256 c0)))
|
||||
(%list->char-set! chars s)
|
||||
(make-char-set s)))
|
||||
|
||||
(define (list->char-set chars . maybe-base)
|
||||
(let ((bs (%default-base maybe-base list->char-set)))
|
||||
(%list->char-set! chars bs)
|
||||
(make-char-set bs)))
|
||||
|
||||
(define (list->char-set! chars base-cs)
|
||||
(%list->char-set! chars (%char-set:s/check base-cs list->char-set!))
|
||||
base-cs)
|
||||
|
||||
|
||||
(define (char-set->list cs)
|
||||
(let ((s (%char-set:s/check cs char-set->list)))
|
||||
(let lp ((i 255) (ans '()))
|
||||
(if (< i 0) ans
|
||||
(lp (- i 1)
|
||||
(if (si=0? s i) ans
|
||||
(cons (%latin1->char i) ans)))))))
|
||||
|
||||
|
||||
|
||||
;;; string <--> char-set
|
||||
|
||||
(define (%string->char-set! str bs proc)
|
||||
(check-arg string? str proc)
|
||||
(do ((i (- (string-length str) 1) (- i 1)))
|
||||
((< i 0))
|
||||
(%set1! bs (%char->latin1 (string-ref str i)))))
|
||||
|
||||
(define (string->char-set str . maybe-base)
|
||||
(let ((bs (%default-base maybe-base string->char-set)))
|
||||
(%string->char-set! str bs string->char-set)
|
||||
(make-char-set bs)))
|
||||
|
||||
(define (string->char-set! str base-cs)
|
||||
(%string->char-set! str (%char-set:s/check base-cs string->char-set!)
|
||||
string->char-set!)
|
||||
base-cs)
|
||||
|
||||
|
||||
(define (char-set->string cs)
|
||||
(let* ((s (%char-set:s/check cs char-set->string))
|
||||
(ans (make-string (char-set-size cs))))
|
||||
(let lp ((i 255) (j 0))
|
||||
(if (< i 0) ans
|
||||
(let ((j (if (si=0? s i) j
|
||||
(begin (string-set! ans j (%latin1->char i))
|
||||
(+ j 1)))))
|
||||
(lp (- i 1) j))))))
|
||||
|
||||
|
||||
;;; -- UCS-range -> char-set
|
||||
|
||||
(define (%ucs-range->char-set! lower upper error? bs proc)
|
||||
(check-arg (lambda (x) (and (integer? x) (exact? x) (<= 0 x))) lower proc)
|
||||
(check-arg (lambda (x) (and (integer? x) (exact? x) (<= lower x))) upper proc)
|
||||
|
||||
(if (and (< lower upper) (< 256 upper) error?)
|
||||
(error "Requested UCS range contains unavailable characters -- this implementation only supports Latin-1"
|
||||
proc lower upper))
|
||||
|
||||
(let lp ((i (- (min upper 256) 1)))
|
||||
(cond ((<= lower i) (%set1! bs i) (lp (- i 1))))))
|
||||
|
||||
(define (ucs-range->char-set lower upper . rest)
|
||||
(let-optionals* rest ((error? #f) rest)
|
||||
(let ((bs (%default-base rest ucs-range->char-set)))
|
||||
(%ucs-range->char-set! lower upper error? bs ucs-range->char-set)
|
||||
(make-char-set bs))))
|
||||
|
||||
(define (ucs-range->char-set! lower upper error? base-cs)
|
||||
(%ucs-range->char-set! lower upper error?
|
||||
(%char-set:s/check base-cs ucs-range->char-set!)
|
||||
ucs-range->char-set)
|
||||
base-cs)
|
||||
|
||||
|
||||
;;; -- predicate -> char-set
|
||||
|
||||
(define (%char-set-filter! pred ds bs proc)
|
||||
(check-arg procedure? pred proc)
|
||||
(let lp ((i 255))
|
||||
(cond ((>= i 0)
|
||||
(if (and (si=1? ds i) (pred (%latin1->char i)))
|
||||
(%set1! bs i))
|
||||
(lp (- i 1))))))
|
||||
|
||||
(define (char-set-filter predicate domain . maybe-base)
|
||||
(let ((bs (%default-base maybe-base char-set-filter)))
|
||||
(%char-set-filter! predicate
|
||||
(%char-set:s/check domain char-set-filter!)
|
||||
bs
|
||||
char-set-filter)
|
||||
(make-char-set bs)))
|
||||
|
||||
(define (char-set-filter! predicate domain base-cs)
|
||||
(%char-set-filter! predicate
|
||||
(%char-set:s/check domain char-set-filter!)
|
||||
(%char-set:s/check base-cs char-set-filter!)
|
||||
char-set-filter!)
|
||||
base-cs)
|
||||
|
||||
|
||||
;;; {string, char, char-set, char predicate} -> char-set
|
||||
|
||||
(define (->char-set x)
|
||||
(cond ((char-set? x) x)
|
||||
((string? x) (string->char-set x))
|
||||
((char? x) (char-set x))
|
||||
(else (error "->char-set: Not a charset, string or char." x))))
|
||||
|
||||
|
||||
|
||||
;;; Set algebra
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; The exported ! procs are "linear update" -- allowed, but not required, to
|
||||
;;; side-effect their first argument when computing their result. In other
|
||||
;;; words, you must use them as if they were completely functional, just like
|
||||
;;; their non-! counterparts, and you must additionally ensure that their
|
||||
;;; first arguments are "dead" at the point of call. In return, we promise a
|
||||
;;; more efficient result, plus allowing you to always assume char-sets are
|
||||
;;; unchangeable values.
|
||||
|
||||
;;; Apply P to each index and its char code in S: (P I VAL).
|
||||
;;; Used by the set-algebra ops.
|
||||
|
||||
(define (%string-iter p s)
|
||||
(let lp ((i (- (string-length s) 1)))
|
||||
(cond ((>= i 0)
|
||||
(p i (%char->latin1 (string-ref s i)))
|
||||
(lp (- i 1))))))
|
||||
|
||||
;;; String S represents some initial char-set. (OP s i val) does some
|
||||
;;; kind of s[i] := s[i] op val update. Do
|
||||
;;; S := S OP CSETi
|
||||
;;; for all the char-sets in the list CSETS. The n-ary set-algebra ops
|
||||
;;; all use this internal proc.
|
||||
|
||||
(define (%char-set-algebra s csets op proc)
|
||||
(for-each (lambda (cset)
|
||||
(let ((s2 (%char-set:s/check cset proc)))
|
||||
(let lp ((i 255))
|
||||
(cond ((>= i 0)
|
||||
(op s i (si s2 i))
|
||||
(lp (- i 1)))))))
|
||||
csets))
|
||||
|
||||
|
||||
;;; -- Complement
|
||||
|
||||
(define (char-set-complement cs)
|
||||
(let ((s (%char-set:s/check cs char-set-complement))
|
||||
(ans (make-string 256)))
|
||||
(%string-iter (lambda (i v) (%not! ans i v)) s)
|
||||
(make-char-set ans)))
|
||||
|
||||
(define (char-set-complement! cset)
|
||||
(let ((s (%char-set:s/check cset char-set-complement!)))
|
||||
(%string-iter (lambda (i v) (%not! s i v)) s))
|
||||
cset)
|
||||
|
||||
|
||||
;;; -- Union
|
||||
|
||||
(define (char-set-union! cset1 . csets)
|
||||
(%char-set-algebra (%char-set:s/check cset1 char-set-union!)
|
||||
csets %or! char-set-union!)
|
||||
cset1)
|
||||
|
||||
(define (char-set-union . csets)
|
||||
(if (pair? csets)
|
||||
(let ((s (%string-copy (%char-set:s/check (car csets) char-set-union))))
|
||||
(%char-set-algebra s (cdr csets) %or! char-set-union)
|
||||
(make-char-set s))
|
||||
(char-set-copy char-set:empty)))
|
||||
|
||||
|
||||
;;; -- Intersection
|
||||
|
||||
(define (char-set-intersection! cset1 . csets)
|
||||
(%char-set-algebra (%char-set:s/check cset1 char-set-intersection!)
|
||||
csets %and! char-set-intersection!)
|
||||
cset1)
|
||||
|
||||
(define (char-set-intersection . csets)
|
||||
(if (pair? csets)
|
||||
(let ((s (%string-copy (%char-set:s/check (car csets) char-set-intersection))))
|
||||
(%char-set-algebra s (cdr csets) %and! char-set-intersection)
|
||||
(make-char-set s))
|
||||
(char-set-copy char-set:full)))
|
||||
|
||||
|
||||
;;; -- Difference
|
||||
|
||||
(define (char-set-difference! cset1 . csets)
|
||||
(%char-set-algebra (%char-set:s/check cset1 char-set-difference!)
|
||||
csets %minus! char-set-difference!)
|
||||
cset1)
|
||||
|
||||
(define (char-set-difference cs1 . csets)
|
||||
(if (pair? csets)
|
||||
(let ((s (%string-copy (%char-set:s/check cs1 char-set-difference))))
|
||||
(%char-set-algebra s csets %minus! char-set-difference)
|
||||
(make-char-set s))
|
||||
(char-set-copy cs1)))
|
||||
|
||||
|
||||
;;; -- Xor
|
||||
|
||||
(define (char-set-xor! cset1 . csets)
|
||||
(%char-set-algebra (%char-set:s/check cset1 char-set-xor!)
|
||||
csets %xor! char-set-xor!)
|
||||
cset1)
|
||||
|
||||
(define (char-set-xor . csets)
|
||||
(if (pair? csets)
|
||||
(let ((s (%string-copy (%char-set:s/check (car csets) char-set-xor))))
|
||||
(%char-set-algebra s (cdr csets) %xor! char-set-xor)
|
||||
(make-char-set s))
|
||||
(char-set-copy char-set:empty)))
|
||||
|
||||
|
||||
;;; -- Difference & intersection
|
||||
|
||||
(define (%char-set-diff+intersection! diff int csets proc)
|
||||
(for-each (lambda (cs)
|
||||
(%string-iter (lambda (i v)
|
||||
(if (not (zero? v))
|
||||
(cond ((si=1? diff i)
|
||||
(%set0! diff i)
|
||||
(%set1! int i)))))
|
||||
(%char-set:s/check cs proc)))
|
||||
csets))
|
||||
|
||||
(define (char-set-diff+intersection! cs1 cs2 . csets)
|
||||
(let ((s1 (%char-set:s/check cs1 char-set-diff+intersection!))
|
||||
(s2 (%char-set:s/check cs2 char-set-diff+intersection!)))
|
||||
(%string-iter (lambda (i v) (if (zero? v)
|
||||
(%set0! s2 i)
|
||||
(if (si=1? s2 i) (%set0! s1 i))))
|
||||
s1)
|
||||
(%char-set-diff+intersection! s1 s2 csets char-set-diff+intersection!))
|
||||
(values cs1 cs2))
|
||||
|
||||
(define (char-set-diff+intersection cs1 . csets)
|
||||
(let ((diff (string-copy (%char-set:s/check cs1 char-set-diff+intersection)))
|
||||
(int (make-string 256 c0)))
|
||||
(%char-set-diff+intersection! diff int csets char-set-diff+intersection)
|
||||
(values (make-char-set diff) (make-char-set int))))
|
||||
|
||||
|
||||
;;;; System character sets
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; These definitions are for Latin-1.
|
||||
;;;
|
||||
;;; If your Scheme implementation allows you to mark the underlying strings
|
||||
;;; as immutable, you should do so -- it would be very, very bad if a client's
|
||||
;;; buggy code corrupted these constants.
|
||||
|
||||
(define char-set:empty (char-set))
|
||||
(define char-set:full (char-set-complement char-set:empty))
|
||||
|
||||
(define char-set:lower-case
|
||||
(let* ((a-z (ucs-range->char-set #x61 #x7B))
|
||||
(latin1 (ucs-range->char-set! #xdf #xf7 #t a-z))
|
||||
(latin2 (ucs-range->char-set! #xf8 #x100 #t latin1)))
|
||||
(char-set-adjoin! latin2 (%latin1->char #xb5))))
|
||||
|
||||
(define char-set:upper-case
|
||||
(let ((A-Z (ucs-range->char-set #x41 #x5B)))
|
||||
;; Add in the Latin-1 upper-case chars.
|
||||
(ucs-range->char-set! #xd8 #xdf #t
|
||||
(ucs-range->char-set! #xc0 #xd7 #t A-Z))))
|
||||
|
||||
(define char-set:title-case char-set:empty)
|
||||
|
||||
(define char-set:letter
|
||||
(let ((u/l (char-set-union char-set:upper-case char-set:lower-case)))
|
||||
(char-set-adjoin! u/l
|
||||
(%latin1->char #xaa) ; FEMININE ORDINAL INDICATOR
|
||||
(%latin1->char #xba)))) ; MASCULINE ORDINAL INDICATOR
|
||||
|
||||
(define char-set:digit (string->char-set "0123456789"))
|
||||
(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF"))
|
||||
|
||||
(define char-set:letter+digit
|
||||
(char-set-union char-set:letter char-set:digit))
|
||||
|
||||
(define char-set:punctuation
|
||||
(let ((ascii (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}"))
|
||||
(latin-1-chars (map %latin1->char '(#xA1 ; INVERTED EXCLAMATION MARK
|
||||
#xAB ; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
|
||||
#xAD ; SOFT HYPHEN
|
||||
#xB7 ; MIDDLE DOT
|
||||
#xBB ; RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
|
||||
#xBF)))) ; INVERTED QUESTION MARK
|
||||
(list->char-set! latin-1-chars ascii)))
|
||||
|
||||
(define char-set:symbol
|
||||
(let ((ascii (string->char-set "$+<=>^`|~"))
|
||||
(latin-1-chars (map %latin1->char '(#x00A2 ; CENT SIGN
|
||||
#x00A3 ; POUND SIGN
|
||||
#x00A4 ; CURRENCY SIGN
|
||||
#x00A5 ; YEN SIGN
|
||||
#x00A6 ; BROKEN BAR
|
||||
#x00A7 ; SECTION SIGN
|
||||
#x00A8 ; DIAERESIS
|
||||
#x00A9 ; COPYRIGHT SIGN
|
||||
#x00AC ; NOT SIGN
|
||||
#x00AE ; REGISTERED SIGN
|
||||
#x00AF ; MACRON
|
||||
#x00B0 ; DEGREE SIGN
|
||||
#x00B1 ; PLUS-MINUS SIGN
|
||||
#x00B4 ; ACUTE ACCENT
|
||||
#x00B6 ; PILCROW SIGN
|
||||
#x00B8 ; CEDILLA
|
||||
#x00D7 ; MULTIPLICATION SIGN
|
||||
#x00F7)))) ; DIVISION SIGN
|
||||
(list->char-set! latin-1-chars ascii)))
|
||||
|
||||
|
||||
(define char-set:graphic
|
||||
(char-set-union char-set:letter+digit char-set:punctuation char-set:symbol))
|
||||
|
||||
(define char-set:whitespace
|
||||
(list->char-set (map %latin1->char '(#x09 ; HORIZONTAL TABULATION
|
||||
#x0A ; LINE FEED
|
||||
#x0B ; VERTICAL TABULATION
|
||||
#x0C ; FORM FEED
|
||||
#x0D ; CARRIAGE RETURN
|
||||
#x20 ; SPACE
|
||||
#xA0))))
|
||||
|
||||
(define char-set:printing (char-set-union char-set:whitespace char-set:graphic)) ; NO-BREAK SPACE
|
||||
|
||||
(define char-set:blank
|
||||
(list->char-set (map %latin1->char '(#x09 ; HORIZONTAL TABULATION
|
||||
#x20 ; SPACE
|
||||
#xA0)))) ; NO-BREAK SPACE
|
||||
|
||||
|
||||
(define char-set:iso-control
|
||||
(ucs-range->char-set! #x7F #xA0 #t (ucs-range->char-set 0 32)))
|
||||
|
||||
(define char-set:ascii (ucs-range->char-set 0 128))
|
||||
|
||||
|
||||
;;; Porting & performance-tuning notes
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; See the section at the beginning of this file on external dependencies.
|
||||
;;;
|
||||
;;; First and foremost, rewrite this code to use bit vectors of some sort.
|
||||
;;; This will give big speedup and memory savings.
|
||||
;;;
|
||||
;;; - LET-OPTIONALS* macro.
|
||||
;;; This is only used once. You can rewrite the use, port the hairy macro
|
||||
;;; definition (which is implemented using a Clinger-Rees low-level
|
||||
;;; explicit-renaming macro system), or port the simple, high-level
|
||||
;;; definition, which is less efficient.
|
||||
;;;
|
||||
;;; - :OPTIONAL macro
|
||||
;;; Very simply defined using an R5RS high-level macro.
|
||||
;;;
|
||||
;;; Implementations that can arrange for the base char sets to be immutable
|
||||
;;; should do so. (E.g., Scheme 48 allows one to mark a string as immutable,
|
||||
;;; which can be used to protect the underlying strings.) It would be very,
|
||||
;;; very bad if a client's buggy code corrupted these constants.
|
||||
;;;
|
||||
;;; There is a fair amount of argument checking. This is, strictly speaking,
|
||||
;;; unnecessary -- the actual body of the procedures will blow up if an
|
||||
;;; illegal value is passed in. However, the error message will not be as good
|
||||
;;; as if the error were caught at the "higher level." Also, a very, very
|
||||
;;; smart Scheme compiler may be able to exploit having the type checks done
|
||||
;;; early, so that the actual body of the procedures can assume proper values.
|
||||
;;; This isn't likely; this kind of compiler technology isn't common any
|
||||
;;; longer.
|
||||
;;;
|
||||
;;; The overhead of optional-argument parsing is irritating. The optional
|
||||
;;; arguments must be consed into a rest list on entry, and then parsed out.
|
||||
;;; Function call should be a matter of a few register moves and a jump; it
|
||||
;;; should not involve heap allocation! Your Scheme system may have a superior
|
||||
;;; non-R5RS optional-argument system that can eliminate this overhead. If so,
|
||||
;;; then this is a prime candidate for optimising these procedures,
|
||||
;;; *especially* the many optional BASE-CS parameters.
|
||||
;;;
|
||||
;;; Note that optional arguments are also a barrier to procedure integration.
|
||||
;;; If your Scheme system permits you to specify alternate entry points
|
||||
;;; for a call when the number of optional arguments is known in a manner
|
||||
;;; that enables inlining/integration, this can provide performance
|
||||
;;; improvements.
|
||||
;;;
|
||||
;;; There is enough *explicit* error checking that *all* internal operations
|
||||
;;; should *never* produce a type or index-range error. Period. Feel like
|
||||
;;; living dangerously? *Big* performance win to be had by replacing string
|
||||
;;; and record-field accessors and setters with unsafe equivalents in the
|
||||
;;; code. Similarly, fixnum-specific operators can speed up the arithmetic
|
||||
;;; done on the index values in the inner loops. The only arguments that are
|
||||
;;; not completely error checked are
|
||||
;;; - string lists (complete checking requires time proportional to the
|
||||
;;; length of the list)
|
||||
;;; - procedure arguments, such as char->char maps & predicates.
|
||||
;;; There is no way to check the range & domain of procedures in Scheme.
|
||||
;;; Procedures that take these parameters cannot fully check their
|
||||
;;; arguments. But all other types to all other procedures are fully
|
||||
;;; checked.
|
||||
;;;
|
||||
;;; This does open up the alternate possibility of simply *removing* these
|
||||
;;; checks, and letting the safe primitives raise the errors. On a dumb
|
||||
;;; Scheme system, this would provide speed (by eliminating the redundant
|
||||
;;; error checks) at the cost of error-message clarity.
|
||||
;;;
|
||||
;;; In an interpreted Scheme, some of these procedures, or the internal
|
||||
;;; routines with % prefixes, are excellent candidates for being rewritten
|
||||
;;; in C.
|
||||
;;;
|
||||
;;; It would also be nice to have the ability to mark some of these
|
||||
;;; routines as candidates for inlining/integration.
|
||||
;;;
|
||||
;;; See the comments preceding the hash function code for notes on tuning
|
||||
;;; the default bound so that the code never overflows your implementation's
|
||||
;;; fixnum size into bignum calculation.
|
||||
;;;
|
||||
;;; All the %-prefixed routines in this source code are written
|
||||
;;; to be called internally to this library. They do *not* perform
|
||||
;;; friendly error checks on the inputs; they assume everything is
|
||||
;;; proper. They also do not take optional arguments. These two properties
|
||||
;;; save calling overhead and enable procedure integration -- but they
|
||||
;;; are not appropriate for exported routines.
|
||||
|
||||
;;; Copyright notice
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology
|
||||
;;;
|
||||
;;; This material was developed by the Scheme project at the Massachusetts
|
||||
;;; Institute of Technology, Department of Electrical Engineering and
|
||||
;;; Computer Science. Permission to copy and modify this software, to
|
||||
;;; redistribute either the original software or a modified version, and
|
||||
;;; to use this software for any purpose is granted, subject to the
|
||||
;;; following restrictions and understandings.
|
||||
;;;
|
||||
;;; 1. Any copy made of this software must include this copyright notice
|
||||
;;; in full.
|
||||
;;;
|
||||
;;; 2. Users of this software agree to make their best efforts (a) to
|
||||
;;; return to the MIT Scheme project any improvements or extensions that
|
||||
;;; they make, so that these may be included in future releases; and (b)
|
||||
;;; to inform MIT of noteworthy uses of this software.
|
||||
;;;
|
||||
;;; 3. All materials developed as a consequence of the use of this
|
||||
;;; software shall duly acknowledge such use, in accordance with the usual
|
||||
;;; standards of acknowledging credit in academic research.
|
||||
;;;
|
||||
;;; 4. MIT has made no warrantee or representation that the operation of
|
||||
;;; this software will be error-free, and MIT is under no obligation to
|
||||
;;; provide any services, by way of maintenance, update, or otherwise.
|
||||
;;;
|
||||
;;; 5. In conjunction with products arising from the use of this material,
|
||||
;;; there shall be no use of the name of the Massachusetts Institute of
|
||||
;;; Technology nor of any adaptation thereof in any advertising,
|
||||
;;; promotional, or sales literature without prior written consent from
|
||||
;;; MIT in each case.
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,56 +0,0 @@
|
|||
;;; Support for obsolete, deprecated 0.5.2 char-set procedures.
|
||||
;;; Will go away in a future release.
|
||||
|
||||
(define-interface obsolete-char-set-interface
|
||||
(export char-set-members ; char-set->list
|
||||
chars->char-set ; list->char-set
|
||||
ascii-range->char-set ; ucs-range->char-set (not exact)
|
||||
predicate->char-set ; char-set-filter (not exact)
|
||||
;->char-set ; no longer handles a predicate
|
||||
char-set-every? ; char-set-every
|
||||
char-set-any? ; char-set-any
|
||||
|
||||
char-set-invert ; char-set-complement
|
||||
char-set-invert! ; char-set-complement!
|
||||
|
||||
char-set:alphabetic ; char-set:letter
|
||||
char-set:numeric ; char-set:digit
|
||||
char-set:alphanumeric ; char-set:letter+digit
|
||||
char-set:control)) ; char-set:iso-control
|
||||
|
||||
|
||||
(define-structure obsolete-char-set-lib obsolete-char-set-interface
|
||||
(open scsh-utilities char-set-lib scheme)
|
||||
(begin
|
||||
|
||||
(define char-set-members
|
||||
(deprecated-proc char-set->list 'char-set-members
|
||||
"Use CHAR-SET->LIST instead."))
|
||||
(define chars->char-set
|
||||
(deprecated-proc list->char-set 'chars->char-set
|
||||
"Use LIST->CHAR-SET instead."))
|
||||
(define ascii-range->char-set
|
||||
(deprecated-proc (lambda (lower upper) (ucs-range->char-set lower upper #t))
|
||||
'ascii-range->char-set
|
||||
"Use UCS-RANGE->CHAR-SET instead."))
|
||||
(define predicate->char-set
|
||||
(deprecated-proc (lambda (pred) (char-set-filter pred char-set:full))
|
||||
'predicate->char-set
|
||||
"Change code to use CHAR-SET-FILTER."))
|
||||
(define char-set-every?
|
||||
(deprecated-proc char-set-every 'char-set-every?
|
||||
"Use CHAR-SET-EVERY instead."))
|
||||
(define char-set-any?
|
||||
(deprecated-proc char-set-every 'char-set-any?
|
||||
"Use CHAR-SET-ANY instead."))
|
||||
(define char-set-invert
|
||||
(deprecated-proc char-set-complement 'char-set-invert
|
||||
"Use CHAR-SET-COMPLEMENT instead."))
|
||||
(define char-set-invert!
|
||||
(deprecated-proc char-set-complement! 'char-set-invert!
|
||||
"Use CHAR-SET-COMPLEMENT! instead."))
|
||||
|
||||
(define char-set:alphabetic char-set:letter)
|
||||
(define char-set:numeric char-set:digit)
|
||||
(define char-set:alphanumeric char-set:letter+digit)
|
||||
(define char-set:control char-set:iso-control)))
|
||||
|
|
@ -1,151 +0,0 @@
|
|||
;;; SRFI-14 interface for Scheme48 -*- Scheme -*-
|
||||
;;;
|
||||
;;; Complete interface spec for the SRFI-14 char-set-lib library in the
|
||||
;;; Scheme48 interface and module language. The interface is fully typed, in
|
||||
;;; the Scheme48 type notation. The structure definitions also provide a
|
||||
;;; formal description of the external dependencies of the source code.
|
||||
|
||||
(define-interface char-set-interface
|
||||
(export (char-set? (proc (:value) :boolean))
|
||||
((char-set= char-set<=) (proc (&rest :value) :boolean))
|
||||
|
||||
(char-set-hash (proc (:value &opt :exact-integer) :exact-integer))
|
||||
|
||||
;; Cursors are exact integers in the reference implementation.
|
||||
;; These typings would be different with a different cursor
|
||||
;; implementation.
|
||||
;; Too bad Scheme doesn't have abstract data types.
|
||||
(char-set-cursor (proc (:value) :exact-integer))
|
||||
(char-set-ref (proc (:value :exact-integer) :char))
|
||||
(char-set-cursor-next (proc (:value :exact-integer) :exact-integer))
|
||||
(end-of-char-set? (proc (:value) :boolean))
|
||||
|
||||
(char-set-fold (proc ((proc (:char :value) :value) :value :value)
|
||||
:value))
|
||||
(char-set-unfold (proc ((proc (:value) :boolean)
|
||||
(proc (:value) :value)
|
||||
(proc (:value) :value)
|
||||
:value
|
||||
&opt :value)
|
||||
:value))
|
||||
|
||||
(char-set-unfold! (proc ((proc (:value) :boolean)
|
||||
(proc (:value) :value)
|
||||
(proc (:value) :value)
|
||||
:value :value)
|
||||
:value))
|
||||
|
||||
(char-set-for-each (proc ((proc (:char) :values) :value) :unspecific))
|
||||
(char-set-map (proc ((proc (:char) :char) :value) :value))
|
||||
|
||||
(char-set-copy (proc (:value) :value))
|
||||
|
||||
(char-set (proc (&rest :char) :value))
|
||||
|
||||
(list->char-set (proc (:value &opt :value) :value))
|
||||
(list->char-set! (proc (:value :value) :value))
|
||||
|
||||
(string->char-set (proc (:value &opt :value) :value))
|
||||
(string->char-set! (proc (:value :value) :value))
|
||||
|
||||
(ucs-range->char-set (proc (:exact-integer :exact-integer &opt
|
||||
:boolean :value)
|
||||
:value))
|
||||
(ucs-range->char-set! (proc (:exact-integer :exact-integer
|
||||
:boolean :value)
|
||||
:value))
|
||||
|
||||
(char-set-filter (proc ((proc (:char) :boolean) :value &opt :value) :value))
|
||||
(char-set-filter! (proc ((proc (:char) :boolean) :value :value) :value))
|
||||
|
||||
(->char-set (proc (:value) :value))
|
||||
|
||||
(char-set-size (proc (:value) :exact-integer))
|
||||
(char-set-count (proc ((proc (:char) :boolean) :value) :exact-integer))
|
||||
(char-set-contains? (proc (:value :value) :boolean))
|
||||
|
||||
(char-set-every (proc ((proc (:char) :boolean) :value) :boolean))
|
||||
(char-set-any (proc ((proc (:char) :boolean) :value) :value))
|
||||
|
||||
((char-set-adjoin char-set-delete
|
||||
char-set-adjoin! char-set-delete!)
|
||||
(proc (:value &rest :char) :value))
|
||||
|
||||
(char-set->list (proc (:value) :value))
|
||||
(char-set->string (proc (:value) :string))
|
||||
|
||||
(char-set-complement (proc (:value) :value))
|
||||
((char-set-union char-set-intersection char-set-xor)
|
||||
(proc (&rest :value) :value))
|
||||
|
||||
(char-set-difference (proc (:value &opt :value) :value))
|
||||
|
||||
(char-set-diff+intersection (proc (:value &rest :value)
|
||||
(some-values :value :value)))
|
||||
|
||||
(char-set-complement! (proc (:value) :value))
|
||||
|
||||
((char-set-union! char-set-intersection!
|
||||
char-set-xor! char-set-difference!)
|
||||
(proc (:value &opt :value) :value))
|
||||
|
||||
(char-set-diff+intersection! (proc (:value :value &rest :value)
|
||||
(some-values :value :value)))
|
||||
|
||||
char-set:lower-case
|
||||
char-set:upper-case
|
||||
char-set:letter
|
||||
char-set:digit
|
||||
char-set:letter+digit
|
||||
char-set:graphic
|
||||
char-set:printing
|
||||
char-set:whitespace
|
||||
char-set:blank
|
||||
char-set:iso-control
|
||||
char-set:punctuation
|
||||
char-set:symbol
|
||||
char-set:hex-digit
|
||||
char-set:ascii
|
||||
char-set:empty
|
||||
char-set:full
|
||||
))
|
||||
|
||||
; rdelim.scm gets into the innards of char-sets.
|
||||
(define-interface scsh-char-set-low-level-interface
|
||||
(export (char-set:s (proc (:value) :string))))
|
||||
|
||||
(define-structures ((char-set-lib char-set-interface)
|
||||
(scsh-char-set-low-level-lib scsh-char-set-low-level-interface))
|
||||
(open error-package ; ERROR procedure
|
||||
let-opt ; LET-OPTIONALS* and :OPTIONAL
|
||||
ascii ; CHAR->ASCII ASCII->CHAR
|
||||
bitwise ; BITWISE-AND
|
||||
jar-d-r-t-package ; DEFINE-RECORD-TYPE/JAR macro.
|
||||
scheme)
|
||||
|
||||
(begin (define (check-arg pred val caller)
|
||||
(let lp ((val val))
|
||||
(if (pred val) val (lp (error "Bad argument" val pred caller)))))
|
||||
|
||||
(define %latin1->char ascii->char) ; Works for S48
|
||||
(define %char->latin1 char->ascii) ; Works for S48
|
||||
|
||||
;; Here's a SRFI-19 d-r-t defined in terms of jar's almost-identical
|
||||
;; d-r-t.
|
||||
(define-syntax define-record-type
|
||||
(syntax-rules ()
|
||||
((define-record-type ?name ?stuff ...)
|
||||
(define-record-type/jar ?name ?name ?stuff ...)))))
|
||||
|
||||
(files cset-lib)
|
||||
(optimize auto-integrate))
|
||||
|
||||
;;; Import jar's DEFINE-RECORD-TYPE macro, and export it under the
|
||||
;;; name DEFINE-RECORD-TYPE/JAR.
|
||||
(define-structure jar-d-r-t-package (export (define-record-type/jar :syntax))
|
||||
(open define-record-types ; JAR's record macro
|
||||
scheme)
|
||||
(begin (define-syntax define-record-type/jar
|
||||
(syntax-rules ()
|
||||
((define-record-type/jar ?stuff ...)
|
||||
(define-record-type ?stuff ...))))))
|
||||
|
|
@ -1,200 +0,0 @@
|
|||
;;; This is a regression testing suite for the SRFI-14 char-set library.
|
||||
;;; Olin Shivers
|
||||
|
||||
(let-syntax ((test (syntax-rules ()
|
||||
((test form ...)
|
||||
(cond ((not form) (error "Test failed" 'form)) ...
|
||||
(else 'OK))))))
|
||||
(let ((vowel (lambda (c) (member c '(#\a #\e #\i #\o #\u)))))
|
||||
|
||||
(test
|
||||
(not (char-set? 5))
|
||||
|
||||
(char-set? (char-set #\a #\e #\i #\o #\u))
|
||||
|
||||
(char-set=)
|
||||
(char-set= (char-set))
|
||||
|
||||
(char-set= (char-set #\a #\e #\i #\o #\u)
|
||||
(string->char-set "ioeauaiii"))
|
||||
|
||||
(not (char-set= (char-set #\e #\i #\o #\u)
|
||||
(string->char-set "ioeauaiii")))
|
||||
|
||||
(char-set<=)
|
||||
(char-set<= (char-set))
|
||||
|
||||
(char-set<= (char-set #\a #\e #\i #\o #\u)
|
||||
(string->char-set "ioeauaiii"))
|
||||
|
||||
(char-set<= (char-set #\e #\i #\o #\u)
|
||||
(string->char-set "ioeauaiii"))
|
||||
|
||||
(<= 0 (char-set-hash char-set:graphic 100) 99)
|
||||
|
||||
(= 4 (char-set-fold (lambda (c i) (+ i 1)) 0
|
||||
(char-set #\e #\i #\o #\u #\e #\e)))
|
||||
|
||||
(char-set= (string->char-set "eiaou2468013579999")
|
||||
(char-set-unfold null? car cdr '(#\a #\e #\i #\o #\u #\u #\u)
|
||||
char-set:digit))
|
||||
|
||||
(char-set= (string->char-set "eiaou246801357999")
|
||||
(char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u)
|
||||
(string->char-set "0123456789")))
|
||||
|
||||
(not (char-set= (string->char-set "eiaou246801357")
|
||||
(char-set-unfold! null? car cdr '(#\a #\e #\i #\o #\u)
|
||||
(string->char-set "0123456789"))))
|
||||
|
||||
(let ((cs (string->char-set "0123456789")))
|
||||
(char-set-for-each (lambda (c) (set! cs (char-set-delete cs c)))
|
||||
(string->char-set "02468000"))
|
||||
(char-set= cs (string->char-set "97531")))
|
||||
|
||||
(not (let ((cs (string->char-set "0123456789")))
|
||||
(char-set-for-each (lambda (c) (set! cs (char-set-delete cs c)))
|
||||
(string->char-set "02468"))
|
||||
(char-set= cs (string->char-set "7531"))))
|
||||
|
||||
(char-set= (char-set-map char-upcase (string->char-set "aeiou"))
|
||||
(string->char-set "IOUAEEEE"))
|
||||
|
||||
(not (char-set= (char-set-map char-upcase (string->char-set "aeiou"))
|
||||
(string->char-set "OUAEEEE")))
|
||||
|
||||
(char-set= (char-set-copy (string->char-set "aeiou"))
|
||||
(string->char-set "aeiou"))
|
||||
|
||||
(char-set= (char-set #\x #\y) (string->char-set "xy"))
|
||||
(not (char-set= (char-set #\x #\y #\z) (string->char-set "xy")))
|
||||
|
||||
(char-set= (string->char-set "xy") (list->char-set '(#\x #\y)))
|
||||
(not (char-set= (string->char-set "axy") (list->char-set '(#\x #\y))))
|
||||
|
||||
(char-set= (string->char-set "xy12345")
|
||||
(list->char-set '(#\x #\y) (string->char-set "12345")))
|
||||
(not (char-set= (string->char-set "y12345")
|
||||
(list->char-set '(#\x #\y) (string->char-set "12345"))))
|
||||
|
||||
(char-set= (string->char-set "xy12345")
|
||||
(list->char-set! '(#\x #\y) (string->char-set "12345")))
|
||||
(not (char-set= (string->char-set "y12345")
|
||||
(list->char-set! '(#\x #\y) (string->char-set "12345"))))
|
||||
|
||||
(char-set= (string->char-set "aeiou12345")
|
||||
(char-set-filter vowel? char-set:ascii (string->char-set "12345")))
|
||||
(not (char-set= (string->char-set "aeou12345")
|
||||
(char-set-filter vowel? char-set:ascii (string->char-set "12345"))))
|
||||
|
||||
(char-set= (string->char-set "aeiou12345")
|
||||
(char-set-filter! vowel? char-set:ascii (string->char-set "12345")))
|
||||
(not (char-set= (string->char-set "aeou12345")
|
||||
(char-set-filter! vowel? char-set:ascii (string->char-set "12345"))))
|
||||
|
||||
|
||||
(char-set= (string->char-set "abcdef12345")
|
||||
(ucs-range->char-set 97 103 #t (string->char-set "12345")))
|
||||
(not (char-set= (string->char-set "abcef12345")
|
||||
(ucs-range->char-set 97 103 #t (string->char-set "12345"))))
|
||||
|
||||
(char-set= (string->char-set "abcdef12345")
|
||||
(ucs-range->char-set! 97 103 #t (string->char-set "12345")))
|
||||
(not (char-set= (string->char-set "abcef12345")
|
||||
(ucs-range->char-set! 97 103 #t (string->char-set "12345"))))
|
||||
|
||||
|
||||
(char-set= (->char-set #\x)
|
||||
(->char-set "x")
|
||||
(->char-set (char-set #\x)))
|
||||
|
||||
(not (char-set= (->char-set #\x)
|
||||
(->char-set "y")
|
||||
(->char-set (char-set #\x))))
|
||||
|
||||
(= 10 (char-set-size (char-set-intersection char-set:ascii char-set:digit)))
|
||||
|
||||
(= 5 (char-set-count vowel? char-set:ascii))
|
||||
|
||||
(equal? '(#\x) (char-set->list (char-set #\x)))
|
||||
(not (equal? '(#\X) (char-set->list (char-set #\x))))
|
||||
|
||||
(equal? "x" (char-set->string (char-set #\x)))
|
||||
(not (equal? "X" (char-set->string (char-set #\x))))
|
||||
|
||||
(char-set-contains? (->char-set "xyz") #\x)
|
||||
(not (char-set-contains? (->char-set "xyz") #\a))
|
||||
|
||||
(char-set-every char-lower-case? (->char-set "abcd"))
|
||||
(not (char-set-every char-lower-case? (->char-set "abcD")))
|
||||
(char-set-any char-lower-case? (->char-set "abcd"))
|
||||
(not (char-set-any char-lower-case? (->char-set "ABCD")))
|
||||
|
||||
(char-set= (->char-set "ABCD")
|
||||
(let ((cs (->char-set "abcd")))
|
||||
(let lp ((cur (char-set-cursor cs)) (ans '()))
|
||||
(if (end-of-char-set? cur) (list->char-set ans)
|
||||
(lp (char-set-cursor-next cs cur)
|
||||
(cons (char-upcase (char-set-ref cs cur)) ans))))))
|
||||
|
||||
|
||||
(char-set= (char-set-adjoin (->char-set "123") #\x #\a)
|
||||
(->char-set "123xa"))
|
||||
(not (char-set= (char-set-adjoin (->char-set "123") #\x #\a)
|
||||
(->char-set "123x")))
|
||||
(char-set= (char-set-adjoin! (->char-set "123") #\x #\a)
|
||||
(->char-set "123xa"))
|
||||
(not (char-set= (char-set-adjoin! (->char-set "123") #\x #\a)
|
||||
(->char-set "123x")))
|
||||
|
||||
(char-set= (char-set-delete (->char-set "123") #\2 #\a #\2)
|
||||
(->char-set "13"))
|
||||
(not (char-set= (char-set-delete (->char-set "123") #\2 #\a #\2)
|
||||
(->char-set "13a")))
|
||||
(char-set= (char-set-delete! (->char-set "123") #\2 #\a #\2)
|
||||
(->char-set "13"))
|
||||
(not (char-set= (char-set-delete! (->char-set "123") #\2 #\a #\2)
|
||||
(->char-set "13a")))
|
||||
|
||||
(char-set= (char-set-intersection char-set:hex-digit (char-set-complement char-set:digit))
|
||||
(->char-set "abcdefABCDEF"))
|
||||
(char-set= (char-set-intersection! (char-set-complement! (->char-set "0123456789"))
|
||||
char-set:hex-digit)
|
||||
(->char-set "abcdefABCDEF"))
|
||||
|
||||
(char-set= (char-set-union char-set:hex-digit
|
||||
(->char-set "abcdefghijkl"))
|
||||
(->char-set "abcdefABCDEFghijkl0123456789"))
|
||||
(char-set= (char-set-union! (->char-set "abcdefghijkl")
|
||||
char-set:hex-digit)
|
||||
(->char-set "abcdefABCDEFghijkl0123456789"))
|
||||
|
||||
(char-set= (char-set-difference (->char-set "abcdefghijklmn")
|
||||
char-set:hex-digit)
|
||||
(->char-set "ghijklmn"))
|
||||
(char-set= (char-set-difference! (->char-set "abcdefghijklmn")
|
||||
char-set:hex-digit)
|
||||
(->char-set "ghijklmn"))
|
||||
|
||||
(char-set= (char-set-xor (->char-set "0123456789")
|
||||
char-set:hex-digit)
|
||||
(->char-set "abcdefABCDEF"))
|
||||
(char-set= (char-set-xor! (->char-set "0123456789")
|
||||
char-set:hex-digit)
|
||||
(->char-set "abcdefABCDEF"))
|
||||
|
||||
(call-with-values (lambda ()
|
||||
(char-set-diff+intersection char-set:hex-digit
|
||||
char-set:letter))
|
||||
(lambda (d i)
|
||||
(and (char-set= d (->char-set "0123456789"))
|
||||
(char-set= i (->char-set "abcdefABCDEF")))))
|
||||
|
||||
(call-with-values (lambda ()
|
||||
(char-set-diff+intersection! (char-set-copy char-set:hex-digit)
|
||||
(char-set-copy char-set:letter)))
|
||||
(lambda (d i)
|
||||
(and (char-set= d (->char-set "0123456789"))
|
||||
(char-set= i (->char-set "abcdefABCDEF"))))))
|
||||
|
||||
))
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,249 +0,0 @@
|
|||
;;; This is a Scheme48 interface spec for the SRFI-1 list-lib package.
|
||||
;;; It defines the LIST-LIB-INTERFACE interface and LIST-LIB structure.
|
||||
;;; Bindings are typed as tightly as one can in Scheme48's type language.
|
||||
;;; -Olin Shivers
|
||||
;;; shivers@ai.mit.edu
|
||||
|
||||
;;; list-lib
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; xcons cons* make-list list-tabulate list-copy circular-list iota
|
||||
;;; proper-list? circular-list? dotted-list? not-pair? null-list? list=
|
||||
;;; first second third fourth fifth sixth seventh eighth ninth tenth
|
||||
;;; car+cdr
|
||||
;;; take drop
|
||||
;;; take-right drop-right
|
||||
;;; take! drop-right!
|
||||
;;; take-while drop-while take-while!
|
||||
;;; split-at split-at!
|
||||
;;; span break
|
||||
;;; span! break!
|
||||
;;; last last-pair
|
||||
;;; length+
|
||||
;;; append! reverse! append-reverse append-reverse! concatenate concatenate!
|
||||
;;; zip unzip1 unzip2 unzip3 unzip4 unzip5
|
||||
;;; count
|
||||
;;; unfold unfold-right
|
||||
;;; fold unfold pair-fold reduce
|
||||
;;; fold-right unfold-right pair-fold-right reduce-right
|
||||
;;; append-map append-map! map! pair-for-each filter-map map-in-order
|
||||
;;; filter partition remove
|
||||
;;; filter! partition! remove!
|
||||
;;; find find-tail any every list-index
|
||||
;;; delete delete! delete-duplicates delete-duplicates!
|
||||
;;; alist-cons alist-copy
|
||||
;;; alist-delete alist-delete!
|
||||
;;;
|
||||
;;; 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!
|
||||
;;;
|
||||
;;; map for-each member assoc (Extended R4RS procedures)
|
||||
;;;
|
||||
;;; cons pair? null? list length append reverse (These are the
|
||||
;;; car cdr ... cdddar cddddr set-car! set-cdr! list-ref R4RS procedures
|
||||
;;; memq memv assoc assq assv re-exported by
|
||||
;;; list-lib unchanged.)
|
||||
|
||||
(define-interface list-lib-interface
|
||||
(export
|
||||
;; xcons <cdr> <car>
|
||||
(xcons (proc (:value :value) :value))
|
||||
|
||||
;; cons* item ...
|
||||
(cons* (proc (:value &rest :value) :value))
|
||||
|
||||
;; make-list len [fill]
|
||||
(make-list (proc (:exact-integer &opt :value) :value))
|
||||
|
||||
;; list-tabulate elt-proc len
|
||||
(list-tabulate (proc (:exact-integer (proc (:exact-integer) :value)) :value))
|
||||
|
||||
;; list-copy lis
|
||||
(list-copy (proc (:value) :value))
|
||||
|
||||
(circular-list (proc (:value &rest :value) :pair))
|
||||
|
||||
; ((:iota iota:)
|
||||
; (proc (:number &opt :number :number) :value))
|
||||
|
||||
(iota (proc (:exact-integer &opt :number :number) :value))
|
||||
|
||||
(proper-list? (proc (:value) :boolean))
|
||||
(dotted-list? (proc (:value) :boolean))
|
||||
(circular-list? (proc (:value) :boolean))
|
||||
|
||||
(not-pair? (proc (:value) :boolean))
|
||||
(null-list? (proc (:value) :boolean))
|
||||
|
||||
(list= (proc ((proc (:value :value) :boolean) &rest :value) :boolean))
|
||||
|
||||
((first second third fourth fifth sixth seventh eighth ninth tenth)
|
||||
(proc (:pair) :value))
|
||||
|
||||
(car+cdr (proc (:pair) (some-values :value :value)))
|
||||
|
||||
;; take lis i take-right lis i
|
||||
;; drop lis i drop-right lis i
|
||||
;; take! lis i drop-right! lis i
|
||||
((take drop take-right drop-right take! drop-right!)
|
||||
(proc (:value :exact-integer) :value))
|
||||
|
||||
((split-at split-at!)
|
||||
(proc (:value :exact-integer) (some-values :value :value)))
|
||||
|
||||
(last (proc (:pair) :value))
|
||||
(last-pair (proc (:pair) :pair))
|
||||
|
||||
(length+ (proc (:value) :value))
|
||||
(append! (proc (:value &rest :value) :value))
|
||||
(reverse! (proc (:value) :value))
|
||||
((append-reverse append-reverse!) (proc (:value :value) :value))
|
||||
((concatenate concatenate!) (proc (:value) :value))
|
||||
|
||||
(zip (proc (:value &rest :value) :value))
|
||||
(unzip1 (proc (:value) :value))
|
||||
(unzip2 (proc (:value) (some-values :value :value)))
|
||||
(unzip3 (proc (:value) (some-values :value :value :value)))
|
||||
(unzip4 (proc (:value) (some-values :value :value :value :value)))
|
||||
(unzip5 (proc (:value) (some-values :value :value :value :value :value)))
|
||||
|
||||
(count (proc ((proc (:value &rest :value) :boolean) :value) :exact-integer))
|
||||
|
||||
((fold fold-right)
|
||||
(proc ((proc (:value :value &rest :value) :value)
|
||||
:value :value &rest :value)
|
||||
:value))
|
||||
|
||||
((unfold unfold-right) (proc ((proc (:value) :boolean)
|
||||
(proc (:value) :value)
|
||||
(proc (:value) :value)
|
||||
:value
|
||||
&opt (proc (:value) :value))
|
||||
:value))
|
||||
|
||||
((pair-fold pair-fold-right)
|
||||
(proc ((proc (:pair :value &rest :value) :value)
|
||||
:value :value &rest :value)
|
||||
:value))
|
||||
|
||||
((reduce reduce-right)
|
||||
(proc ((proc (:value :value) :value) :value :value) :value))
|
||||
|
||||
((append-map append-map! map! filter-map map-in-order)
|
||||
(proc ((proc (:value &rest :value) :value) :value &rest :value) :value))
|
||||
|
||||
(pair-for-each (proc ((proc (:pair &rest :pair) :values) :value &rest :value)
|
||||
:unspecific))
|
||||
|
||||
((filter filter! remove remove!)
|
||||
(proc ((proc (:value) :boolean) :value) :value))
|
||||
|
||||
((partition partition!) (proc ((proc (:value) :boolean) :value)
|
||||
(some-values :value :value)))
|
||||
|
||||
((find find-tail) (proc ((proc (:value) :boolean) :value) :value))
|
||||
|
||||
((take-while take-while! drop-while)
|
||||
(proc ((proc (:value) :boolean) :value) :value))
|
||||
|
||||
((span break span! break!)
|
||||
(proc ((proc (:value) :boolean) :value) (some-values :value :value)))
|
||||
|
||||
((any every)
|
||||
(proc ((proc (:value &rest :value) :value) :value &rest :value) :value))
|
||||
|
||||
(list-index (proc ((proc (:value &rest :value) :value) :value &rest :value)
|
||||
:value))
|
||||
|
||||
((delete delete!)
|
||||
(proc (:value :value &opt (proc (:value :value) :boolean)) :value))
|
||||
|
||||
;; Extended from their R5RS definitions to take an optional comparison
|
||||
;; function: (MEMBER x lis [=]).
|
||||
(member (proc (:value :value &opt (proc (:value :value) :boolean)) :value))
|
||||
(assoc (proc (:value :value &opt (proc (:value :value) :boolean)) :value))
|
||||
|
||||
((delete-duplicates delete-duplicates!)
|
||||
(proc (:value &opt (proc (:value :value) :boolean)) :value))
|
||||
|
||||
(alist-cons (proc (:value :value :value) :value))
|
||||
(alist-copy (proc (:value) :value))
|
||||
((alist-delete alist-delete!)
|
||||
(proc (:value :value &opt (proc (:value :value) :value)) :value))
|
||||
|
||||
;; Extended from their R4RS definitions.
|
||||
(map (proc ((proc (:value &rest :value) :value) :value &rest :value) :value))
|
||||
(for-each (proc ((proc (:value &rest :value) :values) :value &rest :value) :unspecific))
|
||||
|
||||
;; R4RS exports
|
||||
(cons (proc (:value :value) :pair))
|
||||
((pair? null?) (proc (:value) :boolean))
|
||||
(list-ref (proc (:value :exact-integer) :value))
|
||||
(list (proc (&rest :value) :value))
|
||||
(length (proc (:value) :exact-integer))
|
||||
(append (proc (&rest :value) :value))
|
||||
(reverse (proc (:value) :value))
|
||||
((car cdr
|
||||
caaaar caaadr caadar caaddr caaar caadr caar
|
||||
cadaar cadadr caddar cadddr cadar caddr cadr
|
||||
cdaaar cdaadr cdadar cdaddr cdaar cdadr cdar
|
||||
cddaar cddadr cdddar cddddr cddar cdddr cddr) (proc (:value) :value))
|
||||
((set-car! set-cdr!) (proc (:pair :value) :unspecific))
|
||||
((memq memv) (proc (:value :value) :value))
|
||||
((assq assv) (proc (:value :value) :value))
|
||||
|
||||
|
||||
;; lset-lib
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; lset<= = list1 list2 ...
|
||||
;; lset= = list1 list2 ...
|
||||
;; lset-adjoin = list elt1 ...
|
||||
;; lset-union = list1 ...
|
||||
;; lset-intersection = list1 list2 ...
|
||||
;; lset-difference = list1 list2 ...
|
||||
;; lset-xor = list1 ...
|
||||
;; lset-diff+intersection = list1 list2 ...
|
||||
;; ... and their side effecting counterparts:
|
||||
;; lset-union! lset-intersection! lset-difference! lset-xor!
|
||||
;; lset-diff+intersection!
|
||||
|
||||
;; lset= = list1 ... -> boolean
|
||||
;; lset<= = list1 ... -> boolean
|
||||
((lset= lset<=)
|
||||
(proc ((proc (:value :value) :boolean) &rest :value) :boolean))
|
||||
|
||||
;; lset-adjoin = list elt1 ...
|
||||
(lset-adjoin (proc ((proc (:value :value) :boolean) :value &rest :value) :value))
|
||||
|
||||
;; lset-union = list1 ... lset-xor = list1 ...
|
||||
;; lset-union! = list1 ... lset-xor! = list1 ...
|
||||
((lset-union lset-xor)
|
||||
(proc ((proc (:value :value) :boolean) &rest :value) :value))
|
||||
|
||||
;; lset-intersection = list1 list2 ...
|
||||
;; lset-intersection! = list1 list2 ...
|
||||
;; lset-difference = list1 list2 ...
|
||||
;; lset-difference! = list1 list2 ...
|
||||
((lset-intersection lset-difference
|
||||
lset-intersection! lset-difference!)
|
||||
(proc ((proc (:value :value) :boolean) :value &rest :value) :value))
|
||||
|
||||
;; lset-diff+intersection = list1 list2 ...
|
||||
;; lset-diff+intersection! = list1 list2 ...
|
||||
((lset-diff+intersection lset-diff+intersection!)
|
||||
(proc ((proc (:value :value) :boolean) :value &rest :value)
|
||||
(some-values :value :value)))
|
||||
))
|
||||
|
||||
(define-structure list-lib list-lib-interface
|
||||
(open error-package ; ERROR procedure
|
||||
receiving ; RECEIVE m-v macro
|
||||
let-opt ; LET-OPTIONALS and :OPTIONAL.
|
||||
scheme)
|
||||
(begin (define (check-arg pred val caller)
|
||||
(let lp ((val val))
|
||||
(if (pred val) val (lp (error "Bad argument" val pred caller))))))
|
||||
(files list-lib))
|
||||
3257
scsh/lib/srfi-1.html
3257
scsh/lib/srfi-1.html
File diff suppressed because it is too large
Load Diff
2015
scsh/lib/srfi-1.txt
2015
scsh/lib/srfi-1.txt
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
|
|
@ -1,315 +0,0 @@
|
|||
;;; string-lib
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; string-map string-map!
|
||||
;;; string-fold string-fold-right
|
||||
;;; string-unfold string-tabulate
|
||||
;;; string-for-each string-iter
|
||||
;;; string-every string-any
|
||||
;;; string-compare string-compare-ci
|
||||
;;; substring-compare substring-compare-ci
|
||||
;;; string= string< string> string<= string>= string<>
|
||||
;;; string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<>
|
||||
;;; substring= substring<> substring-ci= substring-ci<>
|
||||
;;; substring< substring> substring-ci< substring-ci>
|
||||
;;; substring<= substring>= substring-ci<= substring-ci>=
|
||||
;;; string-upper-case? string-lower-case?
|
||||
;;; capitalize-string capitalize-words string-downcase string-upcase
|
||||
;;; capitalize-string! capitalize-words! string-downcase! string-upcase!
|
||||
;;; string-take string-drop
|
||||
;;; string-pad string-pad-right
|
||||
;;; string-trim string-trim-right string-trim-both
|
||||
;;; string-filter string-delete
|
||||
;;; string-index string-index-right string-skip string-skip-right
|
||||
;;; string-prefix-count string-prefix-count-ci
|
||||
;;; string-suffix-count string-suffix-count-ci
|
||||
;;; substring-prefix-count substring-prefix-count-ci
|
||||
;;; substring-suffix-count substring-suffix-count-ci
|
||||
;;; string-prefix? string-prefix-ci?
|
||||
;;; string-suffix? string-suffix-ci?
|
||||
;;; substring-prefix? substring-prefix-ci?
|
||||
;;; substring-suffix? substring-suffix-ci?
|
||||
;;; substring? substring-ci?
|
||||
;;; string-fill! string-copy! string-copy substring
|
||||
;;; string-reverse string-reverse! reverse-list->string
|
||||
;;; string->list
|
||||
;;; string-concat string-concat/shared string-append/shared
|
||||
;;; xsubstring string-xcopy!
|
||||
;;; string-null?
|
||||
;;; join-strings
|
||||
;;;
|
||||
;;; string? make-string string string-length string-ref string-set!
|
||||
;;; string-append list->string
|
||||
|
||||
(define-interface string-lib-interface
|
||||
(export
|
||||
;; string-map proc s [start end] -> s
|
||||
(string-map (proc ((proc (:char) :char)
|
||||
:string
|
||||
&opt :exact-integer :exact-integer)
|
||||
:string))
|
||||
|
||||
;; string-map! proc s [start end] -> unspecific
|
||||
(string-map! (proc ((proc (:char) :values)
|
||||
:string
|
||||
&opt :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
|
||||
;; string-fold kons knil s [start end] -> value
|
||||
;; string-fold-right kons knil s [start end] -> value
|
||||
((string-fold string-fold-right)
|
||||
(proc ((proc (:char :value) :value)
|
||||
:value :string
|
||||
&opt :exact-integer :exact-integer)
|
||||
:value))
|
||||
|
||||
;; string-unfold p f g seed -> string
|
||||
(string-unfold (proc ((proc (:value) :boolean)
|
||||
(proc (:value) :char)
|
||||
(proc (:value) :value)
|
||||
:value)
|
||||
:string))
|
||||
|
||||
; Enough is enough.
|
||||
; ;; string-unfoldn p f g seed ... -> string
|
||||
; (string-unfoldn (proc ((procedure :values :boolean)
|
||||
; (procedure :values :char)
|
||||
; (procedure :values :values)
|
||||
; &rest :value)
|
||||
; :string))
|
||||
|
||||
;; string-tabulate proc len -> string
|
||||
(string-tabulate (proc ((proc (:exact-integer) :char) :exact-integer)
|
||||
:string))
|
||||
|
||||
;; string-for-each proc s [start end] -> unspecific
|
||||
;; string-iter proc s [start end] -> unspecific
|
||||
((string-for-each string-iter)
|
||||
(proc ((proc (:char) :values) :string &opt :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
|
||||
;; string-every pred s [start end]
|
||||
;; string-any pred s [start end]
|
||||
(string-every
|
||||
(proc ((proc (:char) :boolean) :string &opt :exact-integer :exact-integer)
|
||||
:boolean))
|
||||
(string-any
|
||||
(proc ((proc (:char) :boolean) :string &opt :exact-integer :exact-integer)
|
||||
:value))
|
||||
|
||||
;; string-compare string1 string2 lt-proc eq-proc gt-proc
|
||||
;; string-compare-ci string1 string2 lt-proc eq-proc gt-proc
|
||||
((string-compare string-compare-ci)
|
||||
(proc (:string :string (proc (:exact-integer) :values)
|
||||
(proc (:exact-integer) :values)
|
||||
(proc (:exact-integer) :values))
|
||||
:values))
|
||||
|
||||
;; substring-compare string1 start1 end1 string2 start2 end2 lt eq gt
|
||||
;; substring-compare-ci string1 start1 end1 string2 start2 end2 lt eq gt
|
||||
((substring-compare substring-compare-ci)
|
||||
(proc (:string :exact-integer :exact-integer
|
||||
:string :exact-integer :exact-integer
|
||||
(proc (:exact-integer) :values)
|
||||
(proc (:exact-integer) :values)
|
||||
(proc (:exact-integer) :values))
|
||||
:values))
|
||||
|
||||
;; string< string1 string2
|
||||
((string= string< string> string<= string>= string<>
|
||||
string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<>)
|
||||
(proc (&rest :string) :value))
|
||||
|
||||
;; substring< string1 start1 end1 string2 start2 end2
|
||||
((substring= substring<> substring-ci= substring-ci<>
|
||||
substring< substring> substring-ci< substring-ci>
|
||||
substring<= substring>= substring-ci<= substring-ci>=)
|
||||
(proc (:string :exact-integer :exact-integer
|
||||
:string :exact-integer :exact-integer)
|
||||
:value))
|
||||
|
||||
;; string-upper-case? string [start end]
|
||||
;; string-lower-case? string [start end]
|
||||
((string-upper-case? string-lower-case?)
|
||||
(proc (:string &opt :exact-integer :exact-integer) :boolean))
|
||||
|
||||
;; capitalize-string string [start end]
|
||||
;; capitalize-words string [start end]
|
||||
;; string-downcase string [start end]
|
||||
;; string-upcase string [start end]
|
||||
;; capitalize-string! string [start end]
|
||||
;; capitalize-words! string [start end]
|
||||
;; string-downcase! string [start end]
|
||||
;; string-upcase! string [start end]
|
||||
((capitalize-string capitalize-words string-downcase string-upcase)
|
||||
(proc (:string &opt :exact-integer :exact-integer) :string))
|
||||
((capitalize-string! capitalize-words! string-downcase! string-upcase!)
|
||||
(proc (:string &opt :exact-integer :exact-integer) :unspecific))
|
||||
|
||||
;; string-take string nchars
|
||||
;; string-drop string nchars
|
||||
((string-take string-drop) (proc (:string :exact-integer) :string))
|
||||
|
||||
;; string-pad string k [char start end]
|
||||
;; string-pad-right string k [char start end]
|
||||
((string-pad string-pad-right)
|
||||
(proc (:string :exact-integer &opt :char :exact-integer :exact-integer)
|
||||
:string))
|
||||
|
||||
;; string-trim string [char/char-set/pred start end]
|
||||
;; string-trim-right string [char/char-set/pred start end]
|
||||
;; string-trim-both string [char/char-set/pred start end]
|
||||
((string-trim string-trim-right string-trim-both)
|
||||
(proc (:string &opt :value :exact-integer :exact-integer)
|
||||
:string))
|
||||
|
||||
;; string-filter char/char-set/pred string [start end]
|
||||
;; string-delete char/char-set/pred string [start end]
|
||||
((string-filter string-delete)
|
||||
(proc (:value :string &opt :exact-integer :exact-integer) :string))
|
||||
|
||||
;; string-index string char/char-set/pred [start end]
|
||||
;; string-index-right string char/char-set/pred [end start]
|
||||
;; string-skip string char/char-set/pred [start end]
|
||||
;; string-skip-right string char/char-set/pred [end start]
|
||||
((string-index string-index-right string-skip string-skip-right)
|
||||
(proc (:string :value &opt :exact-integer :exact-integer)
|
||||
:value))
|
||||
|
||||
;; string-prefix-count string1 string2
|
||||
;; string-suffix-count string1 string2
|
||||
;; string-prefix-count-ci string1 string2
|
||||
;; string-suffix-count-ci string1 string2
|
||||
((string-prefix-count string-prefix-count-ci
|
||||
string-suffix-count string-suffix-count-ci)
|
||||
(proc (:string :string) :exact-integer))
|
||||
|
||||
;; substring-prefix-count string1 start1 end1 string2 start2 end2
|
||||
;; substring-suffix-count string1 start1 end1 string2 start2 end2
|
||||
;; substring-prefix-count-ci string1 start1 end1 string2 start2 end2
|
||||
;; substring-suffix-count-ci string1 start1 end1 string2 start2 end2
|
||||
((substring-prefix-count substring-prefix-count-ci
|
||||
substring-suffix-count substring-suffix-count-ci)
|
||||
(proc (:string :exact-integer :exact-integer
|
||||
:string :exact-integer :exact-integer)
|
||||
:exact-integer))
|
||||
|
||||
|
||||
;; string-prefix? string1 string2
|
||||
;; string-suffix? string1 string2
|
||||
;; string-prefix-ci? string1 string2
|
||||
;; string-suffix-ci? string1 string2
|
||||
((string-prefix? string-prefix-ci?
|
||||
string-suffix? string-suffix-ci?)
|
||||
(proc (:string :string) :boolean))
|
||||
|
||||
;; substring-prefix? string1 start1 end1 string2 start2 end2
|
||||
;; substring-suffix? string1 start1 end1 string2 start2 end2
|
||||
;; substring-prefix-ci? string1 start1 end1 string2 start2 end2
|
||||
;; substring-suffix-ci? string1 start1 end1 string2 start2 end2
|
||||
((substring-prefix? substring-prefix-ci?
|
||||
substring-suffix? substring-suffix-ci?)
|
||||
(proc (:string :exact-integer :exact-integer
|
||||
:string :exact-integer :exact-integer)
|
||||
:boolean))
|
||||
|
||||
;; substring? pattern string [start end]
|
||||
;; substring-ci? pattern string [start end]
|
||||
((substring? substring-ci?)
|
||||
(proc (:string :string &opt :exact-integer :exact-integer)
|
||||
:value))
|
||||
|
||||
;; string-fill! string char [start end]
|
||||
(string-fill! (proc (:string :char &opt :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
|
||||
;; string-copy! to tstart from [fstart fend]
|
||||
(string-copy! (proc (:string :exact-integer :string
|
||||
&opt :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
|
||||
;; string-copy s [start end] -> string
|
||||
;; substring s start [end] -> string
|
||||
(string-copy (proc (:string &opt :exact-integer :exact-integer) :string))
|
||||
(substring (proc (:string :exact-integer &opt :exact-integer) :string))
|
||||
|
||||
;; string-reverse s [start end]
|
||||
;; string-reverse! s [start end]
|
||||
(string-reverse (proc (:string &opt :exact-integer :exact-integer) :string))
|
||||
(string-reverse! (proc (:string &opt :exact-integer :exact-integer) :unspecific))
|
||||
|
||||
;; reverse-list->string char-list
|
||||
;; string->list s [start end]
|
||||
;; string-concat string-list
|
||||
;; string-concat/shared string-list
|
||||
;; string-append/shared s ...
|
||||
(reverse-list->string (proc (:value) :string))
|
||||
(string->list (proc (:string &opt :exact-integer :exact-integer) :value))
|
||||
((string-concat string-concat/shared) (proc (:value) :string))
|
||||
(string-append/shared (proc (&rest :string) :string))
|
||||
|
||||
;; xsubstring s from [to start end]
|
||||
;; string-xcopy! target tstart s from [to start end]
|
||||
(xsubstring (proc (:string :exact-integer &opt
|
||||
:exact-integer :exact-integer :exact-integer)
|
||||
:string))
|
||||
(string-xcopy! (proc (:string :exact-integer :string :exact-integer &opt
|
||||
:exact-integer :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
|
||||
;; string-null? s
|
||||
(string-null? (proc (:string) :boolean))
|
||||
|
||||
(join-strings (proc (:value &opt :string :symbol) :string))
|
||||
|
||||
;; Here are the R4RS procs
|
||||
(string? (proc (:value) :boolean))
|
||||
(make-string (proc (:exact-integer &opt :char) :string))
|
||||
(string (proc (&rest :char) :string))
|
||||
(string-length (proc (:string) :exact-integer))
|
||||
(string-ref (proc (:string :exact-integer) :char))
|
||||
(string-set! (proc (:string :exact-integer :char) :unspecific))
|
||||
|
||||
; Not provided by string-lib.
|
||||
;((string=? string-ci=? string<? string-ci<?
|
||||
; string>? string-ci>? string<=? string-ci<=?
|
||||
; string>=? string-ci>=?) (proc (:string :string) :boolean))
|
||||
|
||||
;; These are the R4RS types for SUBSTRING, STRING-COPY, STRING-FILL!,
|
||||
;; and STRING->LIST. The string-lib types are different -- extended.
|
||||
;(substring (proc (:string :exact-integer :exact-integer) :string))
|
||||
;(string-copy (proc (:string) :string))
|
||||
;(string-fill! (proc (:string :char) :unspecific))
|
||||
;(string->list (proc (:string) :value))
|
||||
|
||||
(string-append (proc (&rest :string) :string))
|
||||
(list->string (proc (:value) :string))
|
||||
))
|
||||
|
||||
|
||||
;;; make-kmp-restart-vector
|
||||
;;; parse-final-start+end
|
||||
;;; parse-start+end
|
||||
;;; check-substring-spec
|
||||
|
||||
(define-interface string-lib-internals-interface
|
||||
(export
|
||||
(parse-final-start+end (proc ((procedure :values :values) :string :value)
|
||||
(some-values :exact-integer :exact-integer)))
|
||||
(parse-start+end (proc ((procedure :values :values) :string :value)
|
||||
(some-values :exact-integer :exact-integer :value)))
|
||||
(check-substring-spec (proc ((procedure :values :values) :string :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
(make-kmp-restart-vector (proc (:string (proc (:char :char) :boolean))
|
||||
:vector))))
|
||||
|
||||
|
||||
(define-structures ((string-lib string-lib-interface)
|
||||
(string-lib-internals string-lib-internals-interface))
|
||||
(access scheme) ; Get at R5RS SUBSTRING
|
||||
(open receiving ; RECEIVE
|
||||
char-set-package; Various
|
||||
error-package ; ERROR
|
||||
let-opt ; LET-OPTIONALS :OPTIONAL
|
||||
structure-refs ; STRUCTURE-REF
|
||||
scheme)
|
||||
(files string-lib))
|
||||
|
|
@ -1,350 +0,0 @@
|
|||
;;; Complete interface spec for the SRFI-13 string-lib and -*- Scheme -*-
|
||||
;;; string-lib-internals libraries in the Scheme48 interface
|
||||
;;; and module language. The interfaces are fully typed, in
|
||||
;;; the Scheme48 type notation. The structure definitions also
|
||||
;;; provide a formal description of the external dependencies
|
||||
;;; of the source code.
|
||||
|
||||
;;; string-lib
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; string-map string-map!
|
||||
;;; string-fold string-unfold
|
||||
;;; string-fold-right string-unfold-right
|
||||
;;; string-tabulate string-for-each string-for-each-index
|
||||
;;; string-every string-any
|
||||
;;; string-hash string-hash-ci
|
||||
;;; string-compare string-compare-ci
|
||||
;;; string= string< string> string<= string>= string<>
|
||||
;;; string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<>
|
||||
;;; string-downcase string-upcase string-titlecase
|
||||
;;; string-downcase! string-upcase! string-titlecase!
|
||||
;;; string-take string-take-right
|
||||
;;; string-drop string-drop-right
|
||||
;;; string-pad string-pad-right
|
||||
;;; string-trim string-trim-right string-trim-both
|
||||
;;; string-filter string-delete
|
||||
;;; string-index string-index-right
|
||||
;;; string-skip string-skip-right
|
||||
;;; string-count
|
||||
;;; string-prefix-length string-prefix-length-ci
|
||||
;;; string-suffix-length string-suffix-length-ci
|
||||
;;; string-prefix? string-prefix-ci?
|
||||
;;; string-suffix? string-suffix-ci?
|
||||
;;; string-contains string-contains-ci
|
||||
;;; string-fill! string-copy!
|
||||
;;; string-copy substring/shared
|
||||
;;; string-reverse string-reverse! reverse-list->string
|
||||
;;; string->list
|
||||
;;; string-concatenate string-concatenate/shared
|
||||
;;; string-concatenate-reverse string-concatenate-reverse/shared
|
||||
;;; string-append/shared
|
||||
;;; xsubstring string-xcopy!
|
||||
;;; string-null?
|
||||
;;; string-join
|
||||
;;; string-tokenize
|
||||
;;; string-replace
|
||||
;;;
|
||||
;;; string? make-string string string-length string-ref string-set!
|
||||
;;; string-append list->string
|
||||
;;;
|
||||
;;; make-kmp-restart-vector string-kmp-partial-search kmp-step
|
||||
;;; string-parse-start+end
|
||||
;;; string-parse-final-start+end
|
||||
;;; let-string-start+end
|
||||
;;; check-substring-spec
|
||||
;;; substring-spec-ok?
|
||||
|
||||
(define-interface string-lib-interface
|
||||
(export
|
||||
;; string-map proc s [start end] -> s
|
||||
(string-map (proc ((proc (:char) :char)
|
||||
:string
|
||||
&opt :exact-integer :exact-integer)
|
||||
:string))
|
||||
|
||||
;; string-map! proc s [start end] -> unspecific
|
||||
(string-map! (proc ((proc (:char) :values)
|
||||
:string
|
||||
&opt :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
|
||||
;; string-fold kons knil s [start end] -> value
|
||||
;; string-fold-right kons knil s [start end] -> value
|
||||
((string-fold string-fold-right)
|
||||
(proc ((proc (:char :value) :value)
|
||||
:value :string
|
||||
&opt :exact-integer :exact-integer)
|
||||
:value))
|
||||
|
||||
;; string-unfold p f g seed [base make-final] -> string
|
||||
;; string-unfold-right p f g seed [base make-final] -> string
|
||||
((string-unfold string-unfold)
|
||||
(proc ((proc (:value) :boolean)
|
||||
(proc (:value) :char)
|
||||
(proc (:value) :value)
|
||||
:value
|
||||
&opt :string (proc (:value) :string))
|
||||
:string))
|
||||
|
||||
; Enough is enough.
|
||||
; ;; string-unfoldn p f g seed ... -> string
|
||||
; (string-unfoldn (proc ((procedure :values :boolean)
|
||||
; (procedure :values :char)
|
||||
; (procedure :values :values)
|
||||
; &rest :value)
|
||||
; :string))
|
||||
|
||||
;; string-tabulate proc len -> string
|
||||
(string-tabulate (proc ((proc (:exact-integer) :char) :exact-integer)
|
||||
:string))
|
||||
|
||||
;; string-for-each proc s [start end] -> unspecific
|
||||
;; string-for-each-index proc s [start end] -> unspecific
|
||||
((string-for-each string-for-each-index)
|
||||
(proc ((proc (:char) :values) :string &opt :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
|
||||
;; string-every pred s [start end]
|
||||
;; string-any pred s [start end]
|
||||
(string-every
|
||||
(proc ((proc (:char) :boolean) :string &opt :exact-integer :exact-integer)
|
||||
:boolean))
|
||||
(string-any
|
||||
(proc ((proc (:char) :boolean) :string &opt :exact-integer :exact-integer)
|
||||
:value))
|
||||
|
||||
;; string-hash s [bound start end]
|
||||
;; string-hash-ci s [bound start end]
|
||||
((string-hash string-hash-ci)
|
||||
(proc (:string &opt :exact-integer :exact-integer :exact-integer)
|
||||
:exact-integer))
|
||||
|
||||
;; string-compare string1 string2 lt-proc eq-proc gt-proc [start end]
|
||||
;; string-compare-ci string1 string2 lt-proc eq-proc gt-proc [start end]
|
||||
((string-compare string-compare-ci)
|
||||
(proc (:string :string (proc (:exact-integer) :values)
|
||||
(proc (:exact-integer) :values)
|
||||
(proc (:exact-integer) :values)
|
||||
&opt :exact-integer :exact-integer)
|
||||
:values))
|
||||
|
||||
;; string< string1 string2 [start1 end1 start2 end2]
|
||||
((string= string< string> string<= string>= string<>
|
||||
string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<>)
|
||||
(proc (:string :string &opt :exact-integer :exact-integer
|
||||
:exact-integer :exact-integer)
|
||||
:boolean))
|
||||
|
||||
;; string-titlecase string [start end]
|
||||
;; string-upcase string [start end]
|
||||
;; string-downcase string [start end]
|
||||
;; string-titlecase! string [start end]
|
||||
;; string-upcase! string [start end]
|
||||
;; string-downcase! string [start end]
|
||||
((string-titlecase string-upcase string-downcase)
|
||||
(proc (:string &opt :exact-integer :exact-integer) :string))
|
||||
((string-titlecase! string-upcase! string-downcase!)
|
||||
(proc (:string &opt :exact-integer :exact-integer) :unspecific))
|
||||
|
||||
;; string-take string nchars
|
||||
;; string-drop string nchars
|
||||
;; string-take-right string nchars
|
||||
;; string-drop-right string nchars
|
||||
((string-take string-drop string-take-right string-drop-right)
|
||||
(proc (:string :exact-integer) :string))
|
||||
|
||||
;; string-pad string k [char start end]
|
||||
;; string-pad-right string k [char start end]
|
||||
((string-pad string-pad-right)
|
||||
(proc (:string :exact-integer &opt :char :exact-integer :exact-integer)
|
||||
:string))
|
||||
|
||||
;; string-trim string [char/char-set/pred start end]
|
||||
;; string-trim-right string [char/char-set/pred start end]
|
||||
;; string-trim-both string [char/char-set/pred start end]
|
||||
((string-trim string-trim-right string-trim-both)
|
||||
(proc (:string &opt :value :exact-integer :exact-integer)
|
||||
:string))
|
||||
|
||||
;; string-filter char/char-set/pred string [start end]
|
||||
;; string-delete char/char-set/pred string [start end]
|
||||
((string-filter string-delete)
|
||||
(proc (:value :string &opt :exact-integer :exact-integer) :string))
|
||||
|
||||
;; string-index string char/char-set/pred [start end]
|
||||
;; string-index-right string char/char-set/pred [end start]
|
||||
;; string-skip string char/char-set/pred [start end]
|
||||
;; string-skip-right string char/char-set/pred [end start]
|
||||
((string-index string-index-right string-skip string-skip-right)
|
||||
(proc (:string :value &opt :exact-integer :exact-integer)
|
||||
:value))
|
||||
|
||||
;; string-count string char/char-set/pred [start end]
|
||||
(string-count (proc (:string :value &opt :exact-integer :exact-integer)
|
||||
:exact-integer))
|
||||
|
||||
;; string-prefix-length string1 string2 [start1 end1 start2 end2]
|
||||
;; string-suffix-length string1 string2 [start1 end1 start2 end2]
|
||||
;; string-prefix-length-ci string1 string2 [start1 end1 start2 end2]
|
||||
;; string-suffix-length-ci string1 string2 [start1 end1 start2 end2]
|
||||
((string-prefix-length string-prefix-length-ci
|
||||
string-suffix-length string-suffix-length-ci)
|
||||
(proc (:string :string &opt
|
||||
:exact-integer :exact-integer :exact-integer :exact-integer)
|
||||
:exact-integer))
|
||||
|
||||
;; string-prefix? string1 string2 [start1 end1 start2 end2]
|
||||
;; string-suffix? string1 string2 [start1 end1 start2 end2]
|
||||
;; string-prefix-ci? string1 string2 [start1 end1 start2 end2]
|
||||
;; string-suffix-ci? string1 string2 [start1 end1 start2 end2]
|
||||
((string-prefix? string-prefix-ci?
|
||||
string-suffix? string-suffix-ci?)
|
||||
(proc (:string :string &opt
|
||||
:exact-integer :exact-integer :exact-integer :exact-integer)
|
||||
:boolean))
|
||||
|
||||
;; string-contains string pattern [s-start s-end p-start p-end]
|
||||
;; string-contains-ci string pattern [s-start s-end p-start p-end]
|
||||
((string-contains string-contains-ci)
|
||||
(proc (:string :string &opt :exact-integer :exact-integer
|
||||
:exact-integer :exact-integer)
|
||||
:value))
|
||||
|
||||
;; string-fill! string char [start end]
|
||||
(string-fill! (proc (:string :char &opt :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
|
||||
;; string-copy! to tstart from [fstart fend]
|
||||
(string-copy! (proc (:string :exact-integer :string
|
||||
&opt :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
|
||||
;; string-copy s [start end] -> string
|
||||
;; substring/shared s start [end] -> string
|
||||
(string-copy (proc (:string &opt :exact-integer :exact-integer) :string))
|
||||
(substring/shared (proc (:string :exact-integer &opt :exact-integer) :string))
|
||||
|
||||
;; string-reverse s [start end]
|
||||
;; string-reverse! s [start end]
|
||||
(string-reverse (proc (:string &opt :exact-integer :exact-integer) :string))
|
||||
(string-reverse! (proc (:string &opt :exact-integer :exact-integer) :unspecific))
|
||||
|
||||
;; reverse-list->string char-list
|
||||
;; string->list s [start end]
|
||||
;; string-concatenate string-list
|
||||
;; string-concatenate/shared string-list
|
||||
;; string-append/shared s ...
|
||||
(reverse-list->string (proc (:value) :string))
|
||||
(string->list (proc (:string &opt :exact-integer :exact-integer) :value))
|
||||
((string-concatenate string-concatenate/shared) (proc (:value) :string))
|
||||
(string-append/shared (proc (&rest :string) :string))
|
||||
|
||||
;; string-concatenate-reverse string-list [final-string end]
|
||||
;; string-concatenate-reverse/shared string-list [final-string end]
|
||||
((string-concatenate-reverse string-concatenate-reverse/shared)
|
||||
(proc (:value &opt :string :exact-integer) :string))
|
||||
|
||||
;; xsubstring s from [to start end]
|
||||
;; string-xcopy! target tstart s from [to start end]
|
||||
(xsubstring (proc (:string :exact-integer &opt
|
||||
:exact-integer :exact-integer :exact-integer)
|
||||
:string))
|
||||
(string-xcopy! (proc (:string :exact-integer :string :exact-integer &opt
|
||||
:exact-integer :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
|
||||
;; string-null? s
|
||||
(string-null? (proc (:string) :boolean))
|
||||
|
||||
;; string-join string-list [delim grammar]
|
||||
(string-join (proc (:value &opt :string :symbol) :string))
|
||||
|
||||
;; string-tokenize string [token-chars start end]
|
||||
(string-tokenize (proc (:string &opt :value :exact-integer :exact-integer)
|
||||
:value))
|
||||
|
||||
;; string-replace s1 s2 start1 end1 [start2 end2]
|
||||
(string-replace (proc (:string :string :exact-integer :exact-integer
|
||||
&opt :exact-integer :exact-integer)
|
||||
:string))
|
||||
|
||||
;; Here are the R4RS/R5RS procs
|
||||
(string? (proc (:value) :boolean))
|
||||
(make-string (proc (:exact-integer &opt :char) :string))
|
||||
(string (proc (&rest :char) :string))
|
||||
(string-length (proc (:string) :exact-integer))
|
||||
(string-ref (proc (:string :exact-integer) :char))
|
||||
(string-set! (proc (:string :exact-integer :char) :unspecific))
|
||||
(string-append (proc (&rest :string) :string))
|
||||
(list->string (proc (:value) :string))
|
||||
|
||||
;; These are the R4RS types for STRING-COPY, STRING-FILL!, and
|
||||
;; STRING->LIST. The string-lib types are different -- extended.
|
||||
;(string-copy (proc (:string) :string))
|
||||
;(string-fill! (proc (:string :char) :unspecific))
|
||||
;(string->list (proc (:string) :value))
|
||||
|
||||
))
|
||||
|
||||
|
||||
;;; make-kmp-restart-vector
|
||||
;;; string-kmp-partial-search
|
||||
;;; kmp-step
|
||||
;;; string-parse-start+end
|
||||
;;; string-parse-final-start+end
|
||||
;;; let-string-start+end
|
||||
;;; check-substring-spec
|
||||
;;; substring-spec-ok?
|
||||
|
||||
(define-interface string-lib-internals-interface
|
||||
(export
|
||||
(let-string-start+end :syntax)
|
||||
(string-parse-start+end (proc ((procedure :values :values) :string :value)
|
||||
(some-values :exact-integer :exact-integer :value)))
|
||||
(string-parse-final-start+end (proc ((procedure :values :values) :string :value)
|
||||
(some-values :exact-integer :exact-integer)))
|
||||
(check-substring-spec (proc ((procedure :values :values) :string :exact-integer :exact-integer)
|
||||
:unspecific))
|
||||
(substring-spec-ok? (proc ((procedure :values :values) :string :exact-integer :exact-integer)
|
||||
:boolean))
|
||||
|
||||
;; string-kmp-partial-search pat rv s i [c= p-start s-start s-end] -> integer
|
||||
(string-kmp-partial-search (proc (:string :vector :string :exact-integer
|
||||
&opt (proc (:char :char) :boolean)
|
||||
:exact-integer :exact-integer :exact-integer)
|
||||
:exact-integer))
|
||||
|
||||
;; make-kmp-restart-vector s [c= start end] -> vector
|
||||
(make-kmp-restart-vector (proc (:string &opt (proc (:char :char) :boolean)
|
||||
:exact-integer :exact-integer)
|
||||
:vector))
|
||||
|
||||
;; kmp-step pat rv c i c= p-start -> integer
|
||||
(kmp-step (proc (:string :vector :char :exact-integer
|
||||
(proc (:char :char) :boolean)
|
||||
:exact-integer)
|
||||
:exact-integer))
|
||||
))
|
||||
|
||||
|
||||
(define-structures ((string-lib string-lib-interface)
|
||||
(string-lib-internals string-lib-internals-interface))
|
||||
(access scheme) ; Get at R5RS SUBSTRING
|
||||
(open receiving ; RECEIVE
|
||||
char-set-lib ; Various
|
||||
bitwise ; BITWISE-AND for hashing
|
||||
error-package ; ERROR
|
||||
let-opt ; LET-OPTIONALS* :OPTIONAL
|
||||
scheme)
|
||||
|
||||
;; A few cheesy S48/scsh definitions for string-lib dependencies:
|
||||
(begin (define (check-arg pred val caller)
|
||||
(let lp ((val val))
|
||||
(if (pred val) val (lp (error "Bad argument" val pred caller)))))
|
||||
|
||||
;; These two internal procedures are correctly defined for ASCII or
|
||||
;; Latin-1. They are *not* correct for Unicode.
|
||||
(define (char-cased? c) (char-set-contains? char-set:letter c))
|
||||
(define (char-titlecase c) (char-upcase c)))
|
||||
|
||||
(files string-lib))
|
||||
|
|
@ -33,7 +33,7 @@
|
|||
(let ((substr (lambda (s end) ; Smart substring.
|
||||
(if (= end (string-length s)) s
|
||||
(substring s 0 end))))
|
||||
(delims (->char-set delims))
|
||||
(delims (x->char-set delims))
|
||||
(gobble? (not (eq? delim-action 'peek))))
|
||||
;; BUFLEN is total amount of buffer space allocated to date.
|
||||
(let lp ((strs '()) (buflen 80) (buf (make-string 80)))
|
||||
|
|
@ -127,7 +127,7 @@
|
|||
(if (char? last)
|
||||
(string-set! buf (+ start num-read) last))
|
||||
(and (or (eof-object? last)
|
||||
(char-set-contains? (->char-set delims)
|
||||
(char-set-contains? (x->char-set delims)
|
||||
last))
|
||||
(+ num-read 1)))))))))
|
||||
|
||||
|
|
@ -192,15 +192,14 @@
|
|||
(start 0)
|
||||
(end (string-length buf)))
|
||||
|
||||
(let* ((delims (->char-set delims))
|
||||
(sdelims (char-set:s delims)))
|
||||
(let ((delims (x->char-set delims)))
|
||||
(let lp ((start start) (total 0))
|
||||
(receive (terminator num-read)
|
||||
(port-buffer-read-delimited delims buf gobble? port start end)
|
||||
(if (not (eq? terminator 'port-buffer-exhausted))
|
||||
(values terminator (+ num-read total))
|
||||
(begin (peek-char port) ; kludge to fill the buffer
|
||||
(lp (+ start num-read) (+ total num-read)))))))))
|
||||
(receive (terminator num-read)
|
||||
(port-buffer-read-delimited delims buf gobble? port start end)
|
||||
(if (not (eq? terminator 'port-buffer-exhausted))
|
||||
(values terminator (+ num-read total))
|
||||
(begin (peek-char port) ; kludge to fill the buffer
|
||||
(lp (+ start num-read) (+ total num-read)))))))))
|
||||
|
||||
|
||||
|
||||
|
|
@ -211,16 +210,15 @@
|
|||
|
||||
|
||||
(define (skip-char-set skip-chars . maybe-port)
|
||||
(let* ((port (:optional maybe-port (current-input-port)))
|
||||
(cset (->char-set skip-chars))
|
||||
(scset (char-set:s cset)))
|
||||
(let ((port (:optional maybe-port (current-input-port)))
|
||||
(cset (x->char-set skip-chars)))
|
||||
|
||||
(let lp ((total 0))
|
||||
(receive (succ num-read) (buffer-skip-char-set cset port)
|
||||
(if (not succ)
|
||||
(+ total num-read) ; eof
|
||||
(begin (peek-char port); kludge to fill the buffer
|
||||
(lp (+ total num-read))))))))
|
||||
(if (not succ)
|
||||
(+ total num-read) ; eof
|
||||
(begin (peek-char port) ; kludge to fill the buffer
|
||||
(lp (+ total num-read))))))))
|
||||
|
||||
(define (buffer-skip-char-set cset port)
|
||||
(let ((the-port-limit (port-limit port)))
|
||||
|
|
|
|||
|
|
@ -1,7 +0,0 @@
|
|||
;;; ,exec ,load loadem.scm
|
||||
|
||||
(config '(load "packages2.scm"))
|
||||
(config '(load "cond-package.scm"))
|
||||
;(map load-package '(rx-lib re-basics re-low-exports re-high-tools
|
||||
; sre-parser-package re-posix-parsers sre-syntax-tools
|
||||
; rx-syntax))
|
||||
|
|
@ -1,26 +0,0 @@
|
|||
(define-structure re-package (export)
|
||||
(open scsh
|
||||
formats
|
||||
define-record-types ; re
|
||||
defrec-package ; re
|
||||
scsh-utilities ;
|
||||
define-foreign-syntax ; re-low
|
||||
weak ; re-low
|
||||
let-opt ; re
|
||||
sort ; posixstr
|
||||
receiving ; all of them
|
||||
scheme)
|
||||
|
||||
(files "/usr/home/shivers/src/scm/conditionals.scm"
|
||||
re
|
||||
re-low
|
||||
simp
|
||||
re-high
|
||||
parse
|
||||
posixstr
|
||||
spencer
|
||||
;re-syntax
|
||||
)
|
||||
|
||||
(optimize auto-integrate)
|
||||
)
|
||||
|
|
@ -228,20 +228,20 @@
|
|||
(open scsh-utilities
|
||||
defrec-package
|
||||
weak
|
||||
;re-posix-parsers ; regexp->posix-string
|
||||
;; re-posix-parsers ; regexp->posix-string
|
||||
let-opt
|
||||
sort ; Posix renderer
|
||||
sort ; Posix renderer
|
||||
conditionals
|
||||
define-record-types
|
||||
defrec-package
|
||||
receiving
|
||||
char-set-lib
|
||||
srfi-14
|
||||
error-package
|
||||
ascii
|
||||
primitives ; JMG add-finalizer!
|
||||
define-record-types ; JMG debugging
|
||||
primitives ; JMG add-finalizer!
|
||||
define-record-types ; JMG debugging
|
||||
external-calls
|
||||
string-lib ; string-fold
|
||||
srfi-13 ; string-fold
|
||||
posix-regexps
|
||||
scheme)
|
||||
|
||||
|
|
@ -275,7 +275,7 @@
|
|||
(open re-internals
|
||||
conditionals
|
||||
re-level-0
|
||||
char-set-lib
|
||||
srfi-14
|
||||
scsh-utilities ; fold
|
||||
error-package
|
||||
ascii
|
||||
|
|
@ -291,7 +291,7 @@
|
|||
|
||||
(define-structure rx-syntax rx-syntax-interface
|
||||
(open re-level-0
|
||||
char-set-lib
|
||||
srfi-14
|
||||
rx-lib
|
||||
standard-char-sets
|
||||
scheme)
|
||||
|
|
@ -332,7 +332,7 @@
|
|||
posix-regexps
|
||||
scsh-utilities ; fold & some string utilities that need to be moved.
|
||||
scsh-level-0 ; write-string
|
||||
string-lib ; string-copy!
|
||||
srfi-13 ; string-copy!
|
||||
scheme)
|
||||
(files re-subst)
|
||||
; (optimize auto-integrate)
|
||||
|
|
|
|||
|
|
@ -107,7 +107,9 @@
|
|||
(regexp-submatches? regexp)
|
||||
(regexp-newline? regexp))))
|
||||
(error (if message
|
||||
(string-append "Posix regexp: " message)
|
||||
(string-append "Posix regexp ("
|
||||
(regexp-pattern regexp)
|
||||
") : " message)
|
||||
"inconsistent results from Posix regexp compiler")
|
||||
regexp))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -46,6 +46,11 @@
|
|||
tables)
|
||||
(files weaktables))
|
||||
|
||||
(define list-lib srfi-1)
|
||||
(define string-lib srfi-13)
|
||||
(define char-set-lib srfi-14)
|
||||
|
||||
|
||||
;;; This guy goes into the FOR-SYNTAX part of scsh's syntax exports.
|
||||
(define-structure scsh-syntax-helpers
|
||||
(export transcribe-extended-process-form)
|
||||
|
|
@ -125,7 +130,8 @@
|
|||
scsh-sockets-interface ; new in 0.3
|
||||
tty-interface ; new in 0.4
|
||||
scsh-version-interface
|
||||
char-set-interface
|
||||
(interface-of char-set-lib)
|
||||
(export ->char-set)
|
||||
signal-handler-interface
|
||||
;; This stuff would probably be better off kept
|
||||
;; in separate modules, but we'll toss it in for now.
|
||||
|
|
@ -167,10 +173,9 @@
|
|||
fluids thread-fluids
|
||||
weak-tables
|
||||
|
||||
scsh-char-set-low-level-lib ; rdelim.scm needs it.
|
||||
srfi-14
|
||||
; scsh-regexp-package
|
||||
; scsh-regexp-internals
|
||||
char-set-lib
|
||||
scsh-version
|
||||
tty-flags
|
||||
scsh-internal-tty-flags ; Not exported
|
||||
|
|
@ -184,7 +189,7 @@
|
|||
re-level-0
|
||||
rx-syntax
|
||||
|
||||
string-lib
|
||||
srfi-13
|
||||
|
||||
thread-fluids ; For exec-path-list
|
||||
loopholes ; For my bogus CALL-TERMINALLY implementation.
|
||||
|
|
@ -243,6 +248,9 @@
|
|||
rdelim
|
||||
)
|
||||
; (optimize auto-integrate)
|
||||
(begin
|
||||
;; work around for SRFI 14 naming fuckage
|
||||
(define ->char-set x->char-set))
|
||||
)
|
||||
|
||||
(define-structure defrec-package (export (define-record :syntax))
|
||||
|
|
@ -325,7 +333,11 @@
|
|||
; with-current-output-port exit
|
||||
scsh-level-0-internals ; set-command-line-args! init-scsh-vars
|
||||
threads
|
||||
list-lib ; any
|
||||
(subset srfi-1 (any))
|
||||
(subset srfi-14 (char-set
|
||||
char-set-complement!
|
||||
char-set-contains?
|
||||
string->char-set))
|
||||
root-scheduler ; scheme-exit-now
|
||||
scheme)
|
||||
(files top meta-arg))
|
||||
|
|
@ -335,7 +347,12 @@
|
|||
(open receiving ; receive
|
||||
scsh-utilities ; deprecated-proc
|
||||
error-package ; error
|
||||
string-lib ; string-join for obsolete join-strings
|
||||
(subset srfi-13 (string-join))
|
||||
(subset srfi-14 (char-set?
|
||||
char-set:whitespace
|
||||
char-set
|
||||
x->char-set
|
||||
char-set-complement))
|
||||
scsh-level-0 ; delimited readers
|
||||
; scsh-regexp-package
|
||||
re-exports
|
||||
|
|
@ -345,7 +362,7 @@
|
|||
(files fr)
|
||||
;; Handle a little bit of backwards compatibility.
|
||||
(begin (define join-strings (deprecated-proc string-join 'join-strings
|
||||
"Use STRING-LIB STRING-JOIN.")))
|
||||
"Use SRFI-13 STRING-JOIN.")))
|
||||
)
|
||||
|
||||
|
||||
|
|
@ -392,12 +409,10 @@
|
|||
(export repl)
|
||||
awk-interface
|
||||
char-predicates-interface; Urk -- Some of this is R5RS!
|
||||
obsolete-char-set-interface
|
||||
dot-locking-interface
|
||||
)
|
||||
|
||||
(open structure-refs
|
||||
obsolete-char-set-lib
|
||||
scsh-level-0
|
||||
scsh-level-0-internals
|
||||
re-exports
|
||||
|
|
@ -421,6 +436,7 @@
|
|||
receiving
|
||||
scsh ; Just need the delimited readers.
|
||||
features ; make-immutable!
|
||||
(subset srfi-14 (char-set))
|
||||
scheme)
|
||||
(files here))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue