Rename a bunch of make-string references to make-legacy-string.
(image (image/create window image-width image-height))
(pixels
(if use-string?
- (make-string (fix:* image-width image-height))
+ (make-legacy-string (fix:* image-width image-height))
(make-vector (fix:* image-width image-height))))
(write-pixel (if use-string? vector-8b-set! vector-set!))
(py-max (- pic-height 1))
(error:bad-range-argument string
"a string of no more than 72 characters"
'blowfish-set-key))
- (let ((result (make-string (C-sizeof "BF_KEY"))))
+ (let ((result (make-legacy-string (C-sizeof "BF_KEY"))))
(C-call "BF_set_key" result length string)
result)))
(define (blowfish-encrypt-port input output key init-vector encrypt?)
;; Assumes that INPUT is in blocking mode.
(let ((key (blowfish-set-key key))
- (input-buffer (make-string 4096))
- (output-buffer (make-string 4096)))
+ (input-buffer (make-legacy-string 4096))
+ (output-buffer (make-legacy-string 4096)))
(dynamic-wind
(lambda ()
unspecific)
;; This init vector includes a timestamp with a resolution of
;; milliseconds, plus 20 random bits. This should make it very
;; difficult to generate two identical vectors.
- (let ((iv (make-string 8)))
+ (let ((iv (make-legacy-string 8)))
(do ((i 0 (fix:+ i 1))
(t (+ (* (+ (* (get-universal-time) 1000)
(remainder (real-time-clock) 1000))
(define (read-blowfish-file-header port)
(let ((line (read-line port)))
(cond ((string=? blowfish-file-header-v1 line)
- (make-string 8 #\NUL))
+ (make-legacy-string 8 #\NUL))
((string=? blowfish-file-header-v2 line)
- (let ((init-vector (make-string 8)))
+ (let ((init-vector (make-legacy-string 8)))
(if (not (= 8 (read-string! init-vector port)))
(error "Short read while getting init-vector:" port))
init-vector))
)
(parent ())
- (import (runtime parser)
- (param:parser-associate-positions?
- runtime-param:parser-associate-positions?)
- (param:parser-fold-case? runtime-param:parser-fold-case?)
- (param:parser-radix runtime-param:parser-radix)
- (param:parser-table runtime-param:parser-table)
- get-param:parser-fold-case?)
- (import (runtime character)
- bucky-bits->prefix)
- (import (runtime char-syntax)
- char-syntax-table/entries)
(import (runtime)
define-primitives
ucode-primitive
ucode-type)
+ (import (runtime char-syntax)
+ char-syntax-table/entries)
+ (import (runtime character)
+ bucky-bits->prefix)
(import (runtime microcode-tables)
fixed-objects-item
update-fixed-objects-item!)
+ (import (runtime parser)
+ (param:parser-associate-positions?
+ runtime-param:parser-associate-positions?)
+ (param:parser-fold-case? runtime-param:parser-fold-case?)
+ (param:parser-radix runtime-param:parser-radix)
+ (param:parser-table runtime-param:parser-table)
+ get-param:parser-fold-case?)
(import (runtime port)
(make-port make-textual-port)
(make-port-type make-textual-port-type)
(port/output-channel output-port-channel)
(port/state textual-port-state)
generic-port-operation:write-substring)
- (export (edwin class-macros)
- class-instance-transforms)
+ (import (runtime string)
+ (make-string make-legacy-string))
(export ()
create-editor
create-editor-args
reset-editor
reset-editor-windows
(save-editor-files debug-save-files)
- spawn-edwin))
+ spawn-edwin)
+ (export (edwin class-macros)
+ class-instance-transforms))
(define-package (edwin class-macros)
(files "clsmac")
encrypt?)
;; Assumes that INPUT is in blocking mode.
(let ((context (mcrypt-open-module algorithm mode))
- (input-buffer (make-string 4096))
- (output-buffer (make-string 4096)))
+ (input-buffer (make-legacy-string 4096))
+ (output-buffer (make-legacy-string 4096)))
(mcrypt-init context key init-vector)
(dynamic-wind
(lambda ()
(define (%md5-init)
;; Create and return an MD5 digest context.
- (let ((context (make-string (C-sizeof "MD5_CTX"))))
+ (let ((context (make-legacy-string (C-sizeof "MD5_CTX"))))
(C-call "MD5_INIT" context)
context))
(define (%md5-final context)
;; Finalize CONTEXT and return the digest as a 16-byte string.
(guarantee-md5-context context '%MD5-FINAL)
- (let ((result (make-string (C-enum "MD5_DIGEST_LENGTH"))))
+ (let ((result (make-legacy-string (C-enum "MD5_DIGEST_LENGTH"))))
(C-call "do_MD5_FINAL" context result)
result))
;; The digest is returned as a 16-byte string.
(guarantee-string string '%MD5)
(let ((length (string-length string))
- (result (make-string (C-enum "MD5_DIGEST_LENGTH"))))
+ (result (make-legacy-string (C-enum "MD5_DIGEST_LENGTH"))))
(C-call "do_MD5" string length result)
result))
(define (md5-file filename)
(call-with-legacy-binary-input-file filename
(lambda (port)
- (let ((buffer (make-string 4096))
+ (let ((buffer (make-legacy-string 4096))
(context (%md5-init)))
(dynamic-wind (lambda ()
unspecific)
(define (md5-sum->hexadecimal sum)
(let ((n (string-length sum))
(digits "0123456789abcdef"))
- (let ((s (make-string (fix:* 2 n))))
+ (let ((s (make-legacy-string (fix:* 2 n))))
(do ((i 0 (fix:+ i 1)))
((fix:= i n))
(string-set! s (fix:* 2 i)
(lambda (alien)
(let* ((id (mhash-context-id context))
(size (C-call "mhash_get_block_size" id))
- (digest (make-string size)))
+ (digest (make-legacy-string size)))
(C-call "do_mhash_end" alien digest size)
(remove-context-cleanup context)
digest))))
(lambda (alien)
(let* ((id (mhash-hmac-context-id context))
(size (C-call "mhash_get_block_size" id))
- (digest (make-string size)))
+ (digest (make-legacy-string size)))
(C-call "do_mhash_hmac_end" alien digest size)
(remove-hmac-context-cleanup context)
digest))))
(keyword-size (mhash-keygen-type-key-length type)))
(let ((params (salted-keygen-params
keygenid (mhash-keygen-type-parameter-vector type) salt))
- (keyword (make-string keyword-size))
+ (keyword (make-legacy-string keyword-size))
(max-key-size (C-call "mhash_get_keygen_max_key_size" keygenid)))
(define (hashid-map params i)
(define (mhash-file hash-type filename)
(call-with-legacy-binary-input-file filename
(lambda (port)
- (let ((buffer (make-string 4096))
+ (let ((buffer (make-legacy-string 4096))
(context (mhash-init hash-type)))
(dynamic-wind (lambda ()
unspecific)
(define (mhash-sum->hexadecimal sum)
(let ((n (string-length sum))
(digits "0123456789abcdef"))
- (let ((s (make-string (fix:* 2 n))))
+ (let ((s (make-legacy-string (fix:* 2 n))))
(do ((i 0 (fix:+ i 1)))
((fix:= i n))
(string-set! s (fix:* 2 i)
dbt))
(define (make-dbt)
- (make-string dbt-length))
+ (make-legacy-string dbt-length))
(define rc:db_notfound
(db4:name->rc 'db_notfound))
(cond ((= rc rc:db_notfound)
#f)
((= rc rc:enomem)
- (let ((string (make-string (db4:dbt-size datum))))
+ (let ((string (make-legacy-string (db4:dbt-size datum))))
(db4:init-dbt datum string #f #f)
(pcall db4:db-get db txn key datum flags)
string))
((= rc 0)
- (make-string 0))
+ (make-legacy-string 0))
(else
(bdb-error rc 'db4:db-get))))))
(define (bdb-get-partial db txn key flags start length)
- (let ((string (make-string length)))
+ (let ((string (make-legacy-string length)))
(let ((rc
(db4:db-get (bdb-handle db)
(and txn (bdb-txn-handle txn))
(pcall db4:db-env-lock-id-free (bdb-env-handle env) id))
(define (bdb-env-lock-get env id flags object lock-mode)
- (let ((lock (make-string db-lock-length)))
+ (let ((lock (make-legacy-string db-lock-length)))
(pcall db4:db-env-lock-get
(bdb-env-handle env)
id
(define (blowfish-encrypt-port input output key init-vector encrypt?)
;; Assumes that INPUT is in blocking mode.
(let ((key (blowfish-set-key key))
- (input-buffer (make-string 4096))
- (output-buffer (make-string 4096)))
+ (input-buffer (make-legacy-string 4096))
+ (output-buffer (make-legacy-string 4096)))
(dynamic-wind
(lambda ()
unspecific)
;; This init vector includes a timestamp with a resolution of
;; milliseconds, plus 20 random bits. This should make it very
;; difficult to generate two identical vectors.
- (let ((iv (make-string 8)))
+ (let ((iv (make-legacy-string 8)))
(do ((i 0 (fix:+ i 1))
(t (+ (* (+ (* (get-universal-time) 1000)
(remainder (real-time-clock) 1000))
(define (read-blowfish-file-header port)
(let ((line (read-line port)))
(cond ((string=? blowfish-file-header-v1 line)
- (make-string 8 #\NUL))
+ (make-legacy-string 8 #\NUL))
((string=? blowfish-file-header-v2 line)
- (let ((init-vector (make-string 8)))
+ (let ((init-vector (make-legacy-string 8)))
(if (not (= 8 (read-string! init-vector port)))
(error "Short read while getting init-vector:" port))
init-vector))
(define-integrable buffer-read 4096)
(define-structure (bb (constructor make-byte-buffer ()))
- (vector (make-string buffer-size) read-only true)
+ (vector (make-legacy-string buffer-size) read-only true)
(ptr 0)
(end 0)
(eof? false))
(set-oldest state (oldest-node state) pointer))))
(define (make-output-buffer)
- (cons 0 (make-string 4096)))
+ (cons 0 (make-legacy-string 4096)))
(define (write-byte state byte)
(let ((ob (output-buffer state)))
(if (not (mhash-keygen-type? type))
(error:wrong-type-argument type "mhash type" 'MHASH-KEYGEN))
(let ((id (mhash-keygen-type-id type))
- (keyword (make-string (mhash-keygen-type-key-length type)))
+ (keyword (make-legacy-string (mhash-keygen-type-key-length type)))
(v (mhash-keygen-type-parameter-vector type)))
(if (not ((ucode-primitive mhash_keygen 4)
id
(define (mhash-file hash-type filename)
(call-with-legacy-binary-input-file filename
(lambda (port)
- (let ((buffer (make-string 4096))
+ (let ((buffer (make-legacy-string 4096))
(context (mhash-init hash-type)))
(dynamic-wind (lambda ()
unspecific)
(define (mhash-sum->hexadecimal sum)
(let ((n (string-length sum))
(digits "0123456789abcdef"))
- (let ((s (make-string (fix:* 2 n))))
+ (let ((s (make-legacy-string (fix:* 2 n))))
(do ((i 0 (fix:+ i 1)))
((fix:= i n))
(string-set! s (fix:* 2 i)
(define (%md5-file filename)
(call-with-legacy-binary-input-file filename
(lambda (port)
- (let ((buffer (make-string 4096))
+ (let ((buffer (make-legacy-string 4096))
(context ((ucode-primitive md5-init 0))))
(dynamic-wind (lambda ()
unspecific)
encrypt?)
;; Assumes that INPUT is in blocking mode.
(let ((context (mcrypt-open-module algorithm mode))
- (input-buffer (make-string 4096))
- (output-buffer (make-string 4096)))
+ (input-buffer (make-legacy-string 4096))
+ (output-buffer (make-legacy-string 4096)))
(mcrypt-init context key init-vector)
(dynamic-wind
(lambda ()
(buffer-length 8192))
(if (zero? source-length)
0
- (let* ((buffer (make-string buffer-length))
+ (let* ((buffer (make-legacy-string buffer-length))
(transfer
(lambda (length)
(let ((n-read
((< k+1-l (- n))
(scientific-output digits k radix 0))
((negative? k)
- (string-append "." (make-string (- k+1) #\0) digits))
+ (string-append "." (make-legacy-string (- k+1) #\0) digits))
((negative? k+1-l)
(string-append (string-head digits k+1)
"."
(string-tail digits k+1)))
((<= k n)
- (string-append digits (make-string k+1-l #\0) "."))
+ (string-append digits (make-legacy-string k+1-l #\0) "."))
(else
(scientific-output digits k radix 0))))))
(cond ((= l 0)
(string-append "0e" exponent))
((< l i)
- (string-append digits (make-string (- i l) #\0) "e" exponent))
+ (string-append digits (make-legacy-string (- i l) #\0) "e" exponent))
((= l i)
(string-append digits "e" exponent))
(else
(if %trace? (%outf-error . MSG)))))
(define (tindent)
- (make-string (* 2 (length calloutback-stack)) #\space))
+ (make-legacy-string (* 2 (length calloutback-stack)) #\space))
(define (%outf-error . msg)
(apply outf-error `("; ",@msg"\n")))
\ No newline at end of file
read-substring)
(define-integrable input-size 4096)
(let ((cp-table (make-vector window-size))
- (input-buffer (make-string input-size)))
+ (input-buffer (make-legacy-string input-size)))
(define (displacement->cp-index displacement cp)
(let ((index (fix:- cp displacement)))
(string-set! s2 i2 (string-ref s1 i1))))
(let parse-command ((bp 0) (cp 0) (ip 0) (ip-end 0)
- (buffer (make-string buffer-size))
+ (buffer (make-legacy-string buffer-size))
(buffer-size buffer-size))
;; Invariant: (SUBTRING BUFFER IP IP-END) is unprocessed input.
(define (retry-with-bigger-output-buffer)
(let* ((new-size (fix:+ buffer-size (fix:quotient buffer-size 4)))
- (nbuffer (make-string new-size)))
+ (nbuffer (make-legacy-string new-size)))
(substring-move! buffer 0 buffer-size nbuffer 0)
(parse-command bp cp ip ip-end nbuffer new-size)))
(lambda (input)
(let* ((file-marker "Compressed-B1-1.00")
(marker-size (string-length file-marker))
- (actual-marker (make-string marker-size)))
+ (actual-marker (make-legacy-string marker-size)))
;; This may get more hairy as we up versions
(if (and (fix:= (uncompress-read-substring input
actual-marker 0 marker-size)
(guarantee index-fixnum? k 'read-string)
(let ((port (optional-input-port port 'read-string)))
(if (fix:> k 0)
- (let ((string (make-ustring k)))
+ (let ((string (make-string k)))
(let ((n (input-port/read-string! port string)))
(cond ((not n) n)
((fix:> n 0) (if (fix:< n k) (string-head string n) string))
(header (string-append kryptid (get-krypt-time-string) "\n"))
(hlen (string-length header))
(output-string
- (make-string
+ (make-legacy-string
(fix:+ 6 (fix:+ hlen (string-length input-string)))))
(end-index (fix:- (string-length output-string) ts)))
(let ((key1 (make-krypt-key)))
(rcm-keyinit key1)
(rcm-key key1 header)
(rcm-key key1 password)
- (let ((passwordmac (make-string 5 #\NUL)))
+ (let ((passwordmac (make-legacy-string 5 #\NUL)))
(rcm key1 5 passwordmac)
(substring-move! header 0 hlen output-string 0)
(substring-move! passwordmac 0 5 output-string hlen)
(rcm-keyinit key1)
(rcm-key key1 header)
(rcm-key key1 password)
- (let ((passwordmac (make-string 5 #\NUL)))
+ (let ((passwordmac (make-legacy-string 5 #\NUL)))
(rcm key1 5 passwordmac)
(if (string=? passwordmac pwordmac)
(begin
(call-with-legacy-binary-input-file pathname
(lambda (port)
(let ((n (vector-ref (gc-space-status) 0)))
- (let ((marker (make-string n)))
+ (let ((marker (make-legacy-string n)))
(and (eqv? (read-string! marker port) n)
(let loop ((i 0))
(if (fix:< i n)
(if (fix:< start end)
(if pending
(let ((s
- (make-string
+ (make-legacy-string
(fix:+ (string-length pending) (fix:- end start)))))
(substring-move! string start end
s (string-move! pending s 0))
(define hex-char-table)
(define hex-digit-table)
-(let ((char-table (make-string 256 (integer->char #xff)))
- (digit-table (make-string 16)))
+(let ((char-table (make-legacy-string 256 (integer->char #xff)))
+ (digit-table (make-legacy-string 16)))
(define (do-range low high value)
(do-char low value)
(if (fix:< low high)
(constructor encode-base64:initialize (port text?)))
(port #f read-only #t)
(text? #f read-only #t)
- (buffer (make-string 48) read-only #t)
+ (buffer (make-legacy-string 48) read-only #t)
(index 0))
(define (encode-base64:finalize context)
(constructor decode-base64:initialize (port text?)))
(port #f read-only #t)
(text? #f read-only #t)
- (input-buffer (make-string 4) read-only #t)
+ (input-buffer (make-legacy-string 4) read-only #t)
(input-index 0)
;; Ugh bletch. Add state to look for line starting with NON-BASE64
;; character, and stop decoding there. This works around problem
;; that arises when mail-processing agents randomly glue text on the
;; end of a MIME message.
(input-state 'LINE-START)
- (output-buffer (make-string 3) read-only #t)
+ (output-buffer (make-legacy-string 3) read-only #t)
(pending-return? #f))
(define (decode-base64:finalize context)
(define base64-char-table)
(define base64-digit-table)
-(let ((char-table (make-string 256 (integer->char #xff)))
- (digit-table (make-string 64)))
+(let ((char-table (make-legacy-string 256 (integer->char #xff)))
+ (digit-table (make-legacy-string 64)))
(define (do-range low high value)
(do-char low value)
(if (fix:< low high)
(port #f read-only #t)
(state 'SEEKING-COMMENT)
(line-buffer "")
- (input-buffer (make-string 4) read-only #t)
+ (input-buffer (make-legacy-string 4) read-only #t)
(input-index 0)
- (output-buffer (make-string 3) read-only #t))
+ (output-buffer (make-legacy-string 3) read-only #t))
(define (decode-binhex40:initialize port text?)
text? ;ignored
"!\"#$%&\'()*+,-012345689@ABCDEFGHIJKLMNPQRSTUVXYZ[`abcdefhijklmpqr")
(define binhex40-char-table
- (make-string 256 (integer->char #xff)))
+ (make-legacy-string 256 (integer->char #xff)))
(do ((code 0 (fix:+ code 1)))
((fix:= code 64))
(if (fix:= index 0)
(begin
(set-binhex40-decon/header!
- state (make-string (fix:+ 22 (char->integer char))))
+ state (make-legacy-string (fix:+ 22 (char->integer char))))
(set-binhex40-decon/index! state 1))
(let ((header (binhex40-decon/header state)))
(string-set! header index char)
text?
(let ((state 'BEGIN)
(line-buffer (make-line-buffer 256))
- (output-buffer (make-string 3)))
+ (output-buffer (make-legacy-string 3)))
(define (update string start end)
(if (and (not (eq? state 'FINISHED))
(finalize uudecode-ctx-finalize))
(define (make-line-buffer n-max)
- (let ((s (make-string n-max)))
+ (let ((s (make-legacy-string n-max)))
(set-string-length! s 0)
(cons n-max s)))
(let loop ((n-max (fix:* n-max 2)))
(if (fix:< n-max m)
(loop (fix:* n-max 2))
- (let ((s* (make-string n-max)))
+ (let ((s* (make-legacy-string n-max)))
(substring-move! s 0 n s* 0)
(set-string-length! s* m)
(set-cdr! line-buffer s*))))
(define (line-buffer-contents line-buffer)
(let ((contents (cdr line-buffer))
- (s (make-string (car line-buffer))))
+ (s (make-legacy-string (car line-buffer))))
(set-string-length! s 0)
(set-cdr! line-buffer s)
contents))
(substring<? (car s1) 0 (cdr s1)
(car s2) 0 (cdr s2)))))))
(let ((result
- (make-string
+ (make-legacy-string
(reduce +
0
(map (lambda (s) (fix:+ (string-length s) 1))
(define (rewrite-args/no-quoting strings)
(if (pair? strings)
(let ((result
- (make-string
+ (make-legacy-string
(fix:+ (reduce +
0
(map (lambda (s) (string-length s)) strings))
(cons (if need-quotes? (fix:+ k 2) k)
need-quotes?)))))
(let ((analyses (map analyze-arg strings)))
- (let ((result (make-string (reduce + 0 (map car analyses)))))
+ (let ((result (make-legacy-string (reduce + 0 (map car analyses)))))
(define (do-arg index s analysis)
(if (cdr analysis)
(begin
(pathname-default-type
((make-primitive-procedure 'SCHEME-PROGRAM-NAME))
"exe"))))
- (buf (make-string 256)))
+ (buf (make-legacy-string 256)))
(substring buf 0 ((access get-module-file-name env) handle buf 256)))))
(define (os/shell-file-name)
(not prefix)
(and (string? prefix)
(fix:= 0 (string-length prefix))))
- (make-parser-buffer (make-ustring min-length) 0 0 0 0 port #f 0)
+ (make-parser-buffer (make-string min-length) 0 0 0 0 port #f 0)
(let ((n (string-length prefix)))
(make-parser-buffer (%grow-buffer prefix n (fix:max min-length n))
0 n 0 0 port #f 0))))
(let ((n (string-length string)))
(if (and (fix:> n min-length)
(fix:<= end* (fix:quotient n 4)))
- (make-ustring (fix:quotient n 2))
+ (make-string (fix:quotient n 2))
string))))
(without-interruption
(lambda ()
(define (%grow-buffer string end min-length)
(let ((new-string
- (make-ustring
+ (make-string
(let loop ((n (string-length string)))
(if (fix:<= min-length n)
n
(define (random-byte-vector n #!optional state)
(let ((state (get-random-state state 'RANDOM-BYTE-VECTOR))
- (s (make-string n)))
+ (s (make-vector-8b n)))
(do ((i 0 (fix:+ i 1)))
((fix:= i n))
(vector-8b-set! s i (small-random-integer 256 state)))
(loop (cdr ranges)
(fix:+ n (if (pair? (car ranges)) 3 1)))
n))))
- (let ((s (make-string n)))
+ (let ((s (make-legacy-string n)))
(string-set! s 0 #\[)
(let loop ((ranges ranges) (i 1))
(if (pair? ranges)
;;;; Translation Tables
(define re-translation-table
- (let ((normal-table (make-string 256)))
+ (let ((normal-table (make-legacy-string 256)))
(let loop ((n 0))
(if (< n 256)
(begin
(let ((invert?
(and (input-match? (input-peek ctx) #\^)
(begin (input-discard! ctx) #t)))
- (charset (make-string 32 (integer->char 0))))
+ (charset (make-legacy-string 32 (integer->char 0))))
(if (input-end? ctx)
(premature-end ctx))
(let loop
guarantee-string
guarantee-string-index
hexadecimal->vector-8b
+ make-legacy-string
make-vector-8b
vector-8b->hexadecimal
vector-8b-fill!
guarantee-string
guarantee-string-index
hexadecimal->vector-8b
+ make-legacy-string
make-vector-8b
vector-8b->hexadecimal
vector-8b-fill!
guarantee-substring-end-index
guarantee-substring-start-index
lisp-string->camel-case
- make-string
reverse-string
reverse-substring
set-string-length!
(export ()
(substring string-copy)
list->string
- make-ustring
+ make-string
string
string*
string->list
\f
;;;; Basic Operations
-(define (make-string length #!optional char)
- (guarantee-string-index length 'MAKE-STRING)
- (if (default-object? char)
- (string-allocate length)
- (begin
- (guarantee-char char 'MAKE-STRING)
- (let ((result (string-allocate length)))
- (substring-fill! result 0 length char)
- result))))
+(define (make-legacy-string k #!optional char)
+ (let ((string (string-allocate k)))
+ (if (not (default-object? char))
+ (begin
+ (guarantee 8-bit-char? char 'make-legacy-string)
+ (string-fill! string char)))
+ string))
(define (make-vector-8b length #!optional ascii)
- (make-string length (if (default-object? ascii) ascii (integer->char ascii))))
+ (make-legacy-string length
+ (if (default-object? ascii)
+ ascii
+ (integer->char ascii))))
(define (string-maximum-length string)
(guarantee-string string 'STRING-MAXIMUM-LENGTH)
(define (%reverse-substring string start end)
(let ((n (fix:- end start)))
- (let ((result (make-string n)))
+ (let ((result (make-legacy-string n)))
(do ((i start (fix:+ i 1))
(j (fix:- n 1) (fix:- j 1)))
((fix:= i end))
(string-ref "0123456789abcdef" (fix:and k #x0F)))
(guarantee-string bytes 'VECTOR-8B->HEXADECIMAL)
(let ((n (vector-8b-length bytes)))
- (let ((s (make-string (fix:* 2 n))))
+ (let ((s (make-legacy-string (fix:* 2 n))))
(do ((i 0 (fix:+ i 1))
(j 0 (fix:+ j 2)))
((not (fix:< i n)))
(if nonblock?
(set-output-port-blocking-mode! port 'nonblocking))
(receiver
- (let ((buffer (make-ustring bsize)))
+ (let ((buffer (make-string bsize)))
(lambda ()
(with-input-port-blocking-mode process-input 'BLOCKING
(lambda ()
(let ((input-port/open? (port/operation port 'INPUT-OPEN?))
(input-port/close (port/operation port 'CLOSE-INPUT)))
(if process-output
- (let ((buffer (make-ustring bsize)))
+ (let ((buffer (make-string bsize)))
(let ((copy-output
(lambda ()
(let ((n (input-port/read-string! port buffer)))
(buffer-length 8192))
(if (zero? source-length)
0
- (let* ((buffer (make-string buffer-length))
+ (let* ((buffer (make-legacy-string buffer-length))
(transfer
(lambda (length)
(let ((n-read
(full-string? object)
(slice? object)))
-(define (make-ustring k #!optional char)
- (guarantee index-fixnum? k 'make-ustring)
+(define (make-string k #!optional char)
+ (guarantee index-fixnum? k 'make-string)
(if (fix:> k 0)
(make-full-string k char)
(legacy-string-allocate 0)))
(delete-value! key name))
(define (win32/expand-environment-strings string)
- (let ((result (make-string (win32-expand-environment-strings string ""))))
+ (let ((result
+ (make-legacy-string (win32-expand-environment-strings string ""))))
(win32-expand-environment-strings string result)
(let ((nul (string-find-next-char result #\nul)))
(if nul
(let* ((handle (guarantee-handle key))
(buffer-length
(vector-ref (win32-query-info-registry-key handle) length-index))
- (buffer (make-string buffer-length)))
+ (buffer (make-legacy-string buffer-length)))
(let loop ((index 0) (vs '()))
(let ((v (enumerator handle index buffer)))
(if v
x-left y-bottom x-right y-top ;
x-scale y-scale
-
+
fg-color bg-color
pen-valid?
line-width line-style
(hdc (get-dc hwnd))
(bitmap-dc)
(bitmap))
-
+
(if palette
(select-palette hdc palette #f))
(set! bitmap-dc (create-compatible-dc hdc))
(if palette
(select-palette bitmap-dc palette #f))
- (set! bitmap
+ (set! bitmap
(create-compatible-bitmap hdc (win32-device/width window)
(win32-device/height window)))
(if palette
(realize-palette hdc))
-
+
(set-win32-device/bitmap! window bitmap)
(set-win32-device/hwnd! window hwnd)
(set-win32-device/hdc! window bitmap-dc)
;; windows and closing them with the close button; the result is
;; the BSOD.
0)
-
+
((= msg WM_DESTROY)
(let ((bitmap-dc (win32-device/hdc window)))
(if (not (eqv? 0 bitmap-dc))
(realize-palette hdc)
(realize-palette (win32-device/hdc window))
))
- (bit-blt hdc 0 0
+ (bit-blt hdc 0 0
(win32-device/width window) (win32-device/height window)
(win32-device/hdc window) 0 0 SRCCOPY)
(end-paint hwnd ps))
(release-dc hwnd hdc)
))
0)
-
+
((and (= msg WM_PALETTEISCHANGING) (win32-device/palette window))
(default))
-
+
((and (= msg WM_QUERYNEWPALETTE) (win32-device/palette window))
(update-palette))
(else
(default)))))
-
(define (make-standard-palette)
- (define pal (make-string (+ 4 (* 4 256))))
+ (define pal (make-legacy-string (+ 4 (* 4 256))))
(define i 0)
(define (alloc r g b f)
(let ((base (fix:+ 4 (fix:* i 4))))
)
(define (make-grayscale-palette)
- (define pal (make-string (+ 4 (* 4 256))))
+ (define pal (make-legacy-string (+ 4 (* 4 256))))
(define i 0)
(define (alloc r g b f)
(let ((base (fix:+ 4 (fix:* i 4))))
(create-palette pal)
)
-
(define (make-grayscale-128-palette)
- (define pal (make-string (+ 4 (* 4 256))))
+ (define pal (make-legacy-string (+ 4 (* 4 256))))
(define i 0)
(define (alloc r g b f)
(let ((base (fix:+ 4 (fix:* i 4))))
(loop (+ i 1)))))))))
(define (convert-palette external)
- (let ((s (make-string (+ 4 (* 4 256))))
+ (let ((s (make-legacy-string (+ 4 (* 4 256))))
(n-entries (vector-length external)))
(vector-8b-set! s 0 #x00)
(vector-8b-set! s 1 #x03)
(define device-protection-list)
-(define (win32-graphics/open descriptor->device
+(define (win32-graphics/open descriptor->device
#!optional width height palette)
(let* ((width (if (default-object? width) 512 width))
(height (if (default-object? height) 512 height))
(old-pen (select-object hdc new-pen)))
(delete-object old-pen)
(set-win32-device/pen-valid?! window #t)))
-
+
(define-integrable (win32-device/validate-pen window)
(if (not (win32-device/pen-valid? window))
(win32-device/select-pen window)))
(set-win32-device/y-scale! window
(/ (- (win32-device/height window) 1)
(- (win32-device/y-bottom window) (win32-device/y-top window)))))
-
+
(define (win32-translate-drawing-mode mode)
(case mode ;X11 function names:
(( 0) R2_BLACK) ;GXclear
(text-out hdc xt yt text (string-length text))
(win32-device/invalidate! window)
unspecific))
-
+
(define (win32-graphics/move-cursor device x y)
(let ((window (graphics-device/descriptor device)))
(define (make-C-point-vector window vec)
(let* ((n (vector-length vec))
- (s (make-string (* 4 n))))
+ (s (make-legacy-string (* 4 n))))
(define (loop i)
(if (fix:< i n)
(begin
(set! h heightt)))
(bit-blt hdc x1 y1 w h hdc x0 y0 SRCCOPY)
-
+
(win32-device/invalidate! window)
unspecific))
("pink" 255 181 197)
("brown" 127 63 0)))
-
+
(define (win32-graphics/set-foreground-color device color)
(let* ((window (graphics-device/descriptor device))
(hdc (win32-device/hdc window))
(hwnd (win32-device/hwnd window)))
(set-window-pos hwnd 0 x y 0 0
(+ SWP_NOZORDER SWP_NOSIZE SWP_NOACTIVATE))))
-
+
(define (win32-graphics/resize-window device w h)
(let* ((window (graphics-device/descriptor device))
(hwnd (win32-device/hwnd window)))
(client-width->window-width w)
(client-height->window-height h)
(+ SWP_NOZORDER SWP_NOMOVE SWP_NOACTIVATE))))
-
+
(define (win32-graphics/set-font device font)
(let* ((window (graphics-device/descriptor device))
(hdc (win32-device/hdc window)))
(define (make-message-polling-loop)
- (define msg (make-string 40))
+ (define msg (make-legacy-string 40))
(define (message-polling-loop)
(if (peek-message msg 0 0 0 1 #|PM_REMOVE|#)
(begin
(define-integrable (set-rect/bottom! r v) (int32-offset-set! (rect/mem r) 12 v))
(define (make-rect left top right bottom)
- (define r (%make-rect (make-string 16)))
+ (define r (%make-rect (make-legacy-string 16)))
(set-rect/left! r left)
(set-rect/top! r top)
(set-rect/right! r right)
(byte-offset-set! (paintstruct/mem r) 28 (bool->int v)))
(define (make-paintstruct)
- (define r (%make-paintstruct (make-string 64)))
+ (define r (%make-paintstruct (make-legacy-string 64)))
r)
(define-windows-type paintstruct
(char->integer #\backspace)))
(char->string #\Delete))
((> nbytes 0)
- (let ((s (make-string nbytes)))
+ (let ((s (make-legacy-string nbytes)))
(c-peek-bytes buffer 0 nbytes s 0)
s))
(else ""))
(define (char-ptr-to-prop-data-8 data length)
(let ((scan (copy-alien data))
- (result (make-string length)))
+ (result (make-legacy-string length)))
(let loop ((index 0))
(if (< index length)
(begin
;; Get the contents of the terminal screen rectangle as a string.
;; The string contains alternating (CHARACTER, HIGHLIGHT) pairs.
;; The pairs are organized in row-major order from (X-START, Y-START).
- (let* ((string (make-string (* 2
- (- x-end x-start)
- (- y-end y-start))))
+ (let* ((string (make-legacy-string (* 2
+ (- x-end x-start)
+ (- y-end y-start))))
(code (c-call "xterm_save_contents"
xterm x-start x-end y-start y-end string)))
(case code
(j-limit (quotient n-bits-in-file n-bits-per-integer))
(i-limit (quotient n-bits-per-integer 8)))
(let ((j-dot (quotient j-limit n-progress-dots))
- (buffer (make-string i-limit)))
+ (buffer (make-legacy-string i-limit)))
(do ((j 0 (+ j 1)))
((= j j-limit))
(if (= 0 (remainder j j-dot))
(declare (usual-integrations))
\f
(define (test-noop length iterations)
- (let ((from (make-string length))
- (to (make-string (fix:* 2 length))))
+ (let ((from (make-legacy-string length))
+ (to (make-legacy-string (fix:* 2 length))))
(do ((i 0 (fix:+ i 1)))
((fix:= i iterations)))))
(define (test-left length iterations)
- (let ((from (make-string length))
- (to (make-string (fix:* 2 length))))
+ (let ((from (make-legacy-string length))
+ (to (make-legacy-string (fix:* 2 length))))
(do ((i 0 (fix:+ i 1)))
((fix:= i iterations))
(substring-move-left! from 0 length to length))))
(define (test-right length iterations)
- (let ((from (make-string length))
- (to (make-string (fix:* 2 length))))
+ (let ((from (make-legacy-string length))
+ (to (make-legacy-string (fix:* 2 length))))
(do ((i 0 (fix:+ i 1)))
((fix:= i iterations))
(substring-move-right! from 0 length to length))))
(define (test-inline length iterations)
- (let ((from (make-string length))
- (to (make-string (fix:* 2 length))))
+ (let ((from (make-legacy-string length))
+ (to (make-legacy-string (fix:* 2 length))))
(do ((i 0 (fix:+ i 1)))
((fix:= i iterations))
(do ((fi 0 (fix:+ fi 1))
(builder)))
(define (chars->string chars)
- (let ((s (make-ustring (length chars))))
+ (let ((s (make-string (length chars))))
(do ((chars chars (cdr chars))
(i 0 (fix:+ i 1)))
((not (pair? chars)))
projects / mit-scheme.git / commitdiff