Commit be9445de authored by Erick's avatar Erick

Added the R7RS function read-char

parent 8ddedef7
......@@ -18,7 +18,7 @@
;; USA.
;; Author: Erick Gallesio [eg@unice.fr]
;; 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.])
(insertdoc 'eof-object?)
(insertdoc 'eof-object)
(insertdoc 'char-ready?)
(insertdoc 'read-string)
(insertdoc 'read-line)
(insertdoc 'read-from-string)
(insertdoc 'port->string-list))
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; 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>
(error "bad output port ~S" 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
*
* 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
* it under the terms of the GNU General Public License as published by
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* 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)
*
*/
......@@ -239,7 +239,7 @@ make_sport(enum kind_port kind, SCM str, int init_len, int flags)
/* Initialize now the port itsef */
NEWCELL(res, port);
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_LINE(res) = 1;
PORT_POS(res) = 0;
......
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; 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")
......@@ -403,6 +403,10 @@
(v (call-with-port p read)))
(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)
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; 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")
......@@ -259,6 +259,17 @@
(string-fill! x #\space 1 6)
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 "lambda symbol.1"
'(1 2 3)
......
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