Update of /cvsroot/scsh/scsh/scsh/lib
In directory usw-pr-cvs1:/tmp/cvs-serv11197/scsh/lib
Modified Files:
Tag: srfi13and14_integration_2000_3_10
ccp-pack.scm ccp.scm list-lib.scm srfi-1.html string-lib.scm
Added Files:
Tag: srfi13and14_integration_2000_3_10
char-package.scm cset-lib.html cset-lib.scm cset-lib.txt
cset-obsolete.scm cset-package.scm cset-tests.scm
string-package.scm
Log Message:
Integrated srfi-13 (string lib)& srfi-14 (char-set lib)
- Ported sources to use these libs instead of older string & cset libs
- Wrote backwards-compatibility libs for now-deprecated procs in the
scsh API
- Hacked the makefile/package/interfaces glue
Whew.
--- NEW FILE ---
;;; These defs are things for characters *not* in SRFIs 13 & 14.
;;; It includes some R5RS defs that are not correct in S48 in a Latin-1 world.
(define-interface char-set-predicates-interface
(export
((char-lower-case? ; R5RS
char-upper-case? ; R5RS
char-alphabetic? ; R5RS
char-numeric? ; R5RS
char-whitespace? ; R5RS
char-alphanumeric? ; For compatibility w/old code
char-letter? ; Scsh
char-digit?
char-letter+digit?
char-graphic?
char-printing?
char-blank?
char-iso-control?
char-punctuation?
char-symbol?
char-hex-digit?
char-ascii?) (proc (:char) :boolean))))
(define-structure char-set-predicates-lib char-set-predicates-interface
(open error-package ; ERROR
scsh-utilities ; DEPRECATED-PROC
char-set-lib
scheme)
(begin
;; These are R5RS. We can't use the native S48 ones, because they
;; don't handle full Latin-1.
(define (char-lower-case? c) (char-set-contains? char-set:lower-case c))
(define (char-upper-case? c) (char-set-contains? char-set:upper-case c))
(define (char-alphabetic? c) (char-set-contains? char-set:letter c))
(define (char-numeric? c) (char-set-contains? char-set:digit c))
(define (char-whitespace? c) (char-set-contains? char-set:whitespace c))
;; These are scsh extensions to R5RS.
(define (char-letter? c) (char-set-contains? char-set:letter c))
(define (char-digit? c) (char-set-contains? char-set:digit c))
(define (char-letter+digit? c) (char-set-contains? char-set:letter+digit c))
(define (char-graphic? c) (char-set-contains? char-set:graphic c))
(define (char-printing? c) (char-set-contains? char-set:printing c))
(define (char-blank? c) (char-set-contains? char-set:blank c))
(define (char-iso-control? c) (char-set-contains? char-set:iso-control c))
(define (char-punctuation? c) (char-set-contains? char-set:punctuation c))
(define (char-symbol? c) (char-set-contains? char-set:symbol c))
(define (char-hex-digit? c) (char-set-contains? char-set:hex-digit c))
(define (char-ascii? c) (char-set-contains? char-set:ascii c))
;; Obsolete scsh.
(define char-alphanumeric?
(deprecated-proc char-letter+digit? 'char-alphanumeric?
"Use CHAR-LETTER+DIGIT? instead.")))
(optimize auto-integrate))
--- NEW FILE ---
<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
"http://www.w3.org/TR/html4/loose.dtd";>
<!--
- Do a paragraph check <p>
- The Unicode char tables are messed up, but it can't be fixed w/o CSS2
support, which I do not currently find in web browsers.
- Can I have bangs, plusses, or slashes in #tags? Spaces?
Yes: plus, bang, star No: space Yes: slash, question, ampersand
You can't put sharp in a path, so anything goes, really.
Nonetheless, some of these confuse Netscape, so I'll avoid them.
-->
<!--========================================================================-->
<html lang=en-US>
<head>
<meta name="keywords" content="Scheme, programming language, list
processing, SRFI, underage lesbian sluts">
<link rev=made href="mailto:shivers@ai.mit.edu";>
<title>SRFI 14: Character-set Library</title>
[...1977 lines suppressed...]
LocalWords: elba elbA ary consed XXXX ac bc kons knil ans plusses
LocalWords: catamorphism lp eof lis cdr knull kar kdr anamorphism
LocalWords: abcdefg sfrom sto TCL perl slen rv exp initialisation
LocalWords: plen SJ PJ si sj pj IPORT iport patlen DF buf Bevan
LocalWords: Denheyer scsh Paolo Amoroso Arvestad Bawden Dybvig
LocalWords: Bornstein Bothner Egorov Feeley Matthias Felleisen
LocalWords: Flatt ucs Gleckler Goetter Sven Hartrumpf Hilsdale
LocalWords: Kiselyov Bengt Korb Kleberg Kolbly Shriram bignum
LocalWords: Krishnamurthi Lucier Schilling Sobel Mikael Staldal
LocalWords: Tsyshevsky documentors Jaffer Sperber cltl AE fixnum
LocalWords: CommonLisp HyperSpec Clinger Rees SIGPLAN uniquified
LocalWords: cset EA DrScheme IEC conformant JIS xor diff Posix URL
LocalWords: FFF DIAERESIS abcdefghijklmnopqrstuvwxyz EB EC EF ETH
LocalWords: FA FB FC FD FF Ll AA diaeresis isLowerCase BA CB CC CE
LocalWords: CF DA DC Lt CARON PSILI Lu PROSGEGRAMMENI DASIA VARIA
LocalWords: OXIA PERISPOMENI FAA FAB FAC FAE FAF FBC FFC Lm Lo
LocalWords: abcdefABCDEF Zs Zl Zp OGHAM IDEOGRAPHIC Pc recognised
LocalWords: tokenizers iso Pd Ps Pe Pf AB BB BF Sm Sc Sk AF MACRON
LocalWords: PILCROW soh nul ops Shiro Kawai subform
-->
--- NEW FILE ---
;;; 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.
--- NEW FILE ---
The SRFI 14 character-set library -*- outline -*-
Olin Shivers
98/11/8
Last Update: 2000/7/4
Emacs should display this document in outline mode. Say c-h m for
instructions on how to move through it by sections (e.g., c-c c-n, c-c c-p).
* Table of contents
-------------------
Abstract
Variable index
Rationale
Linear-update operations
Extra-SRFI recommendations
Specification
General procedures
Iterating over character sets
Creating character sets
[...1232 lines suppressed...]
----------------------------------
Ispell dumps "buffer local" words here. Please ignore.
LocalWords: SRFI Unicode API RS lib ARG ascii xor diff defs Generalise cs CSi
LocalWords: kons knil proc upcase cset lp eof lis cdr pred ary CHARi Posix op
LocalWords: uniquified DrScheme soh nul HTML srfi html txt scm Clinger Rees
LocalWords: SIGPLAN refs ucs iso CS's downcase IEC conformant JIS ASCII URL
LocalWords: FFF abcdefghijklmnopqrstuvwxyz DF DIAERESIS AE EA EB EC EE EF ETH
LocalWords: FA FB FC FD FF SS diaeresis isLowerCase Ll AA BA titlecase CA CB
LocalWords: CC CD CE CF DA DC DD Lt CARON PSILI PROSGEGRAMMENI DASIA VARIA Lu
LocalWords: OXIA PERISPOMENI FAA FAB FAC FAE FAF FBC FFC Lm Lo abcdefABCDEF
LocalWords: Zs Zl Zp OGHAM IDEOGRAPHIC recognised isspace isWhitespace Pc Pd
LocalWords: tokenizers IsISOControl Ps Pe Pf AB BB BF Sm Sc Sk AC AF MACRON
LocalWords: PILCROW obj EQ scsh ops UnicodeData Paolo Amoroso Arvestad Bawden
LocalWords: Bornstein Bothner Denheyer Dybvig Egorov Feeley Matthias Flatt eq
LocalWords: Felleisen Gleckler Goetter Sven Hartrumpf Hilsdale Shiro Kawai
LocalWords: Kiselyov Bengt Kleberg Kolbly Korb Shriram Krishnamurthi Lucier
LocalWords: Schilling Sobel Mikael Staldal Tsyshevsky documentors Jaffer ans
LocalWords: Sperber bignum fixnum ref init doc dict subform
--- NEW FILE ---
;;; 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-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-EVERYyn instead."))
(define char-set-invert
(deprecated-proc char-set-complement 'char-set-invert
"Use CHAR-SET-COMPLEMENTyn instead."))
(define char-set-invert!
(deprecated-proc char-set-complement! 'char-set-invert!
"Use CHAR-SET-COMPLEMENT!yn 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)))
--- NEW FILE ---
;;; 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 (:char :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 ...))))))
--- NEW FILE ---
;;; 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"))))))
))
--- NEW FILE ---
;;; 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))
Index: ccp-pack.scm
===================================================================
RCS file: /cvsroot/scsh/scsh/scsh/lib/ccp-pack.scm,v
retrieving revision 1.1
retrieving revision 1.1.2.1
diff -C2 -r1.1 -r1.1.2.1
*** ccp-pack.scm 1999/09/13 17:46:05 1.1
--- ccp-pack.scm 2001/03/11 03:47:00 1.1.2.1
***************
*** 94,98 ****
(define-structure ccp-lib ccp-lib-interface
! (open char-set-package
ascii
defrec-package
--- 94,98 ----
(define-structure ccp-lib ccp-lib-interface
! (open char-set-lib
ascii
defrec-package
Index: ccp.scm
===================================================================
RCS file: /cvsroot/scsh/scsh/scsh/lib/ccp.scm,v
retrieving revision 1.1
retrieving revision 1.1.2.1
diff -C2 -r1.1 -r1.1.2.1
*** ccp.scm 1999/09/15 14:27:23 1.1
--- ccp.scm 2001/03/11 03:47:00 1.1.2.1
***************
*** 96,104 ****
(and (char-set= domain (ccp:domain ccp2))
(let ((cmap2 (ccp:map ccp2)))
! (char-set-every? (lambda (c)
! (let ((i (char->ascii c)))
! (char=? (string-ref cmap i)
! (string-ref cmap2 i))))
! domain))))
rest)))
--- 96,104 ----
(and (char-set= domain (ccp:domain ccp2))
(let ((cmap2 (ccp:map ccp2)))
! (char-set-every (lambda (c)
! (let ((i (char->ascii c)))
! (char=? (string-ref cmap i)
! (string-ref cmap2 i))))
! domain))))
rest)))
***************
*** 117,125 ****
(and (char-set<= domain1 domain2)
(let ((cmap2 (ccp:map ccp2)))
! (char-set-every? (lambda (c)
! (let ((i (char->ascii c)))
! (char=? (string-ref cmap1 i)
! (string-ref cmap2 i))))
! domain1))
(lp domain2 cmap2 rest))))))
--- 117,125 ----
(and (char-set<= domain1 domain2)
(let ((cmap2 (ccp:map ccp2)))
! (char-set-every (lambda (c)
! (let ((i (char->ascii c)))
! (char=? (string-ref cmap1 i)
! (string-ref cmap2 i))))
! domain1))
(lp domain2 cmap2 rest))))))
Index: list-lib.scm
===================================================================
RCS file: /cvsroot/scsh/scsh/scsh/lib/list-lib.scm,v
retrieving revision 1.3
retrieving revision 1.3.2.1
diff -C2 -r1.3 -r1.3.2.1
*** list-lib.scm 1999/10/04 17:33:43 1.3
--- list-lib.scm 2001/03/11 03:47:00 1.3.2.1
***************
*** 17,20 ****
--- 17,25 ----
;;; for SRFI-1. See the porting notes below for more information.
+ ;;; Revision history
+ ;;;;;;;;;;;;;;;;;;;;
+ ;;; This is version 1.1. 12/18/2000
+ ;;; Fixes a small bug in DELETE-DUPLICATES!.
+
;;; Exported:
;;; xcons tree-copy make-list list-tabulate cons* list-copy
***************
*** 385,389 ****
(cond ((pair? l) #f)
((null? l) #t)
! (else (error "null-pair?: argument out of domain" l))))
--- 390,394 ----
(cond ((pair? l) #f)
((null? l) #t)
! (else (error "null-list?: argument out of domain" l))))
***************
*** 1240,1244 ****
(if (eq? tail new-tail) lis (cons x new-tail)))))))
! (define (delete-duplicates! lis maybe-=)
(let ((elt= (:optional maybe-= equal?)))
(check-arg procedure? elt= delete-duplicates!)
--- 1245,1249 ----
(if (eq? tail new-tail) lis (cons x new-tail)))))))
! (define (delete-duplicates! lis . maybe-=)
(let ((elt= (:optional maybe-= equal?)))
(check-arg procedure? elt= delete-duplicates!)
Index: srfi-1.html
===================================================================
RCS file: /cvsroot/scsh/scsh/scsh/lib/srfi-1.html,v
retrieving revision 1.3
retrieving revision 1.3.2.1
diff -C2 -r1.3 -r1.3.2.1
*** srfi-1.html 1999/10/04 17:33:44 1.3
--- srfi-1.html 2001/03/11 03:47:00 1.3.2.1
***************
*** 1,3 ****
! <!doctype html public '-//W3C//DTD HTML 4.0//EN'
'http://www.w3.org/TR/REC-html40/strict.dtd'>
--- 1,3 ----
! <!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0//EN"
'http://www.w3.org/TR/REC-html40/strict.dtd'>
***************
*** 37,43 ****
pre.code-example { margin-left: 2em; } /* Indent code examples. */
/* This stuff is for definition lists of defined procedures.
** A proc-def2 is used when you want a stack of procs to go
! ** with one <dd> ... </dd> body. In this case, make the first
** proc a proc-def1, following ones proc-defi's, and the last one
** a proc-defn.
--- 37,49 ----
pre.code-example { margin-left: 2em; } /* Indent code examples. */
+ /* "Continue" class marks text that isn't really the start
+ ** of a new paragraph -- e.g., continuing a para after a
+ ** code sample.
+ */
+ p.continue { text-indent: 0em; margin-top: 0em}
+
/* This stuff is for definition lists of defined procedures.
** A proc-def2 is used when you want a stack of procs to go
! ** with one dd body. In this case, make the first
** proc a proc-def1, following ones proc-defi's, and the last one
** a proc-defn.
***************
*** 102,106 ****
</style>
! <style type="text/css"; media=all>
/* Nastiness: Here, I'm using a bug to work around a bug.
** Netscape rendering bugs mean you need bogus <dt> and <dd>
--- 108,112 ----
</style>
! <style type="text/css" media=all>
/* Nastiness: Here, I'm using a bug to work around a bug.
** Netscape rendering bugs mean you need bogus <dt> and <dd>
***************
*** 141,151 ****
<!--========================================================================-->
! <h1>Author</H1>
<address>
! <a href="http://www.ai.mit.edu/~shivers/";>Olin Shivers</A> /
! <a href="mailto:shivers@ai.mit.edu";>shivers@ai.mit.edu</A>
</address>
<!--========================================================================-->
<h1>Table of contents</H1>
--- 147,173 ----
<!--========================================================================-->
! <H1>Author</H1>
! <p>
! Olin Shivers
!
<address>
! <a
href="http://www.ai.mit.edu/~shivers/";>http://www.ai.mit.edu/~shivers/</A> /
! <a href="mailto:shivers@ai.mit.edu";>shivers@ai.mit.edu</A>
</address>
<!--========================================================================-->
+ <H1>Status</H1>
+ <p>
+ This SRFI is currently in ``final status. To see an explanation of each
status that a SRFI can hold, see <A
HREF="http://srfi.schemers.org/srfi-process.html";>here</A>.
+ You can access the discussion via <A HREF=mail-archive/maillist.html>the
archive of the mailing list</A>.
+ <P>
+ <UL>
+ <LI>Received: 1998/11/08</LI>
+ <LI>Draft: 1998/12/22-1999/03/09</LI>
+ <LI>Revised: several times</LI>
+ <LI>Final: 1999/10/09</LI>
+ </UL>
+
+
<!--========================================================================-->
<h1>Table of contents</H1>
***************
*** 155,159 ****
<ul id=toc-table>
<li><a href="#Abstract">Abstract</a>
! <li><a href="#Introduction">Introduction</a>
<li><a href="#ProcedureIndex">Procedure index</a>
<li><a href="#GeneralDiscussion">General discussion</a>
--- 177,181 ----
<ul id=toc-table>
<li><a href="#Abstract">Abstract</a>
! <li><a href="#Rationale">Rationale</a>
<li><a href="#ProcedureIndex">Procedure index</a>
<li><a href="#GeneralDiscussion">General discussion</a>
***************
*** 197,208 ****
</ul>
- <strong><em>Note: This is a working draft, and tends to lag the plain-text
version in terms of actual content.
- See <a href="ftp://ftp.ai.mit.edu/people/shivers/srfi/srfi-1/srfi-1.txt";>
- ftp://ftp.ai.mit.edu/people/shivers/srfi/srfi-1/srfi-1.txt</a>
- for the latest copy of the plain-text draft.
- </em></strong>
-
<!--========================================================================-->
! <h1><a name="Introduction">Introduction</a></h1>
<p>
The set of basic list and pair operations provided by R4RS/<abbr
title="Revised^5 Report on Scheme"><a href="#R5RS">R5RS</a></abbr> Scheme is far
--- 219,224 ----
</ul>
<!--========================================================================-->
! <h1><a name="Rationale">Rationale</a></h1>
<p>
The set of basic list and pair operations provided by R4RS/<abbr
title="Revised^5 Report on Scheme"><a href="#R5RS">R5RS</a></abbr> Scheme is far
***************
*** 279,285 ****
<p>
Here is a short list of the procedures provided by the list-lib package.
! <a href="#R5RS">R5RS</a></abbr> procedures are shown in
! <span class=r5rs-proc>bold</span class=r5rs-proc>;
! extended <a href="#R5RS">R5RS</a></abbr>
procedures, in <span class=r5rs-procx>bold italic</span>.
<div class=indent>
--- 295,301 ----
<p>
Here is a short list of the procedures provided by the list-lib package.
! <abbr title="Revised^5 Report on Scheme"><a href="#R5RS">R5RS</a></abbr>
procedures are shown in
! <span class=r5rs-proc>bold</span>;
! extended <abbr title="Revised^5 Report on Scheme"><a
href="#R5RS">R5RS</a></abbr>
procedures, in <span class=r5rs-procx>bold italic</span>.
<div class=indent>
***************
*** 1034,1040 ****
==== car cdr
============================================================================-->
<a name="car"></a>
<a name="cdr"></a>
! <dt class=proc-def1><code class=proc-def>car</code><var> pair ->
value</var>
<dt class=proc-defn><code class=proc-def>cdr</code><var> pair ->
value</var>
<dd class=proc-def>
--- 1050,1057 ----
==== car cdr
============================================================================-->
+ <dt class=proc-def1>
<a name="car"></a>
<a name="cdr"></a>
! <code class=proc-def>car</code><var> pair -> value</var>
<dt class=proc-defn><code class=proc-def>cdr</code><var> pair ->
value</var>
<dd class=proc-def>
***************
*** 2787,2790 ****
--- 2804,2808 ----
<code>(eq? <var>x</var> <var>y</var>)</code> => <code>(<var>=</var>
<var>x</var> <var>y</var>)</code>.
</div>
+ <p class=continue>
Note that this implies, in turn, that two lists that are <code>eq?</code> are
also set-equal by any legal comparison procedure. This allows for
***************
*** 3143,3147 ****
<p>
I am also grateful the authors, implementors and documentors of all the
systems
! mentioned in the introduction. Aubrey Jaffer and Kent Pitman should be noted
for their work in producing Web-accessible versions of the R5RS and
<a href="#CommonLisp">Common Lisp</a> spec, which was a tremendous aid.
--- 3161,3165 ----
<p>
I am also grateful the authors, implementors and documentors of all the
systems
! mentioned in the rationale. Aubrey Jaffer and Kent Pitman should be noted
for their work in producing Web-accessible versions of the R5RS and
<a href="#CommonLisp">Common Lisp</a> spec, which was a tremendous aid.
***************
*** 3157,3185 ****
<dl>
<dt class=biblio>This document, in HTML:
! <dd><a href="http://srfi.schemers.org/srfi-1/srfi-1.html";>
http://srfi.schemers.org/srfi-1/srfi-1.html</a>
- <br><a class=draft
- href="ftp://ftp.ai.mit.edu/people/shivers/srfi/srfi-1/srfi-1.html";>
- ftp://ftp.ai.mit.edu/people/shivers/srfi/srfi-1/srfi-1.html (draft)</a>
-
- <dt class=biblio>This document, in simple text format:
- <dd><a href="http://srfi.schemers.org/srfi-1/srfi-1.txt";>
- http://srfi.schemers.org/srfi-1/srfi-1.txt</a>
-
- <br><a class=draft
- href="ftp://ftp.ai.mit.edu/people/shivers/srfi/srfi-1/srfi-1.txt";>
- ftp://ftp.ai.mit.edu/people/shivers/srfi/srfi-1/srfi-1.txt (draft)</a>
-
<dt class=biblio>Source code for the reference implementation:
! <dd><a HREF="http://srfi.schemers.org/srfi-1/srfi-1-reference.scm";>
http://srfi.schemers.org/srfi-1/srfi-1-reference.scm</a>
- <br><a class=draft
-
href="ftp://ftp.ai.mit.edu/people/shivers/srfi/srfi-1/srfi-1-reference.scm";>
- ftp://ftp.ai.mit.edu/people/shivers/srfi/srfi-1/srfi-1-reference.scm
(draft)</a>
-
<dt class=biblio>Archive of SRFI-1 discussion-list email:
! <dd><a href="http://srfi.schemers.org/srfi-1/mail-archive/maillist.html";>
http://srfi.schemers.org/srfi-1/mail-archive/maillist.html</a>
--- 3175,3187 ----
<dl>
<dt class=biblio>This document, in HTML:
! <dd><a href="srfi-1.html">
http://srfi.schemers.org/srfi-1/srfi-1.html</a>
<dt class=biblio>Source code for the reference implementation:
! <dd><a HREF="srfi-1-reference.scm">
http://srfi.schemers.org/srfi-1/srfi-1-reference.scm</a>
<dt class=biblio>Archive of SRFI-1 discussion-list email:
! <dd><a href="mail-archive/maillist.html">
http://srfi.schemers.org/srfi-1/mail-archive/maillist.html</a>
Index: string-lib.scm
===================================================================
RCS file: /cvsroot/scsh/scsh/scsh/lib/string-lib.scm,v
retrieving revision 1.2
retrieving revision 1.2.2.1
diff -C2 -r1.2 -r1.2.2.1
*** string-lib.scm 1999/11/03 20:19:12 1.2
--- string-lib.scm 2001/03/11 03:47:00 1.2.2.1
***************
*** 1,52 ****
! ;;; Scheme Underground string-processing library -*- Scheme -*-
! ;;; Olin Shivers 11/98
!
! ;;; SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT
! ;;; This is *draft* code for a SRFI proposal. If you see this notice in
! ;;; production code, you've got obsolete, bad source -- go find the final
! ;;; non-draft code on the Net.
! ;;; SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT -- SRFI DRAFT
!
! ;;; Some of this code had (extremely distant) origins in MIT Scheme's string
[...3148 lines suppressed...]
+ ;;; modification, are permitted provided that the following conditions
+ ;;; are met:
+ ;;; 1. Redistributions of source code must retain the above copyright
+ ;;; notice, this list of conditions and the following disclaimer.
+ ;;; 2. Redistributions in binary form must reproduce the above copyright
+ ;;; notice, this list of conditions and the following disclaimer in the
+ ;;; documentation and/or other materials provided with the distribution.
+ ;;; 3. The name of the authors may not be used to endorse or promote products
+ ;;; derived from this software without specific prior written permission.
+ ;;;
+ ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
+ ;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+ ;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+ ;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+ ;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+ ;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+ ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+ ;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+ ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+ ;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|