Commit 161390dc authored by Erick's avatar Erick

.

parent 512aed59
......@@ -23,7 +23,7 @@
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: ??????
* Last file update: 23-Apr-2011 18:53 (eg)
* Last file update: 24-Apr-2011 14:58 (eg)
*/
#include <ctype.h>
......@@ -125,7 +125,10 @@ static int charcompi(SCM c1, SCM c2)
{
if (!CHARACTERP(c1)) error_bad_char(c1);
if (!CHARACTERP(c2)) error_bad_char(c2);
return (towlower(CHARACTER_VAL(c1)) - towlower(CHARACTER_VAL(c2)));
return STk_use_utf8 ?
(towlower(CHARACTER_VAL(c1)) - towlower(CHARACTER_VAL(c2))):
(tolower((unsigned char) CHARACTER_VAL(c1)) -
tolower((unsigned char) CHARACTER_VAL(c2)));
}
......@@ -287,11 +290,13 @@ CHAR_COMPARE("char-ci>=?", chargei, (charcompi(c1,c2) >= 0))
/*=============================================================================*/
#define TEST_CTYPE(tst, name) \
DEFINE_PRIMITIVE(name, CPP_CONCAT(char_is, tst), subr1, (SCM c)) \
{ \
if (!CHARACTERP(c)) error_bad_char(c); \
return MAKE_BOOLEAN(CPP_CONCAT(isw, tst)(CHARACTER_VAL(c))); \
#define TEST_CTYPE(tst, name) \
DEFINE_PRIMITIVE(name, CPP_CONCAT(char_is, tst), subr1, (SCM c)) \
{ \
if (!CHARACTERP(c)) error_bad_char(c); \
return STk_use_utf8 ? \
MAKE_BOOLEAN(CPP_CONCAT(isw, tst)(CHARACTER_VAL((unsigned char)c))): \
MAKE_BOOLEAN(CPP_CONCAT(is, tst)(CHARACTER_VAL(c))); \
}
/*
......@@ -377,13 +382,17 @@ doc>
*/
{
if (!CHARACTERP(c)) error_bad_char(c);
return MAKE_CHARACTER(towupper(CHARACTER_VAL(c)));
return MAKE_CHARACTER(STk_use_utf8 ?
towupper(CHARACTER_VAL(c)):
toupper((unsigned char) CHARACTER_VAL(c)));
}
DEFINE_PRIMITIVE("char-downcase", char_downcase, subr1, (SCM c))
{
if (!CHARACTERP(c)) error_bad_char(c);
return MAKE_CHARACTER(towlower(CHARACTER_VAL(c)));
return MAKE_CHARACTER(STk_use_utf8 ?
towlower(CHARACTER_VAL(c)) :
tolower((unsigned char) CHARACTER_VAL(c)));
}
int STk_init_char(void)
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 17-Feb-1993 12:27
* Last file update: 22-Apr-2011 16:14 (eg)
* Last file update: 24-Apr-2011 11:50 (eg)
*
*/
......@@ -284,43 +284,13 @@ DEFINE_PRIMITIVE("read-char", read_char, subr01, (SCM port))
int c;
port = verify_port(port, PORT_READ);
c = STk_getc(port);
return (c == EOF) ? STk_eof : MAKE_CHARACTER(c);
}
c = STk_get_character(port);
if (c == UTF8_INCORRECT_SEQUENCE)
error_bad_utf8_character(c);
int _base_getc(SCM port)
{
int res = STk_getc(port);
printf("LU: %d (0x%x 0%o) \n", res, res, res);
return res;
return (c == EOF) ? STk_eof : MAKE_CHARACTER(c);
}
DEFINE_PRIMITIVE("read-utf8-char", read_utf8_char, subr01, (SCM port))
{
int c;
port = verify_port(port, PORT_READ);
c = _base_getc(port);
if (c >= 0x80) {
if ((c < 0xc0) || (c > 0xf7))
error_bad_utf8_character(c);
else if (c < 0xe0)
c = ((c & 0x3f) << 6) +
(_base_getc(port) & 0x3F);
else if (c < 0xf0) {
c = ((c & 0x1f) << 12) +
((_base_getc(port) & 0x3f) << 6) +
(_base_getc(port) & 0x3f);
} else {
c = ((c & 0x0F) << 16) +
((_base_getc(port) &0x3f) << 6) +
((_base_getc(port) &0x3f) << 6) +
(_base_getc(port) &0x3F);
}
}
return MAKE_CHARACTER(c);
}
/*
<doc EXT read-chars
......@@ -438,7 +408,9 @@ DEFINE_PRIMITIVE("peek-char", peek_char, subr01, (SCM port))
int c;
port = verify_port(port, PORT_READ);
c = STk_getc(port);
c = STk_get_character(port);
if (c == UTF8_INCORRECT_SEQUENCE) error_bad_utf8_character(c);
STk_ungetc(c, port);
return (c == EOF) ? STk_eof : MAKE_CHARACTER(c);
......@@ -674,7 +646,8 @@ DEFINE_PRIMITIVE("write-byte", write_byte, subr12, (SCM byte, SCM port))
{
int b = STk_integer_value(byte);
if (b == LONG_MIN) STk_error_bad_io_param("bad byte value ~S", byte);
if ((b < 0) || (b > 255))
STk_error_bad_io_param("bad byte value ~S", byte);
port = verify_port(port, PORT_WRITE);
STk_putc(b, port);
return STk_void;
......@@ -1545,7 +1518,6 @@ int STk_init_port(void)
ADD_PRIMITIVE(scheme_read);
ADD_PRIMITIVE(scheme_read_cst);
ADD_PRIMITIVE(read_char);
ADD_PRIMITIVE(read_utf8_char);
ADD_PRIMITIVE(read_chars);
ADD_PRIMITIVE(d_read_chars);
ADD_PRIMITIVE(peek_char);
......
......@@ -20,7 +20,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??-Oct-1993 ??:??
* Last file update: 22-Apr-2011 19:28 (eg)
* Last file update: 24-Apr-2011 15:00 (eg)
*
*/
......@@ -235,7 +235,7 @@ static SCM read_token(SCM port, int c, int case_significant)
}
static SCM read_char(SCM port, int c)
/* read an char (or a char name) item whose 1st char is in c */
/* read a char (or a char name) item whose 1st char is in c */
{
char tok[MAX_TOKEN_SIZE];
register int j = 0;
......
/*
* s i o . c -- Low level I/O
*
* Copyright 1993-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
*
*
* Copyright 1993-2011 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
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
* USA.
*
*
*
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: ????
* Last file update: 14-May-2007 13:36 (eg)
* Last file update: 24-Apr-2011 11:31 (eg)
*
*
* Completely rewritten for the STklos version (Jan. 2000)
......@@ -31,15 +31,14 @@
#include "stklos.h"
int
int
STk_readyp(SCM port)
{
if (PORT_UNGETC(port) != EOF) return 1;
return PORT_READY(port)(PORT_STREAM(port));
}
int
int
STk_getc(SCM port)
{
int result = PORT_UNGETC(port);
......@@ -57,11 +56,43 @@ STk_getc(SCM port)
return result;
}
int
STk_get_character(SCM port) /* result may be a wide character */
{
if (PORT_UNGETC(port) != EOF)
return STk_getc(port);
else {
int c = STk_getc(port);
if (STk_use_utf8 && (c >= 0x80)) {
/* Read an UTF-8 character */
if ((c < 0xc0) || (c > 0xf7))
return UTF8_INCORRECT_SEQUENCE;
else if (c < 0xe0)
c = ((c & 0x3f) << 6) +
((STk_getc(port) & 0x3F));
else if (c < 0xf0) {
c = ((c & 0x1f) << 12) +
((STk_getc(port) & 0x3f) << 6) +
((STk_getc(port) & 0x3f));
} else {
c = ((c & 0x0F) << 16) +
((STk_getc(port) &0x3f) << 6) +
((STk_getc(port) &0x3f) << 6) +
((STk_getc(port) &0x3F));
}
}
return c;
}
}
int
STk_ungetc(int c, SCM port)
{
int result = PORT_UNGETC(port);
if (result != EOF) STk_error("INTERNAL ERROR: cannot unget character");
PORT_UNGETC(port) = c;
if (c == '\n') PORT_LINE(port) -= 1;
......@@ -69,9 +100,9 @@ STk_ungetc(int c, SCM port)
return c;
}
int
int
STk_close(SCM port)
{
{
int res, exec_hook = FALSE;;
if (! (PORT_FLAGS(port) & PORT_CLOSED)) {
......@@ -82,7 +113,7 @@ STk_close(SCM port)
STk_register_finalizer(port, NULL); /* Unregister (possible) finalizer */
PORT_FLAGS(port) |= PORT_CLOSED;
res = PORT_CLOSE(port)(PORT_STREAM(port));
/* Eventually call the close hook */
if (exec_hook && (PORT_CLOSEHOOK(port) != STk_false))
STk_C_apply(PORT_CLOSEHOOK(port), 0);
......@@ -90,7 +121,7 @@ STk_close(SCM port)
return res;
}
int
int
STk_putc(int c, SCM port)
{
int n = PORT_PUTC(port)(c, PORT_STREAM(port));
......@@ -122,7 +153,7 @@ int
STk_nputs(SCM port, char *s, int len)
{
int n = PORT_NPUTS(port)(PORT_STREAM(port), s, len);
if (n >= 0)
if (n >= 0)
PORT_POS(port) += n;
return n;
}
......@@ -140,7 +171,7 @@ STk_seek(SCM port, off_t offset, int whence)
offset = PORT_POS(port) + offset;
whence = SEEK_SET;
}
PORT_UNGETC(port) = EOF;
return PORT_POS(port) = PORT_SEEK(port)(PORT_STREAM(port), offset, whence);
}
......@@ -167,7 +198,7 @@ STk_flush(SCM port)
return PORT_FLUSH(port)(PORT_STREAM(port));
}
int
int
STk_feof(SCM port)
{
return PORT_EOFP(port)(PORT_STREAM(port));
......@@ -188,12 +219,12 @@ int
STk_write_buffer(SCM port, void *buff, int count)
{
int n = PORT_BWRITE(port)(PORT_STREAM(port), buff, count);
if (n >= 0)
if (n >= 0)
PORT_POS(port) += n;
return n;
}
int
int
STk_fprintf(SCM port, char *format, ...)
{
va_list ap;
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 21:19 (eg)
* Last file update: 23-Apr-2011 19:03 (eg)
* Last file update: 24-Apr-2011 11:40 (eg)
*/
#include <stklos.h>
......@@ -98,7 +98,7 @@ static void Usage(char *progname, int only_version)
" -d, --debug add informations to ease debugging\n"
" -s, --stack-size=n use a stack of size n (default %d)\n"
" -c, --case-sensitive be case sensitive (default is #f)\n"
" -u, --utf8-encoding=n use/don't use UTF-8 encoding (default is #t)\n"
" -u, --utf8-encoding=n use/don't use UTF-8 encoding (default is #t)\n"
" -v, --version print program version and exit\n"
" -h, --help print this help and exit\n"
"All the arguments given after options are passed to the Scheme program.\n",
......
......@@ -21,7 +21,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: 28-Dec-1999 22:58 (eg)
* Last file update: 23-Apr-2011 18:52 (eg)
* Last file update: 24-Apr-2011 11:30 (eg)
*/
......@@ -948,8 +948,11 @@ struct port_obj {
**** sio.h primitives
****/
#define UTF8_INCORRECT_SEQUENCE (-2)
int STk_readyp(SCM port);
int STk_getc(SCM port);
int STk_get_character(SCM port); /* result may be a wide char */
int STk_ungetc(int c, SCM port);
int STk_close(SCM port);
int STk_putc(int c, SCM port);
......
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