From: Chris Hanson Date: Fri, 17 Feb 2017 06:17:15 +0000 (-0800) Subject: Move all legacy-string definitions into ustring. X-Git-Tag: mit-scheme-pucked-9.2.12~220^2~88 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=e4b546c1856144c97a109108621e63c49698ea6f;p=mit-scheme.git Move all legacy-string definitions into ustring. This is preparation for moving all the old string code elsewhere. --- diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 04b209a00..c10caa10c 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1004,36 +1004,6 @@ USA. (parent (runtime)) (export-deprecated () ;ignored on 9.2 hosts (guarantee-vector-8b guarantee-string) - (legacy-string string) - (legacy-string->list string->list) - (legacy-string->vector string->vector) - (legacy-string-append string-append) - (legacy-string-capitalize string-capitalize) - (legacy-string-ci<=? string-ci<=?) - (legacy-string-ci=? string-ci>=?) - (legacy-string-ci>? string-ci>?) - (legacy-string-copy string-copy) - (legacy-string-copy! string-copy!) - (legacy-string-downcase string-downcase) - (legacy-string-fill! string-fill!) - (legacy-string-for-each string-for-each) - (legacy-string-hash string-hash) - (legacy-string-length string-length) - (legacy-string-map string-map) - (legacy-string-ref string-ref) - (legacy-string-set! string-set!) - (legacy-string-upcase string-upcase) - (legacy-string<=? string<=?) - (legacy-string=? string>=?) - (legacy-string>? string>?) - (legacy-string? string?) - (legacy-substring substring) - (list->legacy-string list->string) - (make-legacy-string make-string) (set-vector-8b-length! set-string-length!) (vector-8b-length string-length) (vector-8b-maximum-length string-maximum-length) @@ -1053,36 +1023,6 @@ USA. vector-8b-set!) (export () ;temporary duplicate for 9.2 hosts (guarantee-vector-8b guarantee-string) - (legacy-string string) - (legacy-string->list string->list) - (legacy-string->vector string->vector) - (legacy-string-append string-append) - (legacy-string-capitalize string-capitalize) - (legacy-string-ci<=? string-ci<=?) - (legacy-string-ci=? string-ci>=?) - (legacy-string-ci>? string-ci>?) - (legacy-string-copy string-copy) - (legacy-string-copy! string-copy!) - (legacy-string-downcase string-downcase) - (legacy-string-fill! string-fill!) - (legacy-string-for-each string-for-each) - (legacy-string-hash string-hash) - (legacy-string-length string-length) - (legacy-string-map string-map) - (legacy-string-ref string-ref) - (legacy-string-set! string-set!) - (legacy-string-upcase string-upcase) - (legacy-string<=? string<=?) - (legacy-string=? string>=?) - (legacy-string>? string>?) - (legacy-string? string?) - (legacy-substring substring) - (list->legacy-string list->string) - (make-legacy-string make-string) (set-vector-8b-length! set-string-length!) (vector-8b-length string-length) (vector-8b-maximum-length string-maximum-length) @@ -1280,11 +1220,15 @@ USA. ;; vector->ustring ) (export (runtime bytevector) + legacy-string? + make-legacy-string ustring->legacy-string) (export (runtime predicate-metadata) register-ustring-predicates!) (export (runtime symbol) - %ustring*)) + %ustring* + legacy-string-downcase + legacy-string?)) (define-package (runtime bytevector) (files "bytevector") diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm index 414db4c4b..9000b7279 100644 --- a/src/runtime/ustring.scm +++ b/src/runtime/ustring.scm @@ -257,6 +257,85 @@ USA. (utf32-string-set! result i (car chars))) result)))) +;;;; Legacy strings + +(define-primitives + (legacy-string-length string-length 1) + (legacy-string-ref string-ref 2) + (legacy-string-set! string-set! 3) + (legacy-string? string? 1) + (make-legacy-string string-allocate 1)) + +(define (legacy-string-fill! string char #!optional start end) + (let* ((end (fix:end-index end (legacy-string-length string) 'string-fill!)) + (start (fix:start-index start end 'string-fill!))) + (do ((index start (fix:+ index 1))) + ((not (fix:< index end)) unspecific) + (legacy-string-set! string index char)))) + +(define legacy-string-copy + (x-copy-maker legacy-string-length legacy-string-ref make-legacy-string + legacy-string-set! 'string-copy)) + +(define legacy-string-copy! + (x-copy!-maker legacy-string-length legacy-string-ref legacy-string-set! + 'string-copy!)) + +(define (legacy-string->list string #!optional start end) + (let* ((end (fix:end-index end (legacy-string-length string) 'string->list)) + (start (fix:start-index start end 'string->list))) + (let loop ((index (fix:- end 1)) (chars '())) + (if (fix:<= start index) + (loop (fix:- index 1) (cons (legacy-string-ref string index) chars)) + chars)))) + +(define legacy-string->vector + (x-copy-maker legacy-string-length legacy-string-ref make-vector vector-set! + 'string->vector)) + +(define (legacy-string-find-first-index proc string #!optional start end) + (let* ((caller 'legacy-string-find-next-index) + (end (fix:end-index end (legacy-string-length string) caller)) + (start (fix:start-index start end caller))) + (let loop ((i start)) + (and (fix:< i end) + (if (proc (legacy-string-ref string i)) + i + (loop (fix:+ i 1))))))) + +(define (legacy-string-find-last-index proc string #!optional start end) + (let* ((caller 'legacy-string-find-last-index) + (end (fix:end-index end (legacy-string-length string) caller)) + (start (fix:start-index start end caller))) + (let loop ((i (fix:- end 1))) + (and (fix:>= i start) + (if (proc (legacy-string-ref string i)) + i + (loop (fix:- i 1))))))) + +(define (legacy-string-downcase string) + (let ((end (legacy-string-length string))) + (let ((string* (make-legacy-string end))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i end)) + (legacy-string-set! string* i + (char-downcase (legacy-string-ref string i)))) + string*))) + +(define (legacy-string-upcase string) + (let ((end (legacy-string-length string))) + (let ((string* (make-legacy-string end))) + (do ((i 0 (fix:+ i 1))) + ((fix:= i end)) + (legacy-string-set! string* i + (char-upcase (legacy-string-ref string i)))) + string*))) + +(define (legacy-string-hash key #!optional modulus) + (if (default-object? modulus) + ((ucode-primitive string-hash) key) + ((ucode-primitive string-hash-mod) key modulus))) + ;;;; String (define (ustring? object) @@ -264,6 +343,7 @@ USA. (utf32-string? object))) (define (register-ustring-predicates!) + (register-predicate! legacy-string? 'legacy-string) (register-predicate! utf32-string? 'utf32-string) (register-predicate! ustring? 'ustring) (set-predicate<=! legacy-string? ustring?) @@ -605,26 +685,6 @@ USA. (else (error:not-a ustring? string 'ustring-find-last-index)))) -(define (legacy-string-find-first-index proc string #!optional start end) - (let* ((caller 'legacy-string-find-next-index) - (end (fix:end-index end (legacy-string-length string) caller)) - (start (fix:start-index start end caller))) - (let loop ((i start)) - (and (fix:< i end) - (if (proc (legacy-string-ref string i)) - i - (loop (fix:+ i 1))))))) - -(define (legacy-string-find-last-index proc string #!optional start end) - (let* ((caller 'legacy-string-find-last-index) - (end (fix:end-index end (legacy-string-length string) caller)) - (start (fix:start-index start end caller))) - (let loop ((i (fix:- end 1))) - (and (fix:>= i start) - (if (proc (legacy-string-ref string i)) - i - (loop (fix:- i 1))))))) - (define (ustring-find-first-char string char #!optional start end) (ustring-find-first-index (char=-predicate char) string start end))