From 8ffbc2df0fde83082610149d24e594c1cd879f4a Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 2a6 --- strport.scm | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) create mode 100644 strport.scm (limited to 'strport.scm') diff --git a/strport.scm b/strport.scm new file mode 100644 index 0000000..54d8d39 --- /dev/null +++ b/strport.scm @@ -0,0 +1,51 @@ +;;;;"strport.scm" Portable string ports for Scheme +;;;Copyright 1993 Dorai Sitaram and Aubrey Jaffer. +; +;Permission to copy this software, to redistribute it, and to use it +;for any purpose is granted, subject to the following restrictions and +;understandings. +; +;1. Any copy made of this software must include this copyright notice +;in full. +; +;2. I have made no warrantee or representation that the operation of +;this software will be error-free, and I am under no obligation to +;provide any services, by way of maintenance, update, or otherwise. +; +;3. In conjunction with products arising from the use of this +;material, there shall be no use of my name in any advertising, +;promotional, or sales literature without prior written consent in +;each case. + +;N.B.: This implementation assumes you have tmpnam and +;delete-file defined in your .init file. tmpnam generates +;temp file names. delete-file may be defined to be a dummy +;procedure that does nothing. + +(define (call-with-output-string f) + (let ((tmpf (tmpnam))) + (call-with-output-file tmpf f) + (let ((s "") (buf (make-string 512))) + (call-with-input-file tmpf + (lambda (inp) + (let loop ((i 0)) + (let ((c (read-char inp))) + (cond ((eof-object? c) + (set! s (string-append s (substring buf 0 i)))) + ((>= i 512) + (set! s (string-append s buf)) + (loop 0)) + (else + (string-set! buf i c) + (loop (+ i 1)))))))) + (delete-file tmpf) + s))) + +(define (call-with-input-string s f) + (let ((tmpf (tmpnam))) + (call-with-output-file tmpf + (lambda (outp) + (display s outp))) + (let ((x (call-with-input-file tmpf f))) + (delete-file tmpf) + x))) -- cgit v1.2.3