conservatory
/
stk
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
stk/Extensions/locale.c

189 lines
6.3 KiB
C
Raw Normal View History

Commit of 3.99.3 version
1998-09-30 07:11:02 -04:00
/*
*
* l o c a l e . c -- Locale management
*
*
Commit of 4.0.0 version
1999-09-05 07:16:41 -04:00
* Copyright <EFBFBD> 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
Commit of 3.99.3 version
1998-09-30 07:11:02 -04:00
*
*
Commit of 4.0.0 version
1999-09-05 07:16:41 -04:00
* Permission to use, copy, modify, distribute,and license this
* software and its documentation for any purpose is hereby granted,
* provided that existing copyright notices are retained in all
* copies and that this notice is included verbatim in any
* distributions. No written agreement, license, or royalty fee is
* required for any of the authorized uses.
* This software is provided ``AS IS'' without express or implied
* warranty.
Commit of 3.99.3 version
1998-09-30 07:11:02 -04:00
*
*
* Author: Erick Gallesio [eg@kaolin.unice.fr]
* Creation date: 19-Sep-1998 12:01
Commit of 4.0.0 version
1999-09-05 07:16:41 -04:00
* Last file update: 3-Sep-1999 20:21 (eg)
Commit of 3.99.3 version
1998-09-30 07:11:02 -04:00
*
*
*/
#include <locale.h>
#include <stdlib.h>
#include "stk.h"
static char bad_string_message[] = "comparing strings: bad string";
static char bad_char_message[] = "comparing chars: bad char";
static char *locale_name = "";
/*==== Utilities ====*/
static int compare(unsigned char c1, unsigned char c2)
{
unsigned char s1[2] = " ";
unsigned char s2[2] = " ";
/* This is really UGLY but can we write it in a cleaner way using
* only pure ANSI-C primitives? */
*s1 = c1; *s2 = c2;
return strcoll((char *)s1, (char *)s2);
}
static int stringcomp(SCM s1, SCM s2)
{
register int l1, l2;
register char *str1, *str2;
if (NSTRINGP(s1)) Err(bad_string_message, s1);
if (NSTRINGP(s2)) Err(bad_string_message, s2);
for (l1=STRSIZE(s1), str1=CHARS(s1), l2=STRSIZE(s2), str2=CHARS(s2);
l1 && l2;
l1--, str1++, l2--, str2++)
if (*str1 != *str2)
return compare((unsigned char) *str1,
(unsigned char) *str2);
/* l1 == 0 || l2 == 0 */
return l1 ? +1 : (l2 ? -1 : 0);
}
static int stringcompci(SCM s1, SCM s2)
{
register int l1, l2;
register char *str1, *str2;
if (NSTRINGP(s1)) Err(bad_string_message, s1);
if (NSTRINGP(s2)) Err(bad_string_message, s2);
for (l1=STRSIZE(s1), str1=CHARS(s1), l2=STRSIZE(s2), str2=CHARS(s2);
l1 && l2;
l1--, str1++, l2--, str2++)
if (tolower(*str1) != tolower(*str2))
return compare((unsigned char) tolower(*str1),
(unsigned char) tolower(*str2));
/* l1 == 0 || l2 == 0 */
return l1 ? +1 : (l2 ? -1 : 0);
}
static int charcomp(SCM c1, SCM c2)
{
if (NCHARP(c1)) Err(bad_char_message, c1);
if (NCHARP(c2)) Err(bad_char_message, c2);
return compare(CHAR(c1), CHAR(c2));
}
static int charcompci(SCM c1, SCM c2)
{
if (NCHARP(c1)) Err(bad_char_message, c1);
if (NCHARP(c2)) Err(bad_char_message, c2);
return compare((unsigned char) tolower(CHAR(c1)),
(unsigned char) tolower(CHAR(c2)));
}
/*==== Primitives ====*/
static PRIMITIVE set_locale(SCM locale)
{
char *res;
ENTER_PRIMITIVE("set-locale!");
if (!STRINGP(locale)) Serror("bad string", locale);
if ((res=setlocale(LC_ALL, CHARS(locale))) == NULL)
Serror("bad locale", locale);
locale_name = res;
return STk_makestring(res);
}
static PRIMITIVE get_locale(void)
{
return STk_makestring(locale_name);
}
static PRIMITIVE eq (SCM s1,SCM s2){return (stringcomp(s1,s2)==0)? Truth: Ntruth;}
static PRIMITIVE lt (SCM s1,SCM s2){return (stringcomp(s1,s2)<0) ? Truth: Ntruth;}
static PRIMITIVE gt (SCM s1,SCM s2){return (stringcomp(s1,s2)>0) ? Truth: Ntruth;}
static PRIMITIVE le (SCM s1,SCM s2){return (stringcomp(s1,s2)<=0)? Truth: Ntruth;}
static PRIMITIVE ge (SCM s1,SCM s2){return (stringcomp(s1,s2)>=0)? Truth: Ntruth;}
static PRIMITIVE eqci(SCM s1,SCM s2){return (stringcompci(s1,s2)==0)? Truth:Ntruth;}
static PRIMITIVE ltci(SCM s1,SCM s2){return (stringcompci(s1,s2)<0) ? Truth:Ntruth;}
static PRIMITIVE gtci(SCM s1,SCM s2){return (stringcompci(s1,s2)>0) ? Truth:Ntruth;}
static PRIMITIVE leci(SCM s1,SCM s2){return (stringcompci(s1,s2)<=0)? Truth:Ntruth;}
static PRIMITIVE geci(SCM s1,SCM s2){return (stringcompci(s1,s2)>=0)? Truth:Ntruth;}
static PRIMITIVE Ceq (SCM c1, SCM c2){return (charcomp(c1,c2)==0) ? Truth: Ntruth;}
static PRIMITIVE Clt (SCM c1, SCM c2){return (charcomp(c1,c2)<0) ? Truth: Ntruth;}
static PRIMITIVE Cgt (SCM c1, SCM c2){return (charcomp(c1,c2)>0) ? Truth: Ntruth;}
static PRIMITIVE Cle (SCM c1, SCM c2){return (charcomp(c1,c2)<=0) ? Truth: Ntruth;}
static PRIMITIVE Cge (SCM c1, SCM c2){return (charcomp(c1,c2)>=0) ? Truth: Ntruth;}
static PRIMITIVE Ceqci(SCM c1, SCM c2){return (charcompci(c1,c2)==0)? Truth:Ntruth;}
static PRIMITIVE Cltci(SCM c1, SCM c2){return (charcompci(c1,c2)<0) ? Truth:Ntruth;}
static PRIMITIVE Cgtci(SCM c1, SCM c2){return (charcompci(c1,c2)>0) ? Truth:Ntruth;}
static PRIMITIVE Cleci(SCM c1, SCM c2){return (charcompci(c1,c2)<=0)? Truth:Ntruth;}
static PRIMITIVE Cgeci(SCM c1, SCM c2){return (charcompci(c1,c2)>=0)? Truth:Ntruth;}
PRIMITIVE STk_init_locale(void)
{
char *lang = getenv("LANG");
STk_add_new_primitive("set-locale!", tc_subr_1, set_locale);
STk_add_new_primitive("get-locale", tc_subr_0, get_locale);
STk_add_new_primitive("string-lo=?", tc_subr_2, eq);
STk_add_new_primitive("string-lo<?", tc_subr_2, lt);
STk_add_new_primitive("string-lo>?", tc_subr_2, gt);
STk_add_new_primitive("string-lo<=?", tc_subr_2, le);
STk_add_new_primitive("string-lo>=?", tc_subr_2, ge);
STk_add_new_primitive("string-lo-ci=?", tc_subr_2, eqci);
STk_add_new_primitive("string-lo-ci<?", tc_subr_2, ltci);
STk_add_new_primitive("string-lo-ci>?", tc_subr_2, gtci);
STk_add_new_primitive("string-lo-ci<=?", tc_subr_2, leci);
STk_add_new_primitive("string-lo-ci>=?", tc_subr_2, geci);
STk_add_new_primitive("char-lo=?", tc_subr_2, Ceq);
STk_add_new_primitive("char-lo<?", tc_subr_2, Clt);
STk_add_new_primitive("char-lo>?", tc_subr_2, Cgt);
STk_add_new_primitive("char-lo<=?", tc_subr_2, Cle);
STk_add_new_primitive("char-lo>=?", tc_subr_2, Cge);
STk_add_new_primitive("char-lo-ci=?", tc_subr_2, Ceqci);
STk_add_new_primitive("char-lo-ci<?", tc_subr_2, Cltci);
STk_add_new_primitive("char-lo-ci>?", tc_subr_2, Cgtci);
STk_add_new_primitive("char-lo-ci<=?", tc_subr_2, Cleci);
STk_add_new_primitive("char-lo-ci>=?", tc_subr_2, Cgeci);
locale_name = setlocale(LC_ALL, lang ? lang : "");
if(!locale_name)
/* LANG variable is erroneous, set locale to "C" */
locale_name = setlocale(LC_ALL, "C");
return UNDEFINED;
}