381 lines
14 KiB
Scheme
381 lines
14 KiB
Scheme
|
(define-interface string-lib-interface
|
||
|
|
(export
|
||
|
|
;; string-map proc s [start end] -> s
|
||
|
|
(string-map (proc ((proc (:char) :char)
|
||
|
|
:string
|
||
|
|
&opt :exact-integer :exact-integer)
|
||
|
|
:string))
|
||
|
|
|
||
|
|
;; string-map! proc s [start end] -> unspecific
|
||
|
|
(string-map! (proc ((proc (:char) :values)
|
||
|
|
:string
|
||
|
|
&opt :exact-integer :exact-integer)
|
||
|
|
:unspecific))
|
||
|
|
|
||
|
|
;; string-fold kons knil s [start end] -> value
|
||
|
|
;; string-fold-right kons knil s [start end] -> value
|
||
|
|
((string-fold string-fold-right)
|
||
|
|
(proc ((proc (:char :value) :value)
|
||
|
|
:value :string
|
||
|
|
&opt :exact-integer :exact-integer)
|
||
|
|
:value))
|
||
|
|
|
||
|
|
;; string-unfold p f g seed -> string
|
||
|
|
(string-unfold (proc ((proc (:value) :boolean)
|
||
|
|
(proc (:value) :char)
|
||
|
|
(proc (:value) :value)
|
||
|
|
:value)
|
||
|
|
:string))
|
||
|
|
|
||
|
|
; Enough is enough.
|
||
|
|
; ;; string-unfoldn p f g seed ... -> string
|
||
|
|
; (string-unfoldn (proc ((procedure :values :boolean)
|
||
|
|
; (procedure :values :char)
|
||
|
|
; (procedure :values :values)
|
||
|
|
; &rest :value)
|
||
|
|
; :string))
|
||
|
|
|
||
|
|
;; string-tabulate proc len -> string
|
||
|
|
(string-tabulate (proc ((proc (:exact-integer) :char) :exact-integer)
|
||
|
|
:string))
|
||
|
|
|
||
|
|
;; string-for-each proc s [start end] -> unspecific
|
||
|
|
;; string-iter proc s [start end] -> unspecific
|
||
|
|
((string-for-each string-iter)
|
||
|
|
(proc ((proc (:char) :values) :string &opt :exact-integer :exact-integer)
|
||
|
|
:unspecific))
|
||
|
|
|
||
|
|
;; string-every? pred s [start end]
|
||
|
|
;; string-any pred s [start end]
|
||
|
|
(string-every?
|
||
|
|
(proc ((proc (:char) :boolean) :string &opt :exact-integer :exact-integer)
|
||
|
|
:boolean))
|
||
|
|
(string-any
|
||
|
|
(proc ((proc (:char) :boolean) :string &opt :exact-integer :exact-integer)
|
||
|
|
:value))
|
||
|
|
|
||
|
|
;; string-compare string1 string2 lt-proc eq-proc gt-proc
|
||
|
|
;; string-compare-ci string1 string2 lt-proc eq-proc gt-proc
|
||
|
|
((string-compare string-compare-ci)
|
||
|
|
(proc (:string :string (proc (:exact-integer) :values)
|
||
|
|
(proc (:exact-integer) :values)
|
||
|
|
(proc (:exact-integer) :values))
|
||
|
|
:values))
|
||
|
|
|
||
|
|
;; substring-compare string1 start1 end1 string2 start2 end2 lt eq gt
|
||
|
|
;; substring-compare-ci string1 start1 end1 string2 start2 end2 lt eq gt
|
||
|
|
((substring-compare substring-compare-ci)
|
||
|
|
(proc (:string :exact-integer :exact-integer
|
||
|
|
:string :exact-integer :exact-integer
|
||
|
|
(proc (:exact-integer) :values)
|
||
|
|
(proc (:exact-integer) :values)
|
||
|
|
(proc (:exact-integer) :values))
|
||
|
|
:values))
|
||
|
|
|
||
|
|
;; string< string1 string2
|
||
|
|
((string= string< string> string<= string>= string<>
|
||
|
|
string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<>)
|
||
|
|
(proc (&rest :string) :value))
|
||
|
|
|
||
|
|
;; substring< string1 start1 end1 string2 start2 end2
|
||
|
|
((substring= substring<> substring-ci= substring-ci<>
|
||
|
|
substring< substring> substring-ci< substring-ci>
|
||
|
|
substring<= substring>= substring-ci<= substring-ci>=)
|
||
|
|
(proc (:string :exact-integer :exact-integer
|
||
|
|
:string :exact-integer :exact-integer)
|
||
|
|
:value))
|
||
|
|
|
||
|
|
;; string-upper-case? string [start end]
|
||
|
|
;; string-lower-case? string [start end]
|
||
|
|
((string-upper-case? string-lower-case?)
|
||
|
|
(proc (:string &opt :exact-integer :exact-integer) :boolean))
|
||
|
|
|
||
|
|
;; capitalize-string string [start end]
|
||
|
|
;; capitalize-words string [start end]
|
||
|
|
;; string-downcase string [start end]
|
||
|
|
;; string-upcase string [start end]
|
||
|
|
;; capitalize-string! string [start end]
|
||
|
|
;; capitalize-words! string [start end]
|
||
|
|
;; string-downcase! string [start end]
|
||
|
|
;; string-upcase! string [start end]
|
||
|
|
((capitalize-string capitalize-words string-downcase string-upcase)
|
||
|
|
(proc (:string &opt :exact-integer :exact-integer) :string))
|
||
|
|
((capitalize-string! capitalize-words! string-downcase! string-upcase!)
|
||
|
|
(proc (:string &opt :exact-integer :exact-integer) :unspecific))
|
||
|
|
|
||
|
|
;; string-take string nchars
|
||
|
|
;; string-drop string nchars
|
||
|
|
((string-take string-drop) (proc (:string :exact-integer) :string))
|
||
|
|
|
||
|
|
;; string-padl string k [char start end]
|
||
|
|
;; string-padr string k [char start end]
|
||
|
|
((string-padl string-padr)
|
||
|
|
(proc (:string :exact-integer &opt :char :exact-integer :exact-integer)
|
||
|
|
:string))
|
||
|
|
|
||
|
|
;; string-trim string [char/char-set/pred start end]
|
||
|
|
;; string-triml string [char/char-set/pred start end]
|
||
|
|
;; string-trimr string [char/char-set/pred start end]
|
||
|
|
((string-trim string-triml string-trimr)
|
||
|
|
(proc (:string &opt :value :exact-integer :exact-integer)
|
||
|
|
:string))
|
||
|
|
|
||
|
|
;; string-filter char/char-set/pred string [start end]
|
||
|
|
;; string-delete char/char-set/pred string [start end]
|
||
|
|
((string-filter string-delete)
|
||
|
|
(proc (:value :string &opt :exact-integer :exact-integer) :string))
|
||
|
|
|
||
|
|
;; string-index string char/char-set/pred [start end]
|
||
|
|
;; string-index-right string char/char-set/pred [end start]
|
||
|
|
;; string-skip string char/char-set/pred [start end]
|
||
|
|
;; string-skip-right string char/char-set/pred [end start]
|
||
|
|
((string-index string-index-right string-skip string-skip-right)
|
||
|
|
(proc (:string :value &opt :exact-integer :exact-integer)
|
||
|
|
:value))
|
||
|
|
|
||
|
|
;; string-prefix-count string1 string2
|
||
|
|
;; string-suffix-count string1 string2
|
||
|
|
;; string-prefix-count-ci string1 string2
|
||
|
|
;; string-suffix-count-ci string1 string2
|
||
|
|
((string-prefix-count string-prefix-count-ci
|
||
|
|
string-suffix-count string-suffix-count-ci)
|
||
|
|
(proc (:string :string) :exact-integer))
|
||
|
|
|
||
|
|
;; substring-prefix-count string1 start1 end1 string2 start2 end2
|
||
|
|
;; substring-suffix-count string1 start1 end1 string2 start2 end2
|
||
|
|
;; substring-prefix-count-ci string1 start1 end1 string2 start2 end2
|
||
|
|
;; substring-suffix-count-ci string1 start1 end1 string2 start2 end2
|
||
|
|
((substring-prefix-count substring-prefix-count-ci
|
||
|
|
substring-suffix-count substring-suffix-count-ci)
|
||
|
|
(proc (:string :exact-integer :exact-integer
|
||
|
|
:string :exact-integer :exact-integer)
|
||
|
|
:exact-integer))
|
||
|
|
|
||
|
|
|
||
|
|
;; string-prefix? string1 string2
|
||
|
|
;; string-suffix? string1 string2
|
||
|
|
;; string-prefix-ci? string1 string2
|
||
|
|
;; string-suffix-ci? string1 string2
|
||
|
|
((string-prefix? string-prefix-ci?
|
||
|
|
string-suffix? string-suffix-ci?)
|
||
|
|
(proc (:string :string) :boolean))
|
||
|
|
|
||
|
|
;; substring-prefix? string1 start1 end1 string2 start2 end2
|
||
|
|
;; substring-suffix? string1 start1 end1 string2 start2 end2
|
||
|
|
;; substring-prefix-ci? string1 start1 end1 string2 start2 end2
|
||
|
|
;; substring-suffix-ci? string1 start1 end1 string2 start2 end2
|
||
|
|
((substring-prefix? substring-prefix-ci?
|
||
|
|
substring-suffix? substring-suffix-ci?)
|
||
|
|
(proc (:string :exact-integer :exact-integer
|
||
|
|
:string :exact-integer :exact-integer)
|
||
|
|
:boolean))
|
||
|
|
|
||
|
|
;; substring? pattern string [start end]
|
||
|
|
;; substring-ci? pattern string [start end]
|
||
|
|
((substring? substring-ci?)
|
||
|
|
(proc (:string :string &opt :exact-integer :exact-integer)
|
||
|
|
:value))
|
||
|
|
|
||
|
|
;; string-fill! string char [start end]
|
||
|
|
(string-fill! (proc (:string :char &opt :exact-integer :exact-integer)
|
||
|
|
:unspecific))
|
||
|
|
|
||
|
|
;; string-copy! to tstart from [fstart fend]
|
||
|
|
(string-copy! (proc (:string :exact-integer :string
|
||
|
|
&opt :exact-integer :exact-integer)
|
||
|
|
:unspecific))
|
||
|
|
|
||
|
|
;; string-copy s [start end] -> string
|
||
|
|
;; substring s start [end] -> string
|
||
|
|
(string-copy (proc (:string &opt :exact-integer :exact-integer) :string))
|
||
|
|
(substring (proc (:string :exact-integer &opt :exact-integer) :string))
|
||
|
|
|
||
|
|
;; string-reverse s [start end]
|
||
|
|
;; string-reverse! s [start end]
|
||
|
|
(string-reverse (proc (:string &opt :exact-integer :exact-integer) :string))
|
||
|
|
(string-reverse! (proc (:string &opt :exact-integer :exact-integer) :unspecific))
|
||
|
|
|
||
|
|
;; reverse-list->string char-list
|
||
|
|
;; string->list s [start end]
|
||
|
|
;; string-concat string-list
|
||
|
|
;; string-concat/shared string-list
|
||
|
|
;; string-append/shared s ...
|
||
|
|
(reverse-list->string (proc (:value) :string))
|
||
|
|
(string->list (proc (:string &opt :exact-integer :exact-integer) :value))
|
||
|
|
((string-concat string-concat/shared) (proc (:value) :string))
|
||
|
|
(string-append/shared (proc (&rest :string) :string))
|
||
|
|
|
||
|
|
;; xsubstring s from [to start end]
|
||
|
|
;; string-xcopy! target tstart s from [to start end]
|
||
|
|
(xsubstring (proc (:string :exact-integer &opt
|
||
|
|
:exact-integer :exact-integer :exact-integer)
|
||
|
|
:string))
|
||
|
|
(string-xcopy! (proc (:string :exact-integer :string :exact-integer &opt
|
||
|
|
:exact-integer :exact-integer :exact-integer)
|
||
|
|
:unspecific))
|
||
|
|
|
||
|
|
;; string-null? s
|
||
|
|
(string-null? (proc (:string) :boolean))
|
||
|
|
|
||
|
|
(join-strings (proc (:value &opt :string :symbol) :string))
|
||
|
|
|
||
|
|
;; Here are the R4RS procs
|
||
|
|
(string? (proc (:value) :boolean))
|
||
|
|
(make-string (proc (:exact-integer &opt :char) :string))
|
||
|
|
(string (proc (&rest :char) :string))
|
||
|
|
(string-length (proc (:string) :exact-integer))
|
||
|
|
(string-ref (proc (:string :exact-integer) :char))
|
||
|
|
(string-set! (proc (:string :exact-integer :char) :unspecific))
|
||
|
|
|
||
|
|
; Not provided by string-lib.
|
||
|
|
;((string=? string-ci=? string<? string-ci<?
|
||
|
|
; string>? string-ci>? string<=? string-ci<=?
|
||
|
|
; string>=? string-ci>=?) (proc (:string :string) :boolean))
|
||
|
|
|
||
|
|
;; These are the R4RS types for SUBSTRING, STRING-COPY, STRING-FILL!,
|
||
|
|
;; and STRING->LIST. The string-lib types are different -- extended.
|
||
|
|
;(substring (proc (:string :exact-integer :exact-integer) :string))
|
||
|
|
;(string-copy (proc (:string) :string))
|
||
|
|
;(string-fill! (proc (:string :char) :unspecific))
|
||
|
|
;(string->list (proc (:string) :value))
|
||
|
|
|
||
|
|
(string-append (proc (&rest :string) :string))
|
||
|
|
(list->string (proc (:value) :string))
|
||
|
|
))
|
||
|
|
|
||
|
|
|
||
|
|
(define-interface string-lib-internals-interface
|
||
|
|
(export
|
||
|
|
(parse-final-start+end (proc ((procedure :values :values) :string :value)
|
||
|
|
(some-values :exact-integer :exact-integer)))
|
||
|
|
(parse-start+end (proc ((procedure :values :values) :string :value)
|
||
|
|
(some-values :exact-integer :exact-integer :value)))
|
||
|
|
(check-substring-spec (proc ((procedure :values :values) :string :exact-integer :exact-integer)
|
||
|
|
:unspecific))
|
||
|
|
(make-kmp-restart-vector (proc (:string (proc (:char :char) :boolean))
|
||
|
|
:vector))))
|
||
|
|
|
||
|
|
|
||
|
|
(define-structures ((string-lib string-lib-interface)
|
||
|
|
(string-lib-internals string-lib-internals-interface))
|
||
|
|
(open char-set-package
|
||
|
|
receiving
|
||
|
|
error-package
|
||
|
|
let-opt
|
||
|
|
structure-refs
|
||
|
|
scsh-utilities ; FOLD-RIGHT
|
||
|
|
scheme)
|
||
|
|
(access scheme ; Original SUBSTRING
|
||
|
|
silly) ; Primitive reverse-list->string
|
||
|
|
(files stringlib)
|
||
|
|
(optimize auto-integrate))
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
;;; CPP Lib
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;; Character->Character Partial functions
|
||
|
|
|
||
|
|
;;; Many of these types are pretty weak, but there is no way to
|
||
|
|
;;; specify that a parameter must be a particular record type.
|
||
|
|
;;; Every little bit helps, though.
|
||
|
|
|
||
|
|
(define-interface ccp-lib-interface
|
||
|
|
(export
|
||
|
|
;; ccp? x -> boolean
|
||
|
|
(ccp? (proc (:value) :boolean))
|
||
|
|
|
||
|
|
;; ccp-domain ccp -> char-set
|
||
|
|
(ccp-domain (proc (:value) :value)) ; Not very informative.
|
||
|
|
|
||
|
|
;; ccp-copy ccp -> ccp
|
||
|
|
(ccp-copy (proc (:value) :value))
|
||
|
|
|
||
|
|
;; ccp= ccp1 ccp2 ...
|
||
|
|
;; ccp<= ccp1 ccp2 ...
|
||
|
|
((ccp= ccp<=) (proc (&rest :value) :boolean)) ; Not very informative.
|
||
|
|
|
||
|
|
;; ccp-fold kons knil ccp -> value
|
||
|
|
(ccp-fold (proc ((proc (:char :char :value) :value) :value :value) :value))
|
||
|
|
|
||
|
|
;; ccp-for-each proc ccp
|
||
|
|
(ccp-for-each (proc ((proc (:char :char) :values)) :unspecific))
|
||
|
|
|
||
|
|
;; ccp->alist ccp -> alist
|
||
|
|
(ccp->alist (proc (:value) :value))
|
||
|
|
|
||
|
|
;; ccp-restrict ccp cset -> ccp
|
||
|
|
;; ccp-restrict! ccp cset -> ccp
|
||
|
|
((ccp-restrict ccp-restrict!) (proc (:value :value) :value))
|
||
|
|
|
||
|
|
;; ccp-adjoin ccp from-char1 to-char1 ... -> ccp
|
||
|
|
;; ccp-adjoin! ccp from-char1 to-char1 ... -> ccp
|
||
|
|
;; ccp-delete ccp from-char1 ... -> ccp
|
||
|
|
;; ccp-delete! ccp from-char1 ... -> ccp
|
||
|
|
((ccp-adjoin ccp-adjoin!) (proc (:value &rest :char) :value))
|
||
|
|
((ccp-delete ccp-delete!) (proc (:value &rest :char) :value))
|
||
|
|
|
||
|
|
;; ccp-extend ccp1 ... -> ccp
|
||
|
|
;; ccp-extend! ccp1 ... -> ccp
|
||
|
|
((ccp-extend ccp-extend!) (proc (&rest :value) :value))
|
||
|
|
|
||
|
|
;; ccp-compose ccp1 ... -> ccp
|
||
|
|
(ccp-compose (proc (&rest :value) :value))
|
||
|
|
|
||
|
|
;; alist->ccp char/char-alist [ccp] -> ccp
|
||
|
|
;; alist->ccp! char/char-alist [ccp] -> ccp
|
||
|
|
((alist->ccp alist->ccp!) (proc (:value &opt :value) :value))
|
||
|
|
|
||
|
|
;; proc->ccp proc [domain ccp] -> ccp
|
||
|
|
;; proc->ccp! proc [domain ccp] -> ccp
|
||
|
|
((proc->ccp proc->ccp!) (proc ((proc (:char) :char) &opt :value :value)
|
||
|
|
:value))
|
||
|
|
|
||
|
|
;; constant-ccp char [domain ccp] -> ccp
|
||
|
|
;; constant-ccp! char domain ccp -> ccp
|
||
|
|
((constant-ccp constant-ccp!) (proc (:char &opt :value :value) :value))
|
||
|
|
|
||
|
|
;; ccp/mappings from1 to1 ... -> ccp
|
||
|
|
;; extend-ccp/mappings ccp from1 to1 ... -> ccp
|
||
|
|
;; extend-ccp/mappings! ccp from1 to1 ... -> ccp
|
||
|
|
(ccp/mappings (proc (&rest :value) :value))
|
||
|
|
((extend-ccp/mappings extend-ccp/mappings!)
|
||
|
|
(proc (:value &rest :value) :value))
|
||
|
|
|
||
|
|
;; construct-ccp ccp elt ... -> ccp
|
||
|
|
;; construct-ccp! ccp elt ... -> ccp
|
||
|
|
((construct-ccp construct-ccp!) (proc (:value &rest :value) :value))
|
||
|
|
|
||
|
|
;; ccp-unfold p f g seed -> ccp
|
||
|
|
(ccp-unfold (proc ((proc (:value) :boolean)
|
||
|
|
(procedure :value (some-values :char :char))
|
||
|
|
(proc (:value) :value)
|
||
|
|
:value)
|
||
|
|
:value))
|
||
|
|
|
||
|
|
;; tr ccp string [start end] -> string
|
||
|
|
;; ccp-map ccp string [start end] -> string
|
||
|
|
;; ccp-map! ccp string [start end]
|
||
|
|
;; ccp-app ccp char -> char or false
|
||
|
|
((tr ccp-map)
|
||
|
|
(proc (:value :string &opt :exact-integer :exact-integer) :string))
|
||
|
|
(ccp-map! (proc (:value :string &opt :exact-integer :exact-integer) :unspecific))
|
||
|
|
(ccp-app (proc (:value :char) :value))
|
||
|
|
|
||
|
|
;; Primitive CCP's.
|
||
|
|
ccp:0 ccp:1 ccp:upcase ccp:downcase
|
||
|
|
))
|
||
|
|
|
||
|
|
(define-structure ccp-lib ccp-lib-interface
|
||
|
|
(open char-set-package
|
||
|
|
ascii
|
||
|
|
defrec-package
|
||
|
|
string-lib
|
||
|
|
let-opt
|
||
|
|
receiving
|
||
|
|
scsh-utilities ; every
|
||
|
|
error-package
|
||
|
|
scheme)
|
||
|
|
(files ccp)
|
||
|
|
(optimize auto-integrate))
|