srfi-13.scm

Scheme跨平台编译器

;;;; srfi-13.scm - Shivers' reference implementation of SRFI-13


(declare
  (unit srfi-13)
  (uses srfi-14)
  (fixnum)
  (disable-warning redef)
  (hide %string-prefix? %string-hash %finish-string-concatenate-reverse %string-suffix-length %string-prefix-length
	%string-map %string-copy! %string-compare %substring/shared %string-suffix? %multispan-repcopy!
	%string-prefix-length-ci %string-suffix-length-ci %string-prefix-ci? %string-suffix-ci?
	##srfi13#traverse
	%string-titlecase! %string-map! %kmp-search %string-compare-ci ##srfi13#string-fill!)
  (standard-bindings not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr
		     cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
		     cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
		     null? list list? length zero? * - error + / - > < >= <= current-output-port current-input-port
		     write-char newline write display append symbol->string char? char->integer
		     integer->char eof-object? vector-length string-length string-ref string-set! vector-ref 
		     vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol
		     number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact?
		     max min quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact
		     exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=?
		     char-ci<? char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric?
		     char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string<?
		     string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
		     string-append list->string vector? vector->list list->vector string read map for-each
		     read-char substring vector-fill! make-string make-vector open-input-file
		     open-output-file call-with-input-file call-with-output-file close-input-port close-output-port
		     port? values call-with-values vector procedure? memq memv assq assv member assoc) 
  (extended-bindings)
  (disable-interrupts) )

(cond-expand
 [paranoia]
 [else
  (declare
    (no-procedure-checks-for-usual-bindings)
    (bound-to-procedure
     string-concatenate check-substring-spec ##srfi13#string-fill! string-parse-final-start+end
     ##sys#substring string-index-right string-skip-right substring/shared
     string-concatenate/shared make-kmp-restart-vector string-ci= string= char-set?
     char-set-contains? string-fold char-set string-skip string-index string-downcase! char->int
     string-parse-start+end substring-spec-ok?)
    (no-bound-checks) ) ] )

(cond-expand
 [unsafe
  (eval-when (compile)
    (define-macro (##sys#check-structure . _) '(##core#undefined))
    (define-macro (##sys#check-range . _) '(##core#undefined))
    (define-macro (##sys#check-pair . _) '(##core#undefined))
    (define-macro (##sys#check-list . _) '(##core#undefined))
    (define-macro (##sys#check-symbol . _) '(##core#undefined))
    (define-macro (##sys#check-string . _) '(##core#undefined))
    (define-macro (##sys#check-char . _) '(##core#undefined))
    (define-macro (##sys#check-exact . _) '(##core#undefined))
    (define-macro (##sys#check-port . _) '(##core#undefined))
    (define-macro (##sys#check-number . _) '(##core#undefined))
    (define-macro (##sys#check-bytevector . _) '(##core#undefined)) ) ]
 [else
  (declare (emit-exports "srfi-13.exports"))] )

(register-feature! 'srfi-13)


(define-inline (char-cased? c) (char-alphabetic? c))
(define-inline (char-titlecase c) (char-upcase c))


;;; SRFI 13 string library reference implementation		-*- Scheme -*-
;;; Olin Shivers 5/2000
;;;
;;; Copyright (c) 1988-1994 Massachusetts Institute of Technology.
;;; Copyright (c) 1998, 1999, 2000 Olin Shivers. All rights reserved.
;;;   The details of the copyrights appear at the end of the file. Short
;;;   summary: BSD-style open source.

;;; Exports:
;;; 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-copy! substring/shared
;;; string-reverse string-reverse! reverse-list->string
;;; string-concatenate string-concatenate/shared string-concatenate-reverse
;;; string-append/shared
;;; xsubstring string-xcopy!
;;; string-null?
;;; string-join
;;; string-tokenize
;;; string-replace
;;; 
;;; R5RS extended:
;;; string->list string-copy string-fill! 
;;;
;;; R5RS re-exports:
;;; string? make-string string-length string-ref string-set! 
;;;
;;; R5RS re-exports (also defined here but commented-out):
;;; string string-append list->string
;;;
;;; Low-level routines:
;;; 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?

;;; Imports
;;; This is a fairly large library. While it was written for portability, you
;;; must be aware of its dependencies in order to run it in a given scheme
;;; implementation. Here is a complete list of the dependencies it has and the
;;; assumptions it makes beyond stock R5RS Scheme:
;;;
;;; This code has the following non-R5RS dependencies:
;;; - (RECEIVE (var ...) mv-exp body ...) multiple-value binding macro;
;;;
;;; - Various imports from the char-set library for the routines that can
;;;   take char-set arguments;
;;;   
;;; - An n-ary ERROR procedure;
;;;   
;;; - BITWISE-AND for the hash functions;
;;;   
;;; - A simple CHECK-ARG procedure for checking parameter values; it is 
;;;   (lambda (pred val proc) 
;;;     (if (pred val) val (error "Bad arg" val pred proc)))
;;;   
;;; - :OPTIONAL and LET-OPTIONALS* macros for parsing, defaulting & 
;;;   type-checking optional parameters from a rest argument;
;;;   
;;; - CHAR-CASED? and CHAR-TITLECASE for the STRING-TITLECASE & 
;;;   STRING-TITLECASE! procedures. The former returns true iff a character is
;;;   one that has case distinctions; in ASCII it returns true on a-z and A-Z.
;;;   CHAR-TITLECASE is analagous to CHAR-UPCASE and CHAR-DOWNCASE. In ASCII &
;;;   Latin-1, it is the same as CHAR-UPCASE.
;;;
;;; The code depends upon a small set of core string primitives from R5RS:
;;;     MAKE-STRING STRING-REF STRING-SET! STRING? STRING-LENGTH SUBSTRING 
;;; (Actually, SUBSTRING is not a primitive, but we assume that an 
;;; implementation's native version is probably faster than one we could
;;; define, so we import it from R5RS.)
;;;
;;; The code depends upon a small set of R5RS character primitives:
;;;   char? char=? char-ci=? char<? char-ci<?
;;;   char-upcase char-downcase
;;;   char->integer (for the hash functions)
;;;   
;;; We assume the following:
;;; - CHAR-DOWNCASE o CHAR-UPCASE = CHAR-DOWNCASE
;;; - CHAR-CI=? is equivalent to
;;;     (lambda (c1 c2) (char=? (char-downcase (char-upcase c1))
;;;                             (char-downcase (char-upcase c2))))
;;; - CHAR-UPCASE, CHAR-DOWNCASE and CHAR-TITLECASE are locale-insensitive
;;;   and consistent with Unicode's 1-1 char-mapping spec.
;;; These things are typically true, but if not, you would need to modify
;;; the case-mapping and case-insensitive routines.

;;; Enough introductory blather. On to the source code. (But see the end of
;;; the file for further notes on porting & performance tuning.)


;;; Support for START/END substring specs
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(eval-when (compile eval)
  (define-macro (let-string-start+end2 s-e proc s1 s2 args . body)
    (let ([procv (gensym)]
	  [rest (gensym)] )
      `(let ((,procv ,proc))
	 (let-string-start+end 
	  (,(car s-e) ,(cadr s-e) ,rest) ,procv ,s1 ,args
	  (let-string-start+end 
	   ,(cddr s-e) ,procv ,s2 ,rest
	   ,@body) ) ) ) ) )


;;; Returns three values: rest start end

(define (string-parse-start+end proc s args)
  (##sys#check-string s 'string-parse-start+end)
  (let ((slen (string-length s)))
    (if (pair? args)

	(let ((start (car args))
	      (args (cdr args)))
;	  (if (and (integer? start) (exact? start) (>= start 0))
	  (if (and (fixnum? start) (>= start 0))
	      (receive (end args)
		  (if (pair? args)
		      (let ((end (car args))
			    (args (cdr args)))
;			(if (and (integer? end) (exact? end) (<= end slen))
			(if (and (fixnum? end) (<= end slen))
			    (values end args)
			    (##sys#error 'string-parse-start+end "Illegal substring END spec" proc end s)))
		      (values slen args))
		(if (<= start end) (values args start end)
		    (##sys#error 'string-parse-start+end "Illegal substring START/END spec"
			   proc start end s)))
	      (##sys#error 'string-parse-start+end "Illegal substring START spec" proc start s)))

	(values '() 0 slen))))

(define (string-parse-final-start+end proc s args)
  (receive (rest start end) (string-parse-start+end proc s args)
    (if (pair? rest) (##sys#error 'string-parse-final-start+end "Extra arguments to procedure" proc rest)
	(values start end))))

(define (substring-spec-ok? s start end)
  (and (string? s)
;       (integer? start)
;       (exact? start)
;       (integer? end)
;       (exact? end)
       (fixnum? start)
       (fixnum? end)
       (<= 0 start)
       (<= start end)
       (<= end (string-length s))))

(define (check-substring-spec proc s start end)
  (if (not (substring-spec-ok? s start end))
      (##sys#error 'check-substring-spec "Illegal substring spec." proc s start end)))


;;; Defined by R5RS, so commented out here.
;(define (string . chars)
;  (let* ((len (length chars))
;         (ans (make-string len)))
;    (do ((i 0 (+ i 1))
;	 (chars chars (cdr chars)))
;	((>= i len))
;      (string-set! ans i (car chars)))
;    ans))
;
;(define (string . chars) (string-unfold null? car cdr chars))



;;; substring/shared S START [END] 
;;; string-copy      S [START END]
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; All this goop is just arg parsing & checking surrounding a call to the
;;; actual primitive, %SUBSTRING/SHARED.

(define (substring/shared s start . maybe-end)
;  (check-arg string? s substring/shared)
  (let ((slen (string-length s)))
;    (check-arg (lambda (start) (and (integer? start) (exact? start) (<= 0 start)))
;	       start substring/shared)
    (let ([n (:optional maybe-end slen)])
      (##sys#check-exact n 'substring/shared)
      (check-substring-spec 'substring/shared s start n)
      (%substring/shared s start n) ) ) )
#|
    (%substring/shared s start
		       (:optional maybe-end slen
				  (lambda (end) (and (integer? end)
						     (exact? end)
						     (<= start end)
						     (<= end slen)))))))
|#

;;; Split out so that other routines in this library can avoid arg-parsing
;;; overhead for END parameter.
(define (%substring/shared s start end)
  (if (and (zero? start) (= end (string-length s))) s
      (##sys#substring s start end)))

(define (string-copy s . maybe-start+end)
  (let-string-start+end (start end) string-copy s maybe-start+end
    (##sys#substring s start end)))

;This library uses the R5RS SUBSTRING, but doesn't export it.
;Here is a definition, just for completeness.
;(define (substring s start end)
;  (check-substring-spec substring s start end)
;  (let* ((slen (- end start))
;         (ans (make-string slen)))
;    (do ((i 0 (+ i 1))
;         (j start (+ j 1)))
;        ((>= i slen) ans)
;      (string-set! ans i (string-ref s j)))))

;;; Basic iterators and other higher-order abstractions
;;; (string-map proc s [start end])
;;; (string-map! proc s [start end])
;;; (string-fold kons knil s [start end])
;;; (string-fold-right kons knil s [start end])
;;; (string-unfold       p f g seed [base make-final])
;;; (string-unfold-right p f g seed [base make-final])
;;; (string-for-each       proc s [start end])
;;; (string-for-each-index proc s [start end])
;;; (string-every char-set/char/pred s [start end])
;;; (string-any   char-set/char/pred s [start end])
;;; (string-tabulate len proc)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; You want compiler support for high-level transforms on fold and unfold ops.
;;; You'd at least like a lot of inlining for clients of these procedures.
;;; Don't hold your breath.
;;;
;;; Shut up, Olin.

(define (string-map proc s . maybe-start+end)
;  (check-arg procedure? proc string-map)
  (let-string-start+end (start end) string-map s maybe-start+end
    (%string-map proc s start end)))

(define (%string-map proc s start end)	; Internal utility
  (let* ((len (- end start))
	 (ans (make-string len)))
    (do ((i 0 (+ i 1))
	 (j start (+ j 1)))
	((>= i len))
      (string-set! ans i (proc (string-ref s j))))
    ans))

(define (string-map! proc s . maybe-start+end)
;  (check-arg procedure? proc string-map!)
  (let-string-start+end (start end) string-map! s maybe-start+end
    (%string-map! proc s start end)))

(define (%string-map! proc s start end)
  (do ((i start (+ i 1)))
      ((>= i end) s)