mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
Make things compile neatly under Sun's C compiler.
* dynl.c (scm_dynamic_func): Cast return value from sysdep_dynl_func. * extchrs.c (xmbtowc): Make the second arg a normal char, not unsigned, because that's what the ANSI function takes. * extchrs.h (xmbtowc): Corresponding change to prototype. * genio.c (scm_gen_getc): Make buf plain chars. Nobody wants uchars here. * mbstrings.c (scm_mb_ilength): Use ANSI arg syntax. Make DATA argument plain char *. * strings.c (scm_string): Use SCM_ROCHARS, since c is a plain char. * tag.c (scm_tag): Remove unreachable statement. * unif.c (scm_array_to_list): If we want to shift a 1 bit to the top of the word, it should be unsigned.
This commit is contained in:
Jim Blandy
parent
e3173f937c
commit
cdbadcacc1
9 changed files with 11 additions and 800 deletions
|
|
@ -59,7 +59,6 @@ maybe_drag_in_eprintf ()
|
||||||
}
|
}
|
||||||
|
|
||||||
#include <stdio.h>
|
#include <stdio.h>
|
||||||
|
|
||||||
#include "_scm.h"
|
#include "_scm.h"
|
||||||
#include "dynl.h"
|
#include "dynl.h"
|
||||||
#include "genio.h"
|
#include "genio.h"
|
||||||
|
|
@ -401,7 +400,8 @@ scm_dynamic_func (SCM symb, SCM dobj)
|
||||||
d = get_dynl_obj (dobj, s_dynamic_func, SCM_ARG2);
|
d = get_dynl_obj (dobj, s_dynamic_func, SCM_ARG2);
|
||||||
|
|
||||||
SCM_DEFER_INTS;
|
SCM_DEFER_INTS;
|
||||||
func = sysdep_dynl_func (SCM_CHARS (symb), d->handle, s_dynamic_func);
|
func = (void (*) ()) sysdep_dynl_func (SCM_CHARS (symb), d->handle,
|
||||||
|
s_dynamic_func);
|
||||||
SCM_ALLOW_INTS;
|
SCM_ALLOW_INTS;
|
||||||
|
|
||||||
return scm_ulong2num ((unsigned long)func);
|
return scm_ulong2num ((unsigned long)func);
|
||||||
|
|
|
||||||
|
|
@ -1,134 +0,0 @@
|
||||||
/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
|
|
||||||
*
|
|
||||||
* 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, 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 software; see the file COPYING. If not, write to
|
|
||||||
* the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
||||||
*
|
|
||||||
* As a special exception, the Free Software Foundation gives permission
|
|
||||||
* for additional uses of the text contained in its release of GUILE.
|
|
||||||
*
|
|
||||||
* The exception is that, if you link the GUILE library with other files
|
|
||||||
* to produce an executable, this does not by itself cause the
|
|
||||||
* resulting executable to be covered by the GNU General Public License.
|
|
||||||
* Your use of that executable is in no way restricted on account of
|
|
||||||
* linking the GUILE library code into it.
|
|
||||||
*
|
|
||||||
* This exception does not however invalidate any other reasons why
|
|
||||||
* the executable file might be covered by the GNU General Public License.
|
|
||||||
*
|
|
||||||
* This exception applies only to the code released by the
|
|
||||||
* Free Software Foundation under the name GUILE. If you copy
|
|
||||||
* code from other Free Software Foundation releases into a copy of
|
|
||||||
* GUILE, as the General Public License permits, the exception does
|
|
||||||
* not apply to the code that you add in this way. To avoid misleading
|
|
||||||
* anyone as to the status of such modified files, you must delete
|
|
||||||
* this exception notice from them.
|
|
||||||
*
|
|
||||||
* If you write modifications of your own for GUILE, it is your choice
|
|
||||||
* whether to permit this exception to apply to your modifications.
|
|
||||||
* If you do not wish that, delete this exception notice.
|
|
||||||
*/
|
|
||||||
|
|
||||||
|
|
||||||
#include "extchrs.h"
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#ifdef SCM_FAKE_EXT_CHARS
|
|
||||||
|
|
||||||
|
|
||||||
int
|
|
||||||
xmblen (str, size)
|
|
||||||
const char * str;
|
|
||||||
size_t size;
|
|
||||||
{
|
|
||||||
if (!str)
|
|
||||||
return 0;
|
|
||||||
|
|
||||||
if (*(unsigned char *)str > 127)
|
|
||||||
return ((size < 4)
|
|
||||||
? -1
|
|
||||||
: 4);
|
|
||||||
else if (!*str)
|
|
||||||
return 0;
|
|
||||||
else
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
int
|
|
||||||
xwctomb (_str, c)
|
|
||||||
char * _str;
|
|
||||||
int c;
|
|
||||||
{
|
|
||||||
unsigned char * str;
|
|
||||||
str = (unsigned char *)_str;
|
|
||||||
if (!str)
|
|
||||||
return 0;
|
|
||||||
|
|
||||||
if (!c)
|
|
||||||
{
|
|
||||||
*str = 0;
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
if (c < 127)
|
|
||||||
{
|
|
||||||
*str = c;
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
str[0] = 255;
|
|
||||||
str[1] = 0x80 | ((c >> 10) & 0x3f);
|
|
||||||
str[2] = 0x80 | ((c >> 4) & 0x3f);
|
|
||||||
str[3] = 0x80 | (c & 0xf);
|
|
||||||
return 4;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
int
|
|
||||||
xmbtowc (result, _str, size)
|
|
||||||
xwchar_t * result;
|
|
||||||
const unsigned char * _str;
|
|
||||||
size_t size;
|
|
||||||
{
|
|
||||||
const unsigned char * str;
|
|
||||||
str = (const unsigned char *)_str;
|
|
||||||
if (!str)
|
|
||||||
return 0;
|
|
||||||
|
|
||||||
if ((size == 0) || !*str)
|
|
||||||
{
|
|
||||||
*result = 0;
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
if (*str < 128)
|
|
||||||
{
|
|
||||||
*result = *str;
|
|
||||||
return 1;
|
|
||||||
}
|
|
||||||
|
|
||||||
if ( (*str != 255)
|
|
||||||
|| (size < 4))
|
|
||||||
return -1;
|
|
||||||
|
|
||||||
*result = ( ((str[1] & 0x3f) << 10)
|
|
||||||
| ((str[2] & 0x3f) << 4)
|
|
||||||
| (str[3] & 0xf));
|
|
||||||
return 4;
|
|
||||||
}
|
|
||||||
|
|
||||||
#endif /* SCM_FAKE_EXT_CHARS */
|
|
||||||
|
|
||||||
|
|
@ -1,74 +0,0 @@
|
||||||
/* classes: h_files */
|
|
||||||
|
|
||||||
#ifndef EXTCHRSH
|
|
||||||
#define EXTCHRSH
|
|
||||||
/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
|
|
||||||
*
|
|
||||||
* 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, 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 software; see the file COPYING. If not, write to
|
|
||||||
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
|
||||||
* Boston, MA 02111-1307 USA
|
|
||||||
*
|
|
||||||
* As a special exception, the Free Software Foundation gives permission
|
|
||||||
* for additional uses of the text contained in its release of GUILE.
|
|
||||||
*
|
|
||||||
* The exception is that, if you link the GUILE library with other files
|
|
||||||
* to produce an executable, this does not by itself cause the
|
|
||||||
* resulting executable to be covered by the GNU General Public License.
|
|
||||||
* Your use of that executable is in no way restricted on account of
|
|
||||||
* linking the GUILE library code into it.
|
|
||||||
*
|
|
||||||
* This exception does not however invalidate any other reasons why
|
|
||||||
* the executable file might be covered by the GNU General Public License.
|
|
||||||
*
|
|
||||||
* This exception applies only to the code released by the
|
|
||||||
* Free Software Foundation under the name GUILE. If you copy
|
|
||||||
* code from other Free Software Foundation releases into a copy of
|
|
||||||
* GUILE, as the General Public License permits, the exception does
|
|
||||||
* not apply to the code that you add in this way. To avoid misleading
|
|
||||||
* anyone as to the status of such modified files, you must delete
|
|
||||||
* this exception notice from them.
|
|
||||||
*
|
|
||||||
* If you write modifications of your own for GUILE, it is your choice
|
|
||||||
* whether to permit this exception to apply to your modifications.
|
|
||||||
* If you do not wish that, delete this exception notice. */
|
|
||||||
|
|
||||||
|
|
||||||
#include <stdlib.h>
|
|
||||||
|
|
||||||
#include "libguile/__scm.h"
|
|
||||||
|
|
||||||
#define SCM_FAKE_EXT_CHARS 1
|
|
||||||
|
|
||||||
#if !defined(SCM_FAKE_EXT_CHARS)
|
|
||||||
|
|
||||||
#define xmblen mblen
|
|
||||||
#define xwctomb wctomb
|
|
||||||
#define xmbtowc mbtowc
|
|
||||||
#define XMB_CUR_MAX MB_CUR_MAX
|
|
||||||
typedef wchar_t xwchar_t;
|
|
||||||
|
|
||||||
#else
|
|
||||||
|
|
||||||
typedef unsigned short xwchar_t;
|
|
||||||
#define XMB_CUR_MAX 4
|
|
||||||
|
|
||||||
#endif
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
extern int xmblen SCM_P ((const char * str, size_t size));
|
|
||||||
extern int xwctomb SCM_P ((char * _str, int c));
|
|
||||||
extern int xmbtowc SCM_P ((xwchar_t * result, const unsigned char * _str, size_t size));
|
|
||||||
|
|
||||||
#endif /* EXTCHRSH */
|
|
||||||
|
|
@ -204,7 +204,8 @@ scm_gen_puts (rep, str_data, port)
|
||||||
while (size)
|
while (size)
|
||||||
{
|
{
|
||||||
len = xmbtowc (&output, str_data, size);
|
len = xmbtowc (&output, str_data, size);
|
||||||
SCM_ASSERT ((len > 0), SCM_MAKINUM (*str_data), "bogus character", "scm_gen_puts");
|
SCM_ASSERT ((len > 0), SCM_MAKINUM (*str_data),
|
||||||
|
"bogus character", "scm_gen_puts");
|
||||||
scm_putc ((output >> 8) & 0xff, port);
|
scm_putc ((output >> 8) & 0xff, port);
|
||||||
scm_putc (output & 0xff, port);
|
scm_putc (output & 0xff, port);
|
||||||
size -= len;
|
size -= len;
|
||||||
|
|
@ -437,7 +438,7 @@ scm_gen_getc (port)
|
||||||
case scm_mb_port:
|
case scm_mb_port:
|
||||||
{
|
{
|
||||||
int x;
|
int x;
|
||||||
unsigned char buf[256];
|
char buf[256];
|
||||||
|
|
||||||
SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F,
|
SCM_ASSERT (XMB_CUR_MAX < sizeof (buf), SCM_BOOL_F,
|
||||||
"huge translation", "scm_gen_puts");
|
"huge translation", "scm_gen_puts");
|
||||||
|
|
|
||||||
|
|
@ -1,505 +0,0 @@
|
||||||
|
|
||||||
|
|
||||||
/* Copyright (C) 1995, 1996 Free Software Foundation, Inc.
|
|
||||||
*
|
|
||||||
* 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, 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 software; see the file COPYING. If not, write to
|
|
||||||
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
|
||||||
* Boston, MA 02111-1307 USA
|
|
||||||
*
|
|
||||||
* As a special exception, the Free Software Foundation gives permission
|
|
||||||
* for additional uses of the text contained in its release of GUILE.
|
|
||||||
*
|
|
||||||
* The exception is that, if you link the GUILE library with other files
|
|
||||||
* to produce an executable, this does not by itself cause the
|
|
||||||
* resulting executable to be covered by the GNU General Public License.
|
|
||||||
* Your use of that executable is in no way restricted on account of
|
|
||||||
* linking the GUILE library code into it.
|
|
||||||
*
|
|
||||||
* This exception does not however invalidate any other reasons why
|
|
||||||
* the executable file might be covered by the GNU General Public License.
|
|
||||||
*
|
|
||||||
* This exception applies only to the code released by the
|
|
||||||
* Free Software Foundation under the name GUILE. If you copy
|
|
||||||
* code from other Free Software Foundation releases into a copy of
|
|
||||||
* GUILE, as the General Public License permits, the exception does
|
|
||||||
* not apply to the code that you add in this way. To avoid misleading
|
|
||||||
* anyone as to the status of such modified files, you must delete
|
|
||||||
* this exception notice from them.
|
|
||||||
*
|
|
||||||
* If you write modifications of your own for GUILE, it is your choice
|
|
||||||
* whether to permit this exception to apply to your modifications.
|
|
||||||
* If you do not wish that, delete this exception notice. */
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
#include "extchrs.h"
|
|
||||||
#include <stdio.h>
|
|
||||||
#include "_scm.h"
|
|
||||||
#include "chars.h"
|
|
||||||
#include "unif.h"
|
|
||||||
#include "genio.h"
|
|
||||||
#include "read.h"
|
|
||||||
|
|
||||||
#include "mbstrings.h"
|
|
||||||
|
|
||||||
|
|
||||||
SCM_PROC(s_multi_byte_string_p, "multi-byte-string?", 1, 0, 0, scm_multi_byte_string_p);
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_multi_byte_string_p (obj)
|
|
||||||
SCM obj;
|
|
||||||
{
|
|
||||||
return (SCM_MB_STRINGP (obj)
|
|
||||||
? SCM_BOOL_T
|
|
||||||
: SCM_BOOL_F);
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_regular_string_p (obj)
|
|
||||||
SCM obj;
|
|
||||||
{
|
|
||||||
return (SCM_REGULAR_STRINGP (obj)
|
|
||||||
? SCM_BOOL_T
|
|
||||||
: SCM_BOOL_F);
|
|
||||||
}
|
|
||||||
|
|
||||||
SCM_PROC(s_list_to_multi_byte_string, "list->multi-byte-string", 1, 0, 0, scm_multi_byte_string);
|
|
||||||
SCM_PROC(s_multi_byte_string, "multi-byte-string", 0, 0, 1, scm_multi_byte_string);
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_multi_byte_string (chrs)
|
|
||||||
SCM chrs;
|
|
||||||
{
|
|
||||||
SCM res;
|
|
||||||
register char *data;
|
|
||||||
long i;
|
|
||||||
long byte_len;
|
|
||||||
|
|
||||||
i = scm_ilength (chrs);
|
|
||||||
SCM_ASSERT (i >= 0, chrs, SCM_ARG1, s_multi_byte_string);
|
|
||||||
i = i * XMB_CUR_MAX;
|
|
||||||
res = scm_makstr (i, 0);
|
|
||||||
SCM_SETLENGTH (res, SCM_LENGTH (res), scm_tc7_mb_string);
|
|
||||||
data = SCM_CHARS (res);
|
|
||||||
byte_len = 0;
|
|
||||||
xwctomb (0, 0);
|
|
||||||
while (i && SCM_NNULLP (chrs))
|
|
||||||
{
|
|
||||||
int used;
|
|
||||||
SCM ch;
|
|
||||||
|
|
||||||
ch = SCM_CAR (chrs);
|
|
||||||
SCM_ASSERT (SCM_ICHRP (ch), chrs, SCM_ARG1, s_multi_byte_string);
|
|
||||||
used = xwctomb (data + byte_len, SCM_ICHR (ch));
|
|
||||||
SCM_ASSERT (used >= 0, chrs, SCM_ARG1, s_multi_byte_string);
|
|
||||||
byte_len += (used ? used : 1);
|
|
||||||
chrs = SCM_CDR (chrs);
|
|
||||||
--i;
|
|
||||||
}
|
|
||||||
res = scm_vector_set_length_x (res, SCM_MAKINUM (byte_len));
|
|
||||||
return res;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
int
|
|
||||||
scm_mb_ilength (data, size)
|
|
||||||
unsigned char * data;
|
|
||||||
int size;
|
|
||||||
{
|
|
||||||
int pos;
|
|
||||||
int len;
|
|
||||||
|
|
||||||
len = 0;
|
|
||||||
pos = 0;
|
|
||||||
xmblen (0, 0);
|
|
||||||
while (pos < size)
|
|
||||||
{
|
|
||||||
int inc;
|
|
||||||
|
|
||||||
inc = xmblen (data + pos, size - pos);
|
|
||||||
if (inc == 0)
|
|
||||||
++inc;
|
|
||||||
|
|
||||||
if (inc < 0)
|
|
||||||
return -1;
|
|
||||||
|
|
||||||
++len;
|
|
||||||
pos += inc;
|
|
||||||
}
|
|
||||||
|
|
||||||
return len;
|
|
||||||
}
|
|
||||||
|
|
||||||
SCM_PROC(s_multi_byte_string_length, "multi-byte-string-length", 1, 0, 0, scm_multi_byte_string_length);
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_multi_byte_string_length (str)
|
|
||||||
SCM str;
|
|
||||||
{
|
|
||||||
int size;
|
|
||||||
int len;
|
|
||||||
unsigned char * data;
|
|
||||||
|
|
||||||
SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), str, SCM_ARG1, s_multi_byte_string_length);
|
|
||||||
|
|
||||||
data = SCM_ROCHARS (str);
|
|
||||||
size = SCM_ROLENGTH (str);
|
|
||||||
len = scm_mb_ilength (data, size);
|
|
||||||
SCM_ASSERT (len >= 0, str, SCM_ARG1, s_multi_byte_string_length);
|
|
||||||
return SCM_MAKINUM (len);
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
SCM_PROC(s_symbol_multi_byte_p, "symbol-multi-byte?", 1, 0, 0, scm_symbol_multi_byte_p);
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_symbol_multi_byte_p (symbol)
|
|
||||||
SCM symbol;
|
|
||||||
{
|
|
||||||
return SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol);
|
|
||||||
}
|
|
||||||
|
|
||||||
SCM_PROC(s_set_symbol_multi_byte_x, "set-symbol-multi-byte!", 2, 0, 0, scm_set_symbol_multi_byte_x);
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_set_symbol_multi_byte_x (symbol, val)
|
|
||||||
SCM symbol;
|
|
||||||
SCM val;
|
|
||||||
{
|
|
||||||
if (SCM_TYP7 (symbol) == scm_tc7_msymbol)
|
|
||||||
{
|
|
||||||
SCM_SYMBOL_MULTI_BYTE_STRINGP(symbol) = (SCM_FALSEP (val)
|
|
||||||
? SCM_BOOL_F
|
|
||||||
: SCM_BOOL_T);
|
|
||||||
}
|
|
||||||
return SCM_UNSPECIFIED;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
SCM_PROC(s_regular_port_p, "regular-port?", 1, 0, 0, scm_regular_port_p);
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_regular_port_p (p)
|
|
||||||
SCM p;
|
|
||||||
{
|
|
||||||
return (SCM_PORT_REPRESENTATION(p) == scm_regular_port
|
|
||||||
? SCM_BOOL_T
|
|
||||||
: SCM_BOOL_F);
|
|
||||||
}
|
|
||||||
|
|
||||||
SCM_PROC(s_regular_port_x, "regular-port!", 1, 0, 0, scm_regular_port_x);
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_regular_port_x (p)
|
|
||||||
SCM p;
|
|
||||||
{
|
|
||||||
SCM_PORT_REPRESENTATION(p) = scm_regular_port;
|
|
||||||
return SCM_UNSPECIFIED;
|
|
||||||
}
|
|
||||||
|
|
||||||
SCM_PROC(s_multi_byte_port_p, "multi-byte-port?", 1, 0, 0, scm_multi_byte_port_p);
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_multi_byte_port_p (p)
|
|
||||||
SCM p;
|
|
||||||
{
|
|
||||||
return (SCM_PORT_REPRESENTATION(p) == scm_mb_port
|
|
||||||
? SCM_BOOL_T
|
|
||||||
: SCM_BOOL_F);
|
|
||||||
}
|
|
||||||
|
|
||||||
SCM_PROC(s_multi_byte_port_x, "multi-byte-port!", 1, 0, 0, scm_multi_byte_port_x);
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_multi_byte_port_x (p)
|
|
||||||
SCM p;
|
|
||||||
{
|
|
||||||
SCM_PORT_REPRESENTATION(p) = scm_mb_port;
|
|
||||||
return SCM_UNSPECIFIED;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
SCM_PROC(s_wide_character_port_p, "wide-character-port?", 1, 0, 0, scm_wide_character_port_p);
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_wide_character_port_p (p)
|
|
||||||
SCM p;
|
|
||||||
{
|
|
||||||
return (SCM_PORT_REPRESENTATION(p) == scm_wchar_port
|
|
||||||
? SCM_BOOL_T
|
|
||||||
: SCM_BOOL_F);
|
|
||||||
}
|
|
||||||
|
|
||||||
SCM_PROC(s_wide_character_port_x, "wide-character-port!", 1, 0, 0, scm_wide_character_port_x);
|
|
||||||
|
|
||||||
SCM
|
|
||||||
scm_wide_character_port_x (p)
|
|
||||||
SCM p;
|
|
||||||
{
|
|
||||||
SCM_PORT_REPRESENTATION(p) = scm_wchar_port;
|
|
||||||
return SCM_UNSPECIFIED;
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
void
|
|
||||||
scm_put_wchar (c, port, writing)
|
|
||||||
int c;
|
|
||||||
SCM port;
|
|
||||||
int writing;
|
|
||||||
{
|
|
||||||
if (writing)
|
|
||||||
scm_gen_puts (scm_regular_string, "#\\", port);
|
|
||||||
switch (SCM_PORT_REPRESENTATION (port))
|
|
||||||
{
|
|
||||||
case scm_regular_port:
|
|
||||||
{
|
|
||||||
if (c < 256)
|
|
||||||
{
|
|
||||||
if (!writing)
|
|
||||||
scm_gen_putc ((unsigned char)c, port);
|
|
||||||
else if ((c <= ' ') && scm_charnames[c])
|
|
||||||
scm_gen_puts (scm_regular_string, scm_charnames[c], port);
|
|
||||||
else if (c > '\177')
|
|
||||||
scm_intprint (c, 8, port);
|
|
||||||
else
|
|
||||||
scm_gen_putc ((int) c, port);
|
|
||||||
}
|
|
||||||
else
|
|
||||||
{
|
|
||||||
print_octal:
|
|
||||||
if (!writing)
|
|
||||||
scm_gen_putc ('\\', port);
|
|
||||||
scm_intprint (c, 8, port);
|
|
||||||
}
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
|
|
||||||
case scm_mb_port:
|
|
||||||
{
|
|
||||||
char buf[256];
|
|
||||||
int len;
|
|
||||||
|
|
||||||
if (XMB_CUR_MAX > sizeof (buf))
|
|
||||||
goto print_octal;
|
|
||||||
|
|
||||||
len = xwctomb (buf, c);
|
|
||||||
|
|
||||||
if (len < 0)
|
|
||||||
goto print_octal;
|
|
||||||
|
|
||||||
if (len == 0)
|
|
||||||
scm_gen_putc (0, port);
|
|
||||||
else
|
|
||||||
scm_gen_putc (c, port);
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
|
|
||||||
case scm_wchar_port:
|
|
||||||
{
|
|
||||||
scm_gen_putc (c, port);
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
void
|
|
||||||
scm_print_mb_string (exp, port, writing)
|
|
||||||
SCM exp;
|
|
||||||
SCM port;
|
|
||||||
int writing;
|
|
||||||
{
|
|
||||||
if (writing)
|
|
||||||
{
|
|
||||||
int i;
|
|
||||||
int len;
|
|
||||||
char * data;
|
|
||||||
|
|
||||||
scm_gen_putc ('\"', port);
|
|
||||||
i = 0;
|
|
||||||
len = SCM_ROLENGTH (exp);
|
|
||||||
data = SCM_ROCHARS (exp);
|
|
||||||
|
|
||||||
while (i < len)
|
|
||||||
{
|
|
||||||
xwchar_t c;
|
|
||||||
int inc;
|
|
||||||
|
|
||||||
inc = xmbtowc (&c, data + i, len - i);
|
|
||||||
if (inc == 0)
|
|
||||||
inc = 1;
|
|
||||||
if (inc < 0)
|
|
||||||
{
|
|
||||||
inc = 1;
|
|
||||||
c = data[i];
|
|
||||||
}
|
|
||||||
i += inc;
|
|
||||||
switch (c)
|
|
||||||
{
|
|
||||||
case '\"':
|
|
||||||
case '\\':
|
|
||||||
scm_gen_putc ('\\', port);
|
|
||||||
default:
|
|
||||||
scm_gen_putc (c, port);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
scm_gen_putc ('\"', port);
|
|
||||||
}
|
|
||||||
else
|
|
||||||
scm_gen_write (scm_mb_string, SCM_ROCHARS (exp), SCM_ROLENGTH (exp), port);
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
void
|
|
||||||
scm_print_mb_symbol (exp, port)
|
|
||||||
SCM exp;
|
|
||||||
SCM port;
|
|
||||||
{
|
|
||||||
int pos;
|
|
||||||
int end;
|
|
||||||
int len;
|
|
||||||
char * str;
|
|
||||||
int weird;
|
|
||||||
int maybe_weird;
|
|
||||||
int mw_pos = 0; /* initialized to placate compiler */
|
|
||||||
int inc = 0; /* same */
|
|
||||||
xwchar_t c;
|
|
||||||
|
|
||||||
len = SCM_LENGTH (exp);
|
|
||||||
str = SCM_CHARS (exp);
|
|
||||||
scm_remember (&exp);
|
|
||||||
pos = 0;
|
|
||||||
weird = 0;
|
|
||||||
maybe_weird = 0;
|
|
||||||
|
|
||||||
for (end = pos; end < len; end += inc)
|
|
||||||
{
|
|
||||||
inc = xmbtowc (&c, str + end, len - end);
|
|
||||||
if (inc < 0)
|
|
||||||
{
|
|
||||||
inc = 1;
|
|
||||||
c = str[end];
|
|
||||||
goto weird_handler;
|
|
||||||
}
|
|
||||||
if (inc == 0)
|
|
||||||
{
|
|
||||||
inc = 1;
|
|
||||||
goto weird_handler;
|
|
||||||
}
|
|
||||||
switch (c)
|
|
||||||
{
|
|
||||||
#ifdef BRACKETS_AS_PARENS
|
|
||||||
case '[':
|
|
||||||
case ']':
|
|
||||||
#endif
|
|
||||||
case '(':
|
|
||||||
case ')':
|
|
||||||
case '\"':
|
|
||||||
case ';':
|
|
||||||
case SCM_WHITE_SPACES:
|
|
||||||
case SCM_LINE_INCREMENTORS:
|
|
||||||
weird_handler:
|
|
||||||
if (maybe_weird)
|
|
||||||
{
|
|
||||||
end = mw_pos;
|
|
||||||
maybe_weird = 0;
|
|
||||||
}
|
|
||||||
if (!weird)
|
|
||||||
{
|
|
||||||
scm_gen_write (scm_regular_string, "#{", 2, port);
|
|
||||||
weird = 1;
|
|
||||||
}
|
|
||||||
if (pos < end)
|
|
||||||
{
|
|
||||||
int q;
|
|
||||||
int qinc;
|
|
||||||
|
|
||||||
q = pos;
|
|
||||||
while (q < end)
|
|
||||||
{
|
|
||||||
qinc = xmbtowc (&c, str + q, end - q);
|
|
||||||
if (inc <= 0)
|
|
||||||
{
|
|
||||||
inc = 1;
|
|
||||||
c = str[q];
|
|
||||||
}
|
|
||||||
scm_gen_putc (c, port);
|
|
||||||
q += qinc;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
{
|
|
||||||
char buf[2];
|
|
||||||
buf[0] = '\\';
|
|
||||||
buf[1] = str[end];
|
|
||||||
scm_gen_write (scm_regular_string, buf, 2, port);
|
|
||||||
}
|
|
||||||
pos = end + 1;
|
|
||||||
break;
|
|
||||||
case '\\':
|
|
||||||
if (weird)
|
|
||||||
goto weird_handler;
|
|
||||||
if (!maybe_weird)
|
|
||||||
{
|
|
||||||
maybe_weird = 1;
|
|
||||||
mw_pos = pos;
|
|
||||||
}
|
|
||||||
break;
|
|
||||||
case '}':
|
|
||||||
case '#':
|
|
||||||
if (weird)
|
|
||||||
goto weird_handler;
|
|
||||||
break;
|
|
||||||
default:
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
if (pos < end)
|
|
||||||
{
|
|
||||||
int q;
|
|
||||||
int qinc;
|
|
||||||
q = pos;
|
|
||||||
while (q < end)
|
|
||||||
{
|
|
||||||
qinc = xmbtowc (&c, str + q, end - q);
|
|
||||||
if (inc <= 0)
|
|
||||||
inc = 1;
|
|
||||||
scm_gen_putc (c, port);
|
|
||||||
q += qinc;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
if (weird)
|
|
||||||
scm_gen_write (scm_regular_string, "}#", 2, port);
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
void
|
|
||||||
scm_init_mbstrings ()
|
|
||||||
{
|
|
||||||
#include "mbstrings.x"
|
|
||||||
}
|
|
||||||
|
|
||||||
|
|
@ -1,78 +0,0 @@
|
||||||
/* classes: h_files */
|
|
||||||
|
|
||||||
#ifndef MBSTRINGSH
|
|
||||||
#define MBSTRINGSH
|
|
||||||
/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
|
|
||||||
*
|
|
||||||
* 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, 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 software; see the file COPYING. If not, write to
|
|
||||||
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
|
||||||
* Boston, MA 02111-1307 USA
|
|
||||||
*
|
|
||||||
* As a special exception, the Free Software Foundation gives permission
|
|
||||||
* for additional uses of the text contained in its release of GUILE.
|
|
||||||
*
|
|
||||||
* The exception is that, if you link the GUILE library with other files
|
|
||||||
* to produce an executable, this does not by itself cause the
|
|
||||||
* resulting executable to be covered by the GNU General Public License.
|
|
||||||
* Your use of that executable is in no way restricted on account of
|
|
||||||
* linking the GUILE library code into it.
|
|
||||||
*
|
|
||||||
* This exception does not however invalidate any other reasons why
|
|
||||||
* the executable file might be covered by the GNU General Public License.
|
|
||||||
*
|
|
||||||
* This exception applies only to the code released by the
|
|
||||||
* Free Software Foundation under the name GUILE. If you copy
|
|
||||||
* code from other Free Software Foundation releases into a copy of
|
|
||||||
* GUILE, as the General Public License permits, the exception does
|
|
||||||
* not apply to the code that you add in this way. To avoid misleading
|
|
||||||
* anyone as to the status of such modified files, you must delete
|
|
||||||
* this exception notice from them.
|
|
||||||
*
|
|
||||||
* If you write modifications of your own for GUILE, it is your choice
|
|
||||||
* whether to permit this exception to apply to your modifications.
|
|
||||||
* If you do not wish that, delete this exception notice. */
|
|
||||||
|
|
||||||
|
|
||||||
#include "libguile/__scm.h"
|
|
||||||
#include "libguile/symbols.h"
|
|
||||||
|
|
||||||
|
|
||||||
#define SCM_MB_STRINGP(x) ( (SCM_TYP7(x)==scm_tc7_mb_string) \
|
|
||||||
|| ( (SCM_TYP7(x) == scm_tc7_msymbol) \
|
|
||||||
&& (SCM_SYMBOL_MULTI_BYTE_STRINGP (x) != SCM_BOOL_F)))
|
|
||||||
#define SCM_REGULAR_STRINGP(x) (SCM_TYP7D(x)==scm_tc7_string)
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
extern SCM scm_multi_byte_string_p SCM_P ((SCM obj));
|
|
||||||
extern SCM scm_regular_string_p SCM_P ((SCM obj));
|
|
||||||
extern SCM scm_multi_byte_string SCM_P ((SCM chrs));
|
|
||||||
extern int scm_mb_ilength SCM_P ((unsigned char * data, int size));
|
|
||||||
extern SCM scm_multi_byte_string_length SCM_P ((SCM str));
|
|
||||||
extern SCM scm_symbol_multi_byte_p SCM_P ((SCM symbol));
|
|
||||||
extern SCM scm_set_symbol_multi_byte_x SCM_P ((SCM symbol, SCM val));
|
|
||||||
extern SCM scm_regular_port_p SCM_P ((SCM p));
|
|
||||||
extern SCM scm_regular_port_x SCM_P ((SCM p));
|
|
||||||
extern SCM scm_multi_byte_port_p SCM_P ((SCM p));
|
|
||||||
extern SCM scm_multi_byte_port_x SCM_P ((SCM p));
|
|
||||||
extern SCM scm_wide_character_port_p SCM_P ((SCM p));
|
|
||||||
extern SCM scm_wide_character_port_x SCM_P ((SCM p));
|
|
||||||
extern void scm_put_wchar SCM_P ((int c, SCM port, int writing));
|
|
||||||
extern void scm_print_mb_string SCM_P ((SCM exp, SCM port, int writing));
|
|
||||||
extern void scm_print_mb_symbol SCM_P ((SCM exp, SCM port));
|
|
||||||
extern void scm_init_mbstrings SCM_P ((void));
|
|
||||||
|
|
||||||
#endif /* MBSTRINGSH */
|
|
||||||
|
|
@ -116,7 +116,7 @@ scm_string (chrs)
|
||||||
int l;
|
int l;
|
||||||
char * c;
|
char * c;
|
||||||
l = SCM_ROLENGTH (SCM_CAR (chrs));
|
l = SCM_ROLENGTH (SCM_CAR (chrs));
|
||||||
c = SCM_ROUCHARS (SCM_CAR (chrs));
|
c = SCM_ROCHARS (SCM_CAR (chrs));
|
||||||
while (l)
|
while (l)
|
||||||
{
|
{
|
||||||
--l;
|
--l;
|
||||||
|
|
|
||||||
|
|
@ -175,16 +175,17 @@ scm_tag (x)
|
||||||
{
|
{
|
||||||
int tag;
|
int tag;
|
||||||
tag = (SCM_TYP16 (x) >> 8) & 0xff;
|
tag = (SCM_TYP16 (x) >> 8) & 0xff;
|
||||||
return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_smob_base)) | (tag << 8));
|
return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_smob_base))
|
||||||
|
| (tag << 8));
|
||||||
}
|
}
|
||||||
case scm_tcs_cons_gloc:
|
case scm_tcs_cons_gloc:
|
||||||
/* must be a struct */
|
/* must be a struct */
|
||||||
{
|
{
|
||||||
int tag;
|
int tag;
|
||||||
tag = SCM_STRUCT_VTABLE_DATA (x)[scm_struct_i_tag];
|
tag = SCM_STRUCT_VTABLE_DATA (x)[scm_struct_i_tag];
|
||||||
return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_struct_base)) | (tag << 8));
|
return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_struct_base))
|
||||||
|
| (tag << 8));
|
||||||
}
|
}
|
||||||
return SCM_CDR (scm_utag_struct_base) ;
|
|
||||||
|
|
||||||
default:
|
default:
|
||||||
if (SCM_CONSP (x))
|
if (SCM_CONSP (x))
|
||||||
|
|
|
||||||
|
|
@ -2021,7 +2021,7 @@ scm_array_to_list (v)
|
||||||
long *data = (long *) SCM_VELTS (v);
|
long *data = (long *) SCM_VELTS (v);
|
||||||
register unsigned long mask;
|
register unsigned long mask;
|
||||||
for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
|
for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
|
||||||
for (mask = 1L << (SCM_LONG_BIT - 1); mask; mask >>= 1)
|
for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1)
|
||||||
res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
|
res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
|
||||||
for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
|
for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
|
||||||
res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
|
res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue