From: Matt Birkholz Date: Sat, 29 Apr 2017 20:50:14 +0000 (-0700) Subject: Merge branch 'master' into pucked. X-Git-Tag: mit-scheme-pucked-9.2.12~148 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=494a58c10d06ae9361ad5343a9fbfb99860787df;p=mit-scheme.git Merge branch 'master' into pucked. Ported changes in src/runtime/crypto.scm to the md5, mhash and mcrypt plugins. --- 494a58c10d06ae9361ad5343a9fbfb99860787df diff --cc src/imail/imail-mime.scm index 4a6128e66,066865591..3c39a971f --- a/src/imail/imail-mime.scm +++ b/src/imail/imail-mime.scm @@@ -370,10 -370,8 +370,10 @@@ USA (mime:get-content-description header-fields) (mime:get-content-transfer-encoding header-fields) (- end start) - (ignore-errors (lambda () (md5-string string start end)) + (ignore-errors (lambda () + (load-option 'md5) - (md5-substring string start end)) - (lambda (condition) condition #f)) ++ (md5-string string start end)) + (lambda (condition) condition #f)) (mime:get-content-disposition header-fields) (mime:get-content-language header-fields)))) diff --cc src/mcrypt/mcrypt.scm index 5aae9cfd4,5aae9cfd4..c091f291f --- a/src/mcrypt/mcrypt.scm +++ b/src/mcrypt/mcrypt.scm @@@ -165,26 -165,26 +165,38 @@@ USA (make-alien '(const (* char))) code))))))) ++(define-integrable (make-mcrypt-transform! name fname procedure) ++ (lambda (context bytes start end) ++ (guarantee-mcrypt-context context name) ++ (let ((code (procedure context bytes start end))) ++ (if (< code 0) ++ (error (string-append "Error code signalled by "fname":") ++ code))))) ++ ++(define mcrypt-encrypt! ++ (make-mcrypt-transform! ++ 'mcrypt-encrypt! "mcrypt_generic" ++ (lambda (context bytes start end) ++ (let ((alien (mcrypt-context-alien context))) ++ (C-call "scmcrypt_generic" alien bytes start end))))) ++ ++(define mcrypt-decrypt! ++ (make-mcrypt-transform! ++ 'mcrypt-decrypt! "mdecrypt_generic" ++ (lambda (context bytes start end) ++ (let ((alien (mcrypt-context-alien context))) ++ (C-call "scmdecrypt_generic" alien bytes start end))))) ++ (define (mcrypt-encrypt context input input-start input-end output output-start encrypt?) -- (guarantee-mcrypt-context context 'MCRYPT-ENCRYPT) ++ (guarantee-mcrypt-context context 'mcrypt-encrypt) (guarantee bytevector? input 'mcrypt-encrypt) (guarantee bytevector? output 'mcrypt-encrypt) -- (bytevector-copy! output output-start input input-start input-end) -- (let ((code -- (let ((alien (mcrypt-context-alien context)) -- (start output-start) -- (end (+ output-start (- input-end input-start)))) -- (if encrypt? -- (C-call "scmcrypt_generic" alien output start end) -- (C-call "scmdecrypt_generic" alien output start end))))) -- (if (< code 0) -- (error (string-append "Error code signalled by " -- (if encrypt? -- "mcrypt_generic" -- "mdecrypt_generic") -- ":") -- code)))) ++ ((if encrypt? mcrypt-encrypt! mcrypt-decrypt!) ++ context ++ output ++ output-start ++ (bytevector-copy! output output-start input input-start input-end))) (define (mcrypt-end context) (let ((alien (mcrypt-context-alien context))) @@@ -199,7 -199,7 +211,7 @@@ (lambda (object) (cond ((mcrypt-context? object) (context-op object)) -- ((string? object) ++ ((bytevector? object) (init!) (module-op object)) (else @@@ -207,7 -207,7 +219,7 @@@ (define mcrypt-self-test (mcrypt-generic-unary -- 'MCRYPT-SELF-TEST ++ 'mcrypt-self-test (named-lambda (mcrypt-enc-self-test context) (C-call "mcrypt_enc_self_test" (mcrypt-context-alien context))) (named-lambda (mcrypt-module-self-test module-name) @@@ -215,7 -215,7 +227,7 @@@ (define mcrypt-block-algorithm-mode? (mcrypt-generic-unary -- 'MCRYPT-BLOCK-ALGORITHM-MODE? ++ 'mcrypt-block-algorithm-mode? (named-lambda (mcrypt-enc-is-block-algorithm-mode? context) (C-call "mcrypt_enc_is_block_algorithm_mode" (mcrypt-context-alien context))) @@@ -224,7 -224,7 +236,7 @@@ (define mcrypt-block-algorithm? (mcrypt-generic-unary -- 'MCRYPT-BLOCK-ALGORITHM? ++ 'mcrypt-block-algorithm? (named-lambda (mcrypt-enc-is-block-algorithm context) (C-call "mcrypt_enc_is_block_algorithm" (mcrypt-context-alien context))) @@@ -233,7 -233,7 +245,7 @@@ (define mcrypt-block-mode? (mcrypt-generic-unary -- 'MCRYPT-BLOCK-MODE? ++ 'mcrypt-block-mode? (named-lambda (mcrypt-enc-is-block-mode context) (C-call "mcrypt_enc_is_block_mode" (mcrypt-context-alien context))) @@@ -242,7 -242,7 +254,7 @@@ (define mcrypt-key-size (mcrypt-generic-unary -- 'MCRYPT-KEY-SIZE ++ 'mcrypt-key-size (named-lambda (mcrypt-enc-get-key-size context) (C-call "mcrypt_enc_get_key_size" (mcrypt-context-alien context))) @@@ -251,7 -251,7 +263,7 @@@ (define mcrypt-supported-key-sizes (mcrypt-generic-unary -- 'MCRYPT-SUPPORTED-KEY-SIZES ++ 'mcrypt-supported-key-sizes (named-lambda (mcrypt-enc-get-supported-key-sizes context) (let ((mlist (malloc (C-sizeof "struct mcrypt_list") '(struct |mcrypt_list|)))) @@@ -269,42 -269,42 +281,55 @@@ sizes))))) (define (mcrypt-init-vector-size context) -- (guarantee-mcrypt-context context 'MCRYPT-INIT-VECTOR-SIZE) ++ (guarantee-mcrypt-context context 'mcrypt-init-vector-size) (C-call "mcrypt_enc_get_iv_size" (mcrypt-context-alien context))) (define (mcrypt-algorithm-name context) -- (guarantee-mcrypt-context context 'MCRYPT-ALGORITHM-NAME) ++ (guarantee-mcrypt-context context 'mcrypt-algorithm-name) (mcrypt-context-algorithm context)) (define (mcrypt-mode-name context) -- (guarantee-mcrypt-context context 'MCRYPT-MODE-NAME) ++ (guarantee-mcrypt-context context 'mcrypt-mode-name) (mcrypt-context-mode context)) (define (mcrypt-encrypt-port algorithm mode input output key init-vector encrypt?) ;; Assumes that INPUT is in blocking mode. -- (let ((context (mcrypt-open-module algorithm mode)) -- (input-buffer (make-bytevector 4096)) -- (output-buffer (make-bytevector 4096))) -- (mcrypt-init context key init-vector) ++ ((port-transformer (lambda () ++ (let ((context (mcrypt-open-module algorithm mode))) ++ (mcrypt-init context key init-vector) ++ context)) ++ (if encrypt? mcrypt-encrypt! mcrypt-decrypt!) ++ mcrypt-end) ++ input ++ output)) ++ ++(define (port-transformer initialize update finalize) ++ (lambda (input-port output-port) ++ (call-with-buffer #x1000 ++ (lambda (buffer) ++ (let ((context (initialize))) ++ (let loop () ++ (let ((n (read-bytevector! buffer input-port))) ++ (if (and n (fix:> n 0)) ++ (begin ++ (update context buffer 0 n) ++ (let ((n* (write-bytevector buffer output-port 0 n))) ++ (if (not (eqv? n n*)) ++ (error "Short write (requested, actual):" n n*))) ++ (loop))))) ++ (finalize context)))))) ++ ++(define (call-with-buffer n procedure) ++ (let ((buffer (make-bytevector n))) (dynamic-wind -- (lambda () -- unspecific) -- (lambda () -- (let loop () -- (let ((n (read-bytevector! input-buffer input))) -- (if (and (not (eof-object? n)) -- (not (= 0 n))) -- (begin -- (mcrypt-encrypt context input-buffer 0 n output-buffer 0 -- encrypt?) -- (write-bytevector output-buffer output 0 n) -- (loop))))) -- (mcrypt-end context)) -- (lambda () -- (bytevector-fill! input-buffer 0) -- (bytevector-fill! output-buffer 0))))) -- ++ (lambda () ++ unspecific) ++ (lambda () ++ (procedure buffer)) ++ (lambda () ++ (bytevector-fill! buffer 0))))) ++ ;;;; Mcrypt size lists. (define (mcrypt-size-list-elements mlist) diff --cc src/md5/md5-check.scm index 73c611df9,73c611df9..cda8de0d9 --- a/src/md5/md5-check.scm +++ b/src/md5/md5-check.scm @@@ -27,11 -27,11 +27,11 @@@ USA ;;;; Test the MD5 option. (let ((sample "Some text to hash.")) -- (let ((hash (md5-sum->hexadecimal (md5-string sample)))) ++ (let ((hash (bytevector->hexadecimal (md5-string sample)))) (if (not (string=? hash "C8E89C4CBF3ABF9AA758D691CBE4B784")) (error "Bad hash for sample text:" hash))) (call-with-output-file "sample" (lambda (port) (write-string sample port) (newline port))) -- (let ((hash (md5-sum->hexadecimal (md5-file "sample")))) ++ (let ((hash (bytevector->hexadecimal (md5-file "sample")))) (if (not (string=? hash "43EB9ECCB88C329721925EFC04843AF1")) (error "Bad hash for sample file:" hash)))) diff --cc src/md5/md5.pkg index 02113b307,4507658aa..b891fea08 --- a/src/md5/md5.pkg +++ b/src/md5/md5.pkg @@@ -29,15 -29,14 +29,12 @@@ USA (define-package (md5) (files "md5") (parent ()) - ;; You'll have to import these from (global-definitions md5/). They - ;; are currently bound in () by exports from (runtime crypto). + ;; These are "exported" to (runtime crypto) during load-option. + ;; (md5 global) gets them just so that CREF will report any that go + ;; missing. (export (md5 global) md5-file -- md5-string -- md5-substring -- md5-sum->hexadecimal -- md5-sum->number)) ++ md5-string)) (define-package (md5 global) ;; Just to get cref to analyze whether all exports are defined. diff --cc src/md5/md5.scm index e4a4ff6e3,e4a4ff6e3..199abcdd5 --- a/src/md5/md5.scm +++ b/src/md5/md5.scm @@@ -46,38 -46,38 +46,53 @@@ USA (define (md5-file filename) (call-with-binary-input-file filename -- (lambda (port) -- (let ((buffer (make-bytevector 4096)) -- (context (%md5-init))) -- (dynamic-wind (lambda () -- unspecific) -- (lambda () -- (let loop () -- (let ((n (read-bytevector! buffer port))) -- (if (or (eof-object? n) -- (fix:= 0 n)) -- (%md5-final context) -- (begin -- (%md5-update context buffer 0 n) -- (loop)))))) -- (lambda () -- (bytevector-fill! buffer 0))))))) -- --(define (md5-string string) -- (md5-bytevector (string->utf8 string))) -- --(define (md5-substring string start end) -- (md5-bytevector (string->utf8 (substring string start end)))) -- --(define (md5-bytevector bytevector) -- (let ((context (%md5-init))) -- (%md5-update context bytevector 0 (bytevector-length bytevector)) -- (%md5-final context))) ++ (port-consumer %md5-init %md5-update %md5-final))) ++ ++(define (md5-string string #!optional start end) ++ (md5-bytevector (string->utf8 string start end))) --(define (md5-sum->number sum) -- (let ((l (bytevector-length sum))) -- (do ((i 0 (fix:+ i 1)) -- (n 0 (+ (* n #x100) (bytevector-u8-ref sum i)))) -- ((fix:= i l) n)))) ++(define (md5-bytevector bytes #!optional start end) ++ (let ((end (fix:end-index end (bytevector-length bytes) 'md5-bytevector)) ++ (start (fix:start-index start end 'md5-bytevector)) ++ (context (%md5-init))) ++ (%md5-update context bytes start end) ++ (%md5-final context))) --(define md5-sum->hexadecimal bytevector->hexadecimal) ++(define (port-consumer initialize update finalize) ++ (lambda (port) ++ (call-with-buffer #x1000 ++ (lambda (buffer) ++ (let ((context (initialize))) ++ (let loop () ++ (let ((n (read-bytevector! buffer port))) ++ (if (and n (not (eof-object? n))) ++ (begin ++ (update context buffer 0 n) ++ (loop))))) ++ (finalize context)))))) ++ ++(define (port-transformer initialize update finalize) ++ (lambda (input-port output-port) ++ (call-with-buffer #x1000 ++ (lambda (buffer) ++ (let ((context (initialize))) ++ (let loop () ++ (let ((n (read-bytevector! buffer input-port))) ++ (if (and n (fix:> n 0)) ++ (begin ++ (update context buffer 0 n) ++ (let ((n* (write-bytevector buffer output-port 0 n))) ++ (if (not (eqv? n n*)) ++ (error "Short write (requested, actual):" n n*))) ++ (loop))))) ++ (finalize context)))))) ++ ++(define (call-with-buffer n procedure) ++ (let ((buffer (make-bytevector n))) ++ (dynamic-wind ++ (lambda () ++ unspecific) ++ (lambda () ++ (procedure buffer)) ++ (lambda () ++ (bytevector-fill! buffer 0))))) diff --cc src/mhash/mhash-check.scm index 51d0b7ff0,51d0b7ff0..8662728a9 --- a/src/mhash/mhash-check.scm +++ b/src/mhash/mhash-check.scm @@@ -27,11 -27,11 +27,11 @@@ USA ;;;; Test the MHASH option. (let ((sample "Some text to hash.")) -- (let ((hash (mhash-sum->hexadecimal (mhash-string 'MD5 sample)))) ++ (let ((hash (bytevector->hexadecimal (mhash-string 'MD5 sample)))) (if (not (string=? hash "C8E89C4CBF3ABF9AA758D691CBE4B784")) (error "Bad hash for sample text:" hash))) (call-with-output-file "sample" (lambda (port) (write-string sample port) (newline port))) -- (let ((hash (mhash-sum->hexadecimal (mhash-file 'MD5 "sample")))) ++ (let ((hash (bytevector->hexadecimal (mhash-file 'MD5 "sample")))) (if (not (string=? hash "43EB9ECCB88C329721925EFC04843AF1")) (error "Bad hash for sample file:" hash)))) diff --cc src/mhash/mhash.pkg index a9ac0c15b,1da5b316b..84062c1f9 --- a/src/mhash/mhash.pkg +++ b/src/mhash/mhash.pkg @@@ -52,9 -51,9 +52,6 @@@ USA mhash-keygen-uses-hash-algorithm mhash-keygen-uses-salt? mhash-string -- mhash-substring -- mhash-sum->hexadecimal -- mhash-sum->number mhash-type-names mhash-update)) diff --cc src/mhash/mhash.scm index 8be528ee8,8be528ee8..d6d959664 --- a/src/mhash/mhash.scm +++ b/src/mhash/mhash.scm @@@ -132,17 -132,17 +132,17 @@@ USA (define-structure mhash-context mutex alien id) (define-structure mhash-hmac-context mutex alien id) --(define (guarantee-mhash-context object procedure) ++(define (guarantee-mhash-context object caller) (if (not (mhash-context? object)) -- (error:wrong-type-argument object "mhash context" procedure)) ++ (error:wrong-type-argument object "mhash context" caller)) (if (alien-null? (mhash-context-alien object)) -- (error:bad-range-argument object procedure))) ++ (error:bad-range-argument object caller))) --(define (guarantee-mhash-hmac-context object procedure) ++(define (guarantee-mhash-hmac-context object caller) (if (not (mhash-hmac-context? object)) -- (error:wrong-type-argument object "mhash HMAC context" procedure)) ++ (error:wrong-type-argument object "mhash HMAC context" caller)) (if (alien-null? (mhash-hmac-context-alien object)) -- (error:bad-range-argument object procedure))) ++ (error:bad-range-argument object caller))) (define (guarantee-subbytevector object start end operator) (guarantee bytevector? object operator) @@@ -180,10 -180,10 +180,10 @@@ (define (mhash-get-block-size name) (C-call "mhash_get_block_size" -- (mhash-name->id name 'MHASH-GET-BLOCK-SIZE))) ++ (mhash-name->id name 'mhash-get-block-size))) (define (mhash-init name) -- (let ((id (mhash-name->id name 'MHASH-INIT)) ++ (let ((id (mhash-name->id name 'mhash-init)) (alien (make-alien '|MHASH_INSTANCE|))) (let ((context (make-mhash-context (make-thread-mutex) alien id))) (add-context-cleanup context) @@@ -194,9 -194,9 +194,10 @@@ (error "Unable to allocate mhash context:" name)))) context))) --(define (mhash-update context bytevector start end) -- (guarantee-subbytevector bytevector start end 'MHASH-UPDATE) -- (with-context-locked-open context 'MHASH-UPDATE ++(define (mhash-update context bytes start end) ++ (guarantee-mhash-context context 'mhash-update) ++ (subbytevector bytevector start end 'mhash-update) ++ (with-context-locked-open context 'mhash-update (lambda (alien) (C-call "do_mhash" alien bytevector start end)))) @@@ -225,11 -225,11 +226,12 @@@ (error "Unable to allocate mhash HMAC context:" name)))) context))) --(define (mhash-hmac-update context bytevector start end) -- (guarantee-subbytevector bytevector start end 'MHASH-HMAC-UPDATE) -- (with-hmac-context-locked-open context 'MHASH-HMAC-UPDATE ++(define (mhash-hmac-update context bytes start end) ++ (guarantee-mhash-hmac-context context 'mhash-hmac-update) ++ (guarantee-subbytevector bytes start end 'mhash-hmac-update) ++ (with-hmac-context-locked-open context 'mhash-hmac-update (lambda (alien) -- (C-call "do_mhash" alien bytevector start end)))) ++ (C-call "do_mhash" alien bytes start end)))) (define (mhash-hmac-end context) (with-hmac-context-locked-open context 'MHASH-HMAC-END @@@ -255,31 -255,31 +257,30 @@@ (define (mhash-keygen-uses-salt? name) (not (zero? (C-call "mhash_keygen_uses_salt" -- (keygen-name->id name 'MHASH-KEYGEN-USES-SALT?))))) ++ (keygen-name->id name 'mhash-keygen-uses-salt?))))) (define (mhash-keygen-uses-count? name) (not (zero? (C-call "mhash_keygen_uses_count" -- (keygen-name->id name 'MHASH-KEYGEN-USES-COUNT?))))) ++ (keygen-name->id name 'mhash-keygen-uses-count?))))) (define (mhash-keygen-uses-hash-algorithm name) (C-call "mhash_keygen_uses_hash_algorithm" -- (keygen-name->id name 'MHASH-KEYGEN-USES-HASH-ALGORITHM))) ++ (keygen-name->id name 'mhash-keygen-uses-hash-algorithm))) (define (mhash-keygen-salt-size name) (C-call "mhash_get_keygen_salt_size" -- (keygen-name->id name 'MHASH-KEYGEN-SALT-SIZE))) ++ (keygen-name->id name 'mhash-keygen-salt-size))) (define (mhash-keygen-max-key-size name) (C-call "mhash_get_keygen_max_key_size" -- (keygen-name->id name 'MHASH-KEYGEN-MAX-KEY-SIZE))) ++ (keygen-name->id name 'mhash-keygen-max-key-size))) (define (mhash-keygen type passphrase #!optional salt) -- (if (not (mhash-keygen-type? type)) -- (error:wrong-type-argument type "mhash type" 'MHASH-KEYGEN)) ++ (error:wrong-type-argument type "mhash type" 'mhash-keygen)) (let ((keygenid (mhash-keygen-type-id type)) (keyword-size (mhash-keygen-type-key-length type)) -- (passbytes (string->utf8 passphrase))) ++ (keyword (string->utf8 passphrase))) (let ((params (salted-keygen-params keygenid (mhash-keygen-type-parameter-vector type) salt)) (keyword (make-bytevector keyword-size)) @@@ -330,15 -330,15 +331,13 @@@ (parameter-vector #f read-only #t)) (define (make-mhash-keygen-type name key-length hash-names #!optional count) -- (if (not (index-fixnum? key-length)) -- (error:wrong-type-argument key-length "key length" -- 'MAKE-MHASH-KEYGEN-TYPE)) ++ (guarantee index-fixnum? key-length 'make-mhash-keygen-type) (if (not (let ((m (mhash-keygen-max-key-size name))) (or (= m 0) (<= key-length m)))) -- (error:bad-range-argument key-length 'MAKE-MHASH-KEYGEN-TYPE)) ++ (error:bad-range-argument key-length 'make-mhash-keygen-type)) (%make-mhash-keygen-type -- (keygen-name->id name 'MAKE-MHASH-KEYGEN-TYPE) ++ (keygen-name->id name 'make-mhash-keygen-type) key-length (let ((n-algorithms (mhash-keygen-uses-hash-algorithm name)) (hash-names @@@ -360,13 -360,13 +359,13 @@@ (error "Iteration count required:" name)) (if (not (and (exact-integer? count) (positive? count))) -- (error:bad-range-argument count 'MAKE-MHASH-KEYGEN-TYPE)) ++ (error:bad-range-argument count 'make-mhash-keygen-type)) count))) (do ((i 2 (fix:+ i 1)) (names hash-names (cdr names))) ((fix:= i n)) (vector-set! v i -- (mhash-name->id (car names) 'MAKE-MHASH-KEYGEN-TYPE))) ++ (mhash-name->id (car names) 'make-mhash-keygen-type))) v))))) (define (initialize-mhash-variables!) @@@ -407,41 -407,41 +406,19 @@@ (define (mhash-file hash-type filename) (call-with-binary-input-file filename -- (lambda (port) -- (let ((buffer (make-bytevector 4096)) -- (context (mhash-init hash-type))) -- (dynamic-wind (lambda () -- unspecific) -- (lambda () -- (let loop () -- (let ((n (read-bytevector! buffer port))) -- (if (or (eof-object? n) -- (fix:= 0 n)) -- (mhash-end context) -- (begin -- (mhash-update context buffer 0 n) -- (loop)))))) -- (lambda () -- (bytevector-fill! buffer 0))))))) -- --(define (mhash-string hash-type string) -- (mhash-bytevector hash-type (string->utf8 string))) -- --(define (mhash-substring hash-type string start end) -- (mhash-bytevector hash-type (string->utf8 (substring string start end)))) -- --(define (mhash-bytevector hash-type bytevector) -- (let ((context (mhash-init hash-type))) -- (mhash-update context bytevector 0 (bytevector-length bytevector)) ++ (port-consumer (lambda () (mhash-init hash-type)) ++ mhash-update ++ mhash-end))) ++ ++(define (mhash-string hash-type string #!optional start end) ++ (mhash-bytevector hash-type (string->utf8 string start end))) ++ ++(define (mhash-bytevector hash-type bytes #!optional start end) ++ (let* ((end (fix:end-index end (bytevector-length bytes) 'mhash-bytevector)) ++ (start (fix:start-index start end 'mhash-bytevector)) ++ (context (mhash-init hash-type))) ++ (mhash-update context bytes start end) (mhash-end context))) -- --(define (mhash-sum->number sum) -- (let ((l (bytevector-length sum))) -- (do ((i 0 (fix:+ i 1)) -- (n 0 (+ (* n #x100) (bytevector-u8-ref sum i)))) -- ((fix:= i l) n)))) -- --(define mhash-sum->hexadecimal bytevector->hexadecimal) ;;;; Package initialization @@@ -471,4 -471,4 +448,43 @@@ (if name (cons name names) names))) -- names)))) ++ names)))) ++ ++(define (port-consumer initialize update finalize) ++ (lambda (port) ++ (call-with-buffer #x1000 ++ (lambda (buffer) ++ (let ((context (initialize))) ++ (let loop () ++ (let ((n (read-bytevector! buffer port))) ++ (if (and n (not (eof-object? n))) ++ (begin ++ (update context buffer 0 n) ++ (loop))))) ++ (finalize context)))))) ++ ++(define (port-transformer initialize update finalize) ++ (lambda (input-port output-port) ++ (call-with-buffer #x1000 ++ (lambda (buffer) ++ (let ((context (initialize))) ++ (let loop () ++ (let ((n (read-bytevector! buffer input-port))) ++ (if (and n (fix:> n 0)) ++ (begin ++ (update context buffer 0 n) ++ (let ((n* (write-bytevector buffer output-port 0 n))) ++ (if (not (eqv? n n*)) ++ (error "Short write (requested, actual):" n n*))) ++ (loop))))) ++ (finalize context)))))) ++ ++(define (call-with-buffer n procedure) ++ (let ((buffer (make-bytevector n))) ++ (dynamic-wind ++ (lambda () ++ unspecific) ++ (lambda () ++ (procedure buffer)) ++ (lambda () ++ (bytevector-fill! buffer 0))))) diff --cc src/runtime/global.scm index 97ac8fdb2,a4c156b44..82e4bf5e2 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@@ -149,36 -149,12 +149,38 @@@ USA (define with-values call-with-values) (define (write-to-string object #!optional max) - ((if (or (default-object? max) (not max)) - call-with-output-string - call-with-truncated-output-string) - (lambda (port) (write object port)))) + (if (or (default-object? max) (not max)) + (call-with-output-string + (lambda (port) (write object port))) + (call-with-truncated-output-string + max + (lambda (port) (write object port))))) + +(define (edit . args) + (let ((env (let ((package (name->package '(edwin)))) + (and package (package/environment package))))) + (if env + (apply (environment-lookup env 'edit) args) + (begin + (with-notification + (lambda (port) (display "Loading Edwin" port)) + (lambda () + (parameterize* + (list (cons param:suppress-loading-message? #t)) + (lambda () + (load-option 'EDWIN) + (if (let ((DISPLAY (get-environment-variable "DISPLAY"))) + (and (string? DISPLAY) + (not (string-null? DISPLAY)))) + (ignore-errors (lambda () (load-option 'x11-screen)))))))) + (apply (environment-lookup (->environment '(edwin)) 'edit) args))))) + +(define edwin edit) + +(define (spawn-edwin . args) + (let ((thread (create-thread #f (lambda () (apply edwin args))))) + (detach-thread thread) + thread)) (define (pa procedure) (guarantee procedure? procedure 'PA)