srfi-14.scm

Scheme跨平台编译器

;;; 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)
  (##sys#check-exact cursor 'char-set-cursor-next)
;  (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)
  (##sys#check-string str 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)
  (##sys#check-exact lower proc)
  (##sys#check-exact upper 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?)
      (##sys#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 (##sys#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))


;;; -- Invert

(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)))