Add most SRFI 175 ASCII character procedures
This commit is contained in:
parent
738f8bec62
commit
0d315e320e
|
|
@ -0,0 +1,382 @@
|
|||
#include <sys/types.h>
|
||||
|
||||
#include <assert.h>
|
||||
#include <ctype.h>
|
||||
#include <errno.h>
|
||||
#include <math.h>
|
||||
#include <setjmp.h>
|
||||
#include <stdarg.h>
|
||||
#include <stdint.h>
|
||||
#include <stdio.h>
|
||||
#include <stdlib.h>
|
||||
#include <string.h>
|
||||
#include <wchar.h>
|
||||
#include <wctype.h>
|
||||
|
||||
#include "scheme.h"
|
||||
|
||||
value_t builtin_ascii_codepoint_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
int32_t cc;
|
||||
|
||||
argcount("ascii-codepoint?", nargs, 1);
|
||||
if (isfixnum(args[0])) {
|
||||
cc = numval(args[0]);
|
||||
if ((cc >= 0) && (cc < 128)) {
|
||||
return FL_T;
|
||||
}
|
||||
}
|
||||
return FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_char_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct cprim *cp;
|
||||
int32_t cc;
|
||||
|
||||
argcount("ascii-char?", nargs, 1);
|
||||
if (iscprim(args[0])) {
|
||||
cp = (struct cprim *)ptr(args[0]);
|
||||
if (cp_class(cp) == wchartype) {
|
||||
cc = *(int32_t *)cp_data(cp); // TODO: Is this right?
|
||||
if (cc < 128) {
|
||||
return FL_T;
|
||||
}
|
||||
}
|
||||
}
|
||||
return FL_F;
|
||||
}
|
||||
|
||||
static int32_t must_get_char_as_int(const char *procname, value_t *args,
|
||||
uint32_t nargs)
|
||||
{
|
||||
struct cprim *cp;
|
||||
int32_t cc;
|
||||
|
||||
argcount(procname, nargs, 1);
|
||||
if (isfixnum(args[0])) {
|
||||
return numval(args[0]); // TODO: range?
|
||||
}
|
||||
if (iscprim(args[0])) {
|
||||
cp = (struct cprim *)ptr(args[0]);
|
||||
if (cp_class(cp) == wchartype) {
|
||||
cc = *(int32_t *)cp_data(cp);
|
||||
return *(int32_t *)cp_data(cp); // TODO: Is this right?
|
||||
}
|
||||
}
|
||||
type_error(procname, "wchar or fixnum", args[0]);
|
||||
}
|
||||
|
||||
static int32_t map_char_int(const char *procname, int32_t (*mapfun)(int32_t),
|
||||
value_t *args, uint32_t nargs)
|
||||
{
|
||||
struct cprim *cp;
|
||||
int32_t cc;
|
||||
|
||||
argcount(procname, nargs, 1);
|
||||
if (isfixnum(args[0])) {
|
||||
return fixnum(mapfun(numval(args[0])));
|
||||
}
|
||||
if (iscprim(args[0])) {
|
||||
cp = (struct cprim *)ptr(args[0]);
|
||||
if (cp_class(cp) == wchartype) {
|
||||
cc = *(int32_t *)cp_data(cp);
|
||||
return mk_wchar(mapfun(cc)); // TODO: Is this right?
|
||||
}
|
||||
}
|
||||
type_error(procname, "wchar or byte", args[0]);
|
||||
}
|
||||
|
||||
static int32_t cc_base_offset_limit(int32_t cc, int32_t base, int32_t offset,
|
||||
int32_t limit, int32_t maxlimit)
|
||||
|
||||
{
|
||||
if (limit > maxlimit) {
|
||||
limit = maxlimit;
|
||||
}
|
||||
if ((cc >= base) && (cc < base + limit)) {
|
||||
return fixnum(offset + (base - cc));
|
||||
}
|
||||
return FL_F;
|
||||
}
|
||||
|
||||
//
|
||||
|
||||
static int32_t ascii_upcase_int(int32_t cc)
|
||||
{
|
||||
if ((cc >= 0x61) && (cc <= 0x7a)) {
|
||||
return cc - 0x20;
|
||||
}
|
||||
return cc;
|
||||
}
|
||||
|
||||
static int32_t ascii_downcase_int(int32_t cc)
|
||||
{
|
||||
if ((cc >= 0x41) && (cc <= 0x5a)) {
|
||||
return cc + 0x20;
|
||||
}
|
||||
return cc;
|
||||
}
|
||||
|
||||
static int32_t ascii_open_bracket_int(int32_t cc)
|
||||
{
|
||||
if ((cc == '(') || (cc == '[') || (cc == '{') || (cc == '<')) {
|
||||
return cc;
|
||||
}
|
||||
return -1;
|
||||
}
|
||||
|
||||
static int32_t ascii_close_bracket_int(int32_t cc)
|
||||
{
|
||||
if ((cc == ')') || (cc == ']') || (cc == '}') || (cc == '>')) {
|
||||
return cc;
|
||||
}
|
||||
return -1;
|
||||
}
|
||||
|
||||
static int32_t ascii_mirror_bracket_int(int32_t cc)
|
||||
{
|
||||
switch (cc) {
|
||||
case '(':
|
||||
return ')';
|
||||
case ')':
|
||||
return '(';
|
||||
case '[':
|
||||
return ']';
|
||||
case ']':
|
||||
return '[';
|
||||
case '{':
|
||||
return '}';
|
||||
case '}':
|
||||
return '{';
|
||||
case '<':
|
||||
return '>';
|
||||
case '>':
|
||||
return '<';
|
||||
}
|
||||
return -1;
|
||||
}
|
||||
|
||||
static int32_t ascii_control_to_display_int(int32_t cc)
|
||||
{
|
||||
if ((cc >= 0x00) && (cc <= 0x1f)) {
|
||||
return cc + 0x40;
|
||||
}
|
||||
if (cc == 0x7f) {
|
||||
return 0x3f;
|
||||
}
|
||||
return -1;
|
||||
}
|
||||
|
||||
static int32_t ascii_display_to_control_int(int32_t cc)
|
||||
{
|
||||
if ((cc >= 0x40) && (cc <= 0x5f)) {
|
||||
return cc - 0x40;
|
||||
}
|
||||
if (cc == 0x3f) {
|
||||
return 0x7f;
|
||||
}
|
||||
return -1;
|
||||
}
|
||||
|
||||
//
|
||||
|
||||
value_t builtin_ascii_control_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint32_t cc;
|
||||
|
||||
cc = must_get_char_as_int("ascii-control?", args, nargs);
|
||||
return (((cc >= 0x0) && (cc <= 0x1f)) || (cc == 0x7f)) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_display_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint32_t cc;
|
||||
|
||||
cc = must_get_char_as_int("ascii-display?", args, nargs);
|
||||
return ((cc >= 0x20) && (cc <= 0x7e)) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_whitespace_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint32_t cc;
|
||||
|
||||
cc = must_get_char_as_int("ascii-whitespace?", args, nargs);
|
||||
if (cc < 0x09) {
|
||||
return FL_F;
|
||||
}
|
||||
if (cc < 0x0e) {
|
||||
return FL_T;
|
||||
}
|
||||
return (cc == 0x20) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_space_or_tab_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint32_t cc;
|
||||
|
||||
cc = must_get_char_as_int("ascii-space-or-tab?", args, nargs);
|
||||
return ((cc == 0x09) || (cc == 0x20)) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_punctuation_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint32_t cc;
|
||||
|
||||
cc = must_get_char_as_int("ascii-punctuation?", args, nargs);
|
||||
if ((cc >= 0x21) && (cc <= 0x2f)) {
|
||||
return FL_T;
|
||||
}
|
||||
if ((cc >= 0x3a) && (cc <= 0x40)) {
|
||||
return FL_T;
|
||||
}
|
||||
if ((cc >= 0x5b) && (cc <= 0x60)) {
|
||||
return FL_T;
|
||||
}
|
||||
if ((cc >= 0x7b) && (cc <= 0x7e)) {
|
||||
return FL_T;
|
||||
}
|
||||
return FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_upper_case_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint32_t cc;
|
||||
|
||||
cc = must_get_char_as_int("ascii-upper-case?", args, nargs);
|
||||
return ((cc >= 0x41) && (cc <= 0x5a)) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_lower_case_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint32_t cc;
|
||||
|
||||
cc = must_get_char_as_int("ascii-lower-case?", args, nargs);
|
||||
return ((cc >= 0x61) && (cc <= 0x7a)) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_alphanumeric_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint32_t cc;
|
||||
|
||||
cc = must_get_char_as_int("ascii-alphanumeric?", args, nargs);
|
||||
if ((cc >= 0x30) && (cc <= 0x39)) {
|
||||
return FL_T;
|
||||
}
|
||||
if ((cc >= 0x41) && (cc <= 0x5a)) {
|
||||
return FL_T;
|
||||
}
|
||||
if ((cc >= 0x61) && (cc <= 0x7a)) {
|
||||
return FL_T;
|
||||
}
|
||||
return FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_numeric_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint32_t cc;
|
||||
|
||||
cc = must_get_char_as_int("ascii-numeric?", args, nargs);
|
||||
return ((cc >= 0x30) && (cc <= 0x39)) ? FL_T : FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_alphabetic_p(value_t *args, uint32_t nargs)
|
||||
{
|
||||
uint32_t cc;
|
||||
|
||||
cc = must_get_char_as_int("ascii-alphabetic?", args, nargs);
|
||||
return ((cc >= 0x41) && (cc <= 0x5a)) || ((cc >= 0x61) && (cc <= 0x7a));
|
||||
}
|
||||
|
||||
value_t builtin_ascii_upcase(value_t *args, uint32_t nargs)
|
||||
{
|
||||
return map_char_int("ascii-upcase", ascii_upcase_int, args, nargs);
|
||||
}
|
||||
|
||||
value_t builtin_ascii_downcase(value_t *args, uint32_t nargs)
|
||||
{
|
||||
return map_char_int("ascii-downcase", ascii_downcase_int, args, nargs);
|
||||
}
|
||||
|
||||
value_t builtin_ascii_open_bracket(value_t *args, uint32_t nargs)
|
||||
{
|
||||
return map_char_int("ascii-open-bracket", ascii_open_bracket_int, args,
|
||||
nargs);
|
||||
}
|
||||
|
||||
value_t builtin_ascii_close_bracket(value_t *args, uint32_t nargs)
|
||||
{
|
||||
return map_char_int("ascii-close-bracket", ascii_close_bracket_int, args,
|
||||
nargs);
|
||||
}
|
||||
|
||||
value_t builtin_ascii_mirror_bracket(value_t *args, uint32_t nargs)
|
||||
{
|
||||
return map_char_int("ascii-mirror-bracket", ascii_mirror_bracket_int,
|
||||
args, nargs);
|
||||
}
|
||||
|
||||
value_t builtin_ascii_control_to_display(value_t *args, uint32_t nargs)
|
||||
{
|
||||
return map_char_int("ascii-control->display",
|
||||
ascii_control_to_display_int, args, nargs);
|
||||
}
|
||||
|
||||
value_t builtin_ascii_display_to_control(value_t *args, uint32_t nargs)
|
||||
{
|
||||
return map_char_int("ascii-display->control",
|
||||
ascii_display_to_control_int, args, nargs);
|
||||
}
|
||||
|
||||
value_t builtin_ascii_nth_digit(value_t *args, uint32_t nargs)
|
||||
{
|
||||
int32_t i;
|
||||
|
||||
i = must_get_char_as_int("ascii-nth-digit", args, nargs);
|
||||
return ((i >= 0) && (i < 10)) ? mk_wchar(0x30 + i) : FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_nth_upper_case(value_t *args, uint32_t nargs)
|
||||
{
|
||||
int32_t i;
|
||||
|
||||
i = must_get_char_as_int("ascii-nth-upper-case", args, nargs);
|
||||
return ((i >= 0) && (i < 26)) ? mk_wchar(0x41 + i) : FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_nth_lower_case(value_t *args, uint32_t nargs)
|
||||
{
|
||||
int32_t i;
|
||||
|
||||
i = must_get_char_as_int("ascii-nth-lower-case", args, nargs);
|
||||
return ((i >= 0) && (i < 26)) ? mk_wchar(0x61 + i) : FL_F;
|
||||
}
|
||||
|
||||
value_t builtin_ascii_digit_value(value_t *args, uint32_t nargs)
|
||||
{
|
||||
int32_t cc, limit;
|
||||
|
||||
cc = must_get_char_as_int("ascii-digit-value", args, nargs);
|
||||
limit = 10; // TODO: really an arg
|
||||
return cc_base_offset_limit(cc, 0x30, 0, limit, 10);
|
||||
}
|
||||
|
||||
value_t builtin_ascii_upper_case_value(value_t *args, uint32_t nargs)
|
||||
{
|
||||
int32_t cc, offset, limit;
|
||||
|
||||
cc = must_get_char_as_int("ascii-upper-case-value", args, nargs);
|
||||
offset = 0; // TODO: really an arg
|
||||
limit = 26; // TODO: really an arg
|
||||
return cc_base_offset_limit(cc, 0x41, offset, limit, 26);
|
||||
}
|
||||
|
||||
value_t builtin_ascii_lower_case_value(value_t *args, uint32_t nargs)
|
||||
{
|
||||
int32_t cc, offset, limit;
|
||||
|
||||
cc = must_get_char_as_int("ascii-lower-case-value", args, nargs);
|
||||
offset = 0; // TODO: really an arg
|
||||
limit = 26; // TODO: really an arg
|
||||
return cc_base_offset_limit(cc, 0x61, offset, limit, 26);
|
||||
}
|
||||
|
|
@ -44,9 +44,10 @@ struct builtin_library {
|
|||
#define SRFI_0 (1 << 8)
|
||||
#define SRFI_13 (1 << 9) // String Libraries
|
||||
#define SRFI_170 (1 << 10) // POSIX API
|
||||
#define SRFI_175 (1 << 11) // POSIX API
|
||||
|
||||
// Up Scheme libraries
|
||||
#define UP_2019 (1 << 11)
|
||||
#define UP_2019 (1 << 20)
|
||||
|
||||
static struct builtin_procedure builtin_procedures[] = {
|
||||
#if 0
|
||||
|
|
@ -94,6 +95,44 @@ static struct builtin_procedure builtin_procedures[] = {
|
|||
{ "set-environment-variable", builtin_set_environment_variable,
|
||||
R7RS_PROCESS_CONTEXT | UP_2019 },
|
||||
|
||||
{ "ascii-codepoint?", builtin_ascii_codepoint_p, SRFI_175 | UP_2019 },
|
||||
//{ "ascii-bytevector?", builtin_ascii_bytevector_p, SRFI_175 | UP_2019 },
|
||||
{ "ascii-char?", builtin_ascii_char_p, SRFI_175 | UP_2019 },
|
||||
//{ "ascii-string?", builtin_ascii_string_p, SRFI_175 | UP_2019 },
|
||||
{ "ascii-control?", builtin_ascii_control_p, SRFI_175 | UP_2019 },
|
||||
{ "ascii-display?", builtin_ascii_display_p, SRFI_175 | UP_2019 },
|
||||
{ "ascii-space-or-tab?", builtin_ascii_space_or_tab_p,
|
||||
SRFI_175 | UP_2019 },
|
||||
{ "ascii-punctuation?", builtin_ascii_punctuation_p, SRFI_175 | UP_2019 },
|
||||
{ "ascii-alphanumeric?", builtin_ascii_alphanumeric_p,
|
||||
SRFI_175 | UP_2019 },
|
||||
{ "ascii-alphabetic?", builtin_ascii_alphabetic_p, SRFI_175 | UP_2019 },
|
||||
{ "ascii-numeric?", builtin_ascii_numeric_p, SRFI_175 | UP_2019 },
|
||||
{ "ascii-whitespace?", builtin_ascii_whitespace_p, SRFI_175 | UP_2019 },
|
||||
{ "ascii-upper-case?", builtin_ascii_upper_case_p, SRFI_175 | UP_2019 },
|
||||
{ "ascii-lower-case?", builtin_ascii_lower_case_p, SRFI_175 | UP_2019 },
|
||||
{ "ascii-upcase", builtin_ascii_upcase, SRFI_175 | UP_2019 },
|
||||
{ "ascii-downcase", builtin_ascii_downcase, SRFI_175 | UP_2019 },
|
||||
{ "ascii-open-bracket", builtin_ascii_open_bracket, SRFI_175 | UP_2019 },
|
||||
{ "ascii-close-bracket", builtin_ascii_close_bracket,
|
||||
SRFI_175 | UP_2019 },
|
||||
{ "ascii-mirror-bracket", builtin_ascii_mirror_bracket,
|
||||
SRFI_175 | UP_2019 },
|
||||
{ "ascii-control->display", builtin_ascii_control_to_display,
|
||||
SRFI_175 | UP_2019 },
|
||||
{ "ascii-display->control", builtin_ascii_display_to_control,
|
||||
SRFI_175 | UP_2019 },
|
||||
{ "ascii-nth-digit", builtin_ascii_nth_digit, SRFI_175 | UP_2019 },
|
||||
{ "ascii-nth-upper-case", builtin_ascii_nth_upper_case,
|
||||
SRFI_175 | UP_2019 },
|
||||
{ "ascii-nth-lower-case", builtin_ascii_nth_lower_case,
|
||||
SRFI_175 | UP_2019 },
|
||||
{ "ascii-digit-value", builtin_ascii_digit_value, SRFI_175 | UP_2019 },
|
||||
{ "ascii-upper-case-value", builtin_ascii_upper_case_value,
|
||||
SRFI_175 | UP_2019 },
|
||||
{ "ascii-lower-case-value", builtin_ascii_lower_case_value,
|
||||
SRFI_175 | UP_2019 },
|
||||
|
||||
{ 0, 0, 0 },
|
||||
};
|
||||
|
||||
|
|
|
|||
28
c/scheme.h
28
c/scheme.h
|
|
@ -169,6 +169,34 @@ int u8_isvalid(const char *str, int length);
|
|||
// be allocated to at least len+1 bytes. returns 1 for error, 0 otherwise
|
||||
int u8_reverse(char *dest, char *src, size_t len);
|
||||
|
||||
//// char.c
|
||||
|
||||
value_t builtin_ascii_codepoint_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_char_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_control_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_display_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_whitespace_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_space_or_tab_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_punctuation_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_upper_case_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_lower_case_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_alphanumeric_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_numeric_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_alphabetic_p(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_upcase(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_downcase(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_open_bracket(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_close_bracket(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_mirror_bracket(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_control_to_display(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_display_to_control(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_nth_digit(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_nth_upper_case(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_nth_lower_case(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_digit_value(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_upper_case_value(value_t *args, uint32_t nargs);
|
||||
value_t builtin_ascii_lower_case_value(value_t *args, uint32_t nargs);
|
||||
|
||||
//// #include "ios.h"
|
||||
|
||||
// this flag controls when data actually moves out to the underlying I/O
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ o_files="$o_files bitvector.o"
|
|||
o_files="$o_files boot_image.o"
|
||||
o_files="$o_files buf.o"
|
||||
o_files="$o_files builtins.o"
|
||||
o_files="$o_files char.o"
|
||||
o_files="$o_files dump.o"
|
||||
o_files="$o_files env_unix.o"
|
||||
o_files="$o_files equalhash.o"
|
||||
|
|
@ -98,6 +99,7 @@ $CC $CFLAGS -c ../c/bitvector-ops.c
|
|||
$CC $CFLAGS -c ../c/bitvector.c
|
||||
$CC $CFLAGS -c ../c/buf.c
|
||||
$CC $CFLAGS -c ../c/builtins.c
|
||||
$CC $CFLAGS -c ../c/char.c
|
||||
$CC $CFLAGS -c ../c/dump.c
|
||||
$CC $CFLAGS -c ../c/env_unix.c
|
||||
$CC $CFLAGS -c ../c/equalhash.c
|
||||
|
|
|
|||
Loading…
Reference in New Issue