Commit be9445de authored by Erick's avatar Erick

Added the R7RS function read-char

parent 8ddedef7
...@@ -18,7 +18,7 @@ ...@@ -18,7 +18,7 @@
;; USA. ;; USA.
;; Author: Erick Gallesio [eg@unice.fr] ;; Author: Erick Gallesio [eg@unice.fr]
;; Creation date: 26-Nov-2000 18:19 (eg) ;; Creation date: 26-Nov-2000 18:19 (eg)
;; Last file update: 10-Jul-2018 16:11 (eg) ;; Last file update: 1-Aug-2018 18:11 (eg)
;; ;;
;; ====================================================================== ;; ======================================================================
...@@ -596,6 +596,7 @@ be accessed as a normal port with the standard Scheme primitives.]) ...@@ -596,6 +596,7 @@ be accessed as a normal port with the standard Scheme primitives.])
(insertdoc 'eof-object?) (insertdoc 'eof-object?)
(insertdoc 'eof-object) (insertdoc 'eof-object)
(insertdoc 'char-ready?) (insertdoc 'char-ready?)
(insertdoc 'read-string)
(insertdoc 'read-line) (insertdoc 'read-line)
(insertdoc 'read-from-string) (insertdoc 'read-from-string)
(insertdoc 'port->string-list)) (insertdoc 'port->string-list))
......
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
;;;; ;;;;
;;;; Author: Erick Gallesio [eg@unice.fr] ;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg) ;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 18-Jul-2018 14:16 (eg) ;;;; Last file update: 1-Aug-2018 18:17 (eg)
;;;; ;;;;
;;;; ---------------------------------------------------------------------- ;;;; ----------------------------------------------------------------------
...@@ -688,3 +688,35 @@ doc> ...@@ -688,3 +688,35 @@ doc>
(error "bad output port ~S" port)) (error "bad output port ~S" port))
(not (port-closed? port))) (not (port-closed? port)))
#|
<doc R7RS read-string
* (read-string k)
* (read-string k port)
*
* Reads the next |k| characters, or as many as are available
* before the end of file, from the textual input |port| into a
* newly allocated string in left-to-right order and returns the
* string. If no characters are available before the end of file,
* an end-of-file object is returned.
doc>
|#
(define (read-string k :optional (port (current-input-port)))
(%claim-error
'read-string
(unless (positive? k)
(error "parameter must be a positive integer. It was: ~S" k))
(unless (and (input-port? port) (textual-port? port))
(error "bad textual input port ~S" port))
(let ((buffer (make-string k)))
(let Loop ((i 0)
(c (read-char port)))
(cond
((eof-object? c) (if (zero? i)
(eof-object)
(substring buffer 0 i)))
((= i (- k 1)) (string-set! buffer i c)
buffer)
(else (string-set! buffer i c)
(Loop (+ i 1) (read-char port))))))))
/* /*
* s p o r t . c -- String ports management * s p o r t . c -- String ports management
* *
* Copyright © 1993-2012 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr> * Copyright © 1993-2018 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
* *
* This program is free software; you can redistribute it and/or modify * This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by * it under the terms of the GNU General Public License as published by
...@@ -20,7 +20,7 @@ ...@@ -20,7 +20,7 @@
* *
* Author: Erick Gallesio [eg@unice.fr] * Author: Erick Gallesio [eg@unice.fr]
* Creation date: 17-Feb-1993 12:27 * Creation date: 17-Feb-1993 12:27
* Last file update: 18-Mar-2012 18:47 (eg) * Last file update: 1-Aug-2018 18:28 (eg)
* *
*/ */
...@@ -28,7 +28,7 @@ ...@@ -28,7 +28,7 @@
/*===========================================================================*\ /*===========================================================================*\
* *
* Utilities * Utilities
* *
\*===========================================================================*/ \*===========================================================================*/
...@@ -43,21 +43,21 @@ static void error_bad_string(SCM s) ...@@ -43,21 +43,21 @@ static void error_bad_string(SCM s)
* *
\*===========================================================================*/ \*===========================================================================*/
#define START_ALLOC_SIZE 100 /* Initial size of an ouput string port */ #define START_ALLOC_SIZE 100 /* Initial size of an ouput string port */
struct sstream { struct sstream {
char *ptr; char *ptr;
char *base; char *base;
char *end; char *end;
int bufsize; int bufsize;
SCM str; /* keep a ref on original string to avoid GC problems */ SCM str; /* keep a ref on original string to avoid GC problems */
}; };
#define PORT_BASE(x) (((struct sstream *) (x))->base) #define PORT_BASE(x) (((struct sstream *) (x))->base)
#define PORT_PTR(x) (((struct sstream *) (x))->ptr) #define PORT_PTR(x) (((struct sstream *) (x))->ptr)
#define PORT_END(x) (((struct sstream *) (x))->end) #define PORT_END(x) (((struct sstream *) (x))->end)
#define PORT_BUFSIZE(x) (((struct sstream *) (x))->bufsize) #define PORT_BUFSIZE(x) (((struct sstream *) (x))->bufsize)
#define PORT_STR(x) (((struct sstream *) (x))->str) #define PORT_STR(x) (((struct sstream *) (x))->str)
static Inline int Sgetc(void *stream) static Inline int Sgetc(void *stream)
{ {
...@@ -100,8 +100,8 @@ static Inline int Sputc(int c, void *stream) ...@@ -100,8 +100,8 @@ static Inline int Sputc(int c, void *stream)
if (PORT_PTR(stream) >= PORT_END(stream)) { if (PORT_PTR(stream) >= PORT_END(stream)) {
if (PORT_END(stream) == PORT_BASE(stream) + PORT_BUFSIZE(stream)) { if (PORT_END(stream) == PORT_BASE(stream) + PORT_BUFSIZE(stream)) {
/* No more room => allocate a new buffer */ /* No more room => allocate a new buffer */
tmp = PORT_BUFSIZE(stream); tmp = PORT_BUFSIZE(stream);
tmp += tmp/2; tmp += tmp/2;
PORT_BASE(stream)= STk_must_realloc(PORT_BASE(stream), tmp); PORT_BASE(stream)= STk_must_realloc(PORT_BASE(stream), tmp);
PORT_PTR(stream) = PORT_BASE(stream) + PORT_BUFSIZE(stream);/*base can move*/ PORT_PTR(stream) = PORT_BASE(stream) + PORT_BUFSIZE(stream);/*base can move*/
PORT_BUFSIZE(stream) = tmp; PORT_BUFSIZE(stream) = tmp;
...@@ -183,9 +183,9 @@ static void sport_print(SCM obj, SCM port) /* Generic printing of string ports ...@@ -183,9 +183,9 @@ static void sport_print(SCM obj, SCM port) /* Generic printing of string ports
char buffer[MAX_PATH_LENGTH + 20]; char buffer[MAX_PATH_LENGTH + 20];
sprintf(buffer, "#[%s-string-port %lx%s]", sprintf(buffer, "#[%s-string-port %lx%s]",
ISPORTP(obj) ? "input" : "output", ISPORTP(obj) ? "input" : "output",
(unsigned long) obj, (unsigned long) obj,
PORT_IS_CLOSEDP(obj) ? " (closed)" : ""); PORT_IS_CLOSEDP(obj) ? " (closed)" : "");
STk_puts(buffer, port); STk_puts(buffer, port);
} }
...@@ -197,7 +197,7 @@ static void sport_release(SCM port) ...@@ -197,7 +197,7 @@ static void sport_release(SCM port)
/*===========================================================================*\ /*===========================================================================*\
* *
* Input ports * Input ports
* *
\*===========================================================================*/ \*===========================================================================*/
enum kind_port {SREAD_C, SREAD, SWRITE}; enum kind_port {SREAD_C, SREAD, SWRITE};
...@@ -211,23 +211,23 @@ make_sport(enum kind_port kind, SCM str, int init_len, int flags) ...@@ -211,23 +211,23 @@ make_sport(enum kind_port kind, SCM str, int init_len, int flags)
/* Initialize the stream part */ /* Initialize the stream part */
switch (kind) { switch (kind) {
case SREAD: /* this is a input string */ case SREAD: /* this is a input string */
{ {
char *s = STRING_CHARS(str); char *s = STRING_CHARS(str);
PORT_BASE(ss) = s; PORT_BASE(ss) = s;
PORT_END(ss) = s + init_len; PORT_END(ss) = s + init_len;
PORT_STR(ss) = str; PORT_STR(ss) = str;
break; break;
} }
case SREAD_C: /* this is a input string (from a C string) */ case SREAD_C: /* this is a input string (from a C string) */
PORT_BASE(ss) = (char *) str; PORT_BASE(ss) = (char *) str;
PORT_END(ss) = (char *) str + init_len; PORT_END(ss) = (char *) str + init_len;
PORT_STR(ss) = str; PORT_STR(ss) = str;
break; break;
case SWRITE: /* This is an output string */ case SWRITE: /* This is an output string */
PORT_BASE(ss) = PORT_END(ss) = STk_must_malloc_atomic(init_len); PORT_BASE(ss) = PORT_END(ss) = STk_must_malloc_atomic(init_len);
PORT_STR(ss) = STk_false; PORT_STR(ss) = STk_false;
break; break;
} }
PORT_PTR(ss) = PORT_BASE(ss); PORT_PTR(ss) = PORT_BASE(ss);
...@@ -238,28 +238,28 @@ make_sport(enum kind_port kind, SCM str, int init_len, int flags) ...@@ -238,28 +238,28 @@ make_sport(enum kind_port kind, SCM str, int init_len, int flags)
/* Initialize now the port itsef */ /* Initialize now the port itsef */
NEWCELL(res, port); NEWCELL(res, port);
PORT_STREAM(res) = ss; PORT_STREAM(res) = ss;
PORT_FLAGS(res) = flags | PORT_IS_STRING; PORT_FLAGS(res) = flags | PORT_IS_STRING | PORT_TEXTUAL;
PORT_UNGETC(res) = EOF; PORT_UNGETC(res) = EOF;
PORT_LINE(res) = 1; PORT_LINE(res) = 1;
PORT_POS(res) = 0; PORT_POS(res) = 0;
PORT_FNAME(res) = "string port"; PORT_FNAME(res) = "string port";
PORT_CLOSEHOOK(res) = STk_false; PORT_CLOSEHOOK(res) = STk_false;
PORT_PRINT(res) = sport_print; PORT_PRINT(res) = sport_print;
PORT_RELEASE(res) = sport_release; PORT_RELEASE(res) = sport_release;
PORT_GETC(res) = Sgetc; PORT_GETC(res) = Sgetc;
PORT_READY(res) = Sreadyp; PORT_READY(res) = Sreadyp;
PORT_EOFP(res) = Seof; PORT_EOFP(res) = Seof;
PORT_CLOSE(res) = Sclose; PORT_CLOSE(res) = Sclose;
PORT_PUTC(res) = Sputc; PORT_PUTC(res) = Sputc;
PORT_PUTS(res) = Sputs; PORT_PUTS(res) = Sputs;
PORT_PUTSTRING(res) = Sputstring; PORT_PUTSTRING(res) = Sputstring;
PORT_NPUTS(res) = Snputs; PORT_NPUTS(res) = Snputs;
PORT_FLUSH(res) = Sflush; PORT_FLUSH(res) = Sflush;
PORT_BREAD(res) = Sread; PORT_BREAD(res) = Sread;
PORT_BWRITE(res) = Swrite; PORT_BWRITE(res) = Swrite;
PORT_SEEK(res) = Sseek; PORT_SEEK(res) = Sseek;
return (struct port_obj *) res; return (struct port_obj *) res;
} }
......
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
;;;; ;;;;
;;;; Author: Erick Gallesio [eg@unice.fr] ;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg) ;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 13-Jul-2018 15:06 (eg) ;;;; Last file update: 1-Aug-2018 18:29 (eg)
;;;; ;;;;
(require "test") (require "test")
...@@ -403,6 +403,10 @@ ...@@ -403,6 +403,10 @@
(v (call-with-port p read))) (v (call-with-port p read)))
(cons v (port-closed? p)))) (cons v (port-closed? p))))
(let ((p (open-input-string "ABCDE")))
(test "read-string.1" "ABCD" (read-string 4 p))
(test "read-string.2" "E" (read-string 4 p))
(test "read-string.3" #eof (read-string 4 p)))
(test-section-end) (test-section-end)
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
;;;; ;;;;
;;;; Author: Erick Gallesio [eg@unice.fr] ;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 27-May-2011 23:35 (eg) ;;;; Creation date: 27-May-2011 23:35 (eg)
;;;; Last file update: 28-Jun-2018 17:47 (eg) ;;;; Last file update: 1-Aug-2018 18:40 (eg)
;;;; ;;;;
(require "test") (require "test")
...@@ -258,6 +258,17 @@ ...@@ -258,6 +258,17 @@
(let ((x (make-string 7 #\λ))) (let ((x (make-string 7 #\λ)))
(string-fill! x #\space 1 6) (string-fill! x #\space 1 6)
x)) x))
(test "peek-char and read-char on UTF8 chars"
'(#\x2264 #\x2264 #\xab #\xbb #eof #eof)
(let ((p (open-input-string (string #\x2264 #\xab #\xbb))))
(let* ((c0 (peek-char p))
(c1 (read-char p))
(c2 (read-char p))
(c3 (read-char p))
(c4 (peek-char p))
(c5 (read-char p)))
(list c0 c1 c2 c3 c4 c5))))
;;---- Test the lambda form with λ symbol ;;---- Test the lambda form with λ symbol
(test "lambda symbol.1" (test "lambda symbol.1"
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment