Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-05 12:16:37 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

string utilities

Browse source
This commit is contained in:
Alex Shinn 2009-04-02 18:35:08 +09:00
parent a27fe20de9
commit 2e55517108
7 changed files with 175 additions and 47 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
debug.c
View file

@ -10,7 +10,8 @@ static const char* reverse_opcode_names[] =
"STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "AND",
"NULL?", "FIXNUM?", "SYMBOL?", "CHAR?",
"EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
"MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQN", "EQ",
"MUL", "DIV", "QUOTIENT", "REMAINDER", "NEGATIVE", "INVERSE",
"LT", "LE", "EQN", "EQ",
"EXACT->INEXACT", "INEXACT->EXACT",
"CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
"DISPLAY", "WRITE", "WRITE-CHAR",

121
eval.c
View file

@ -285,7 +285,7 @@ static sexp sexp_identifier_eq (sexp e1, sexp id1, sexp e2, sexp id2) {
static sexp sexp_compile_error(char *message, sexp irritants) {
return sexp_make_exception(the_compile_error_symbol,
sexp_make_string(message),
sexp_c_string(message),
irritants, SEXP_FALSE, SEXP_FALSE);
}
@ -1280,21 +1280,26 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
else sexp_raise("/: not a number", sexp_list2(_ARG1, _ARG2));
top--;
break;
case OP_QUOT:
case OP_QUOTIENT:
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) {
if (_ARG1 == sexp_make_integer(0))
sexp_raise("divide by zero", SEXP_NULL);
_ARG2 = sexp_fx_div(_ARG1, _ARG2);
top--;
}
else sexp_raise("quotient: not a number", sexp_list2(_ARG1, _ARG2));
else sexp_raise("quotient: not an integer", sexp_list2(_ARG1, _ARG2));
break;
case OP_MOD:
case OP_REMAINDER:
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2)) {
_ARG2 = sexp_fx_mod(_ARG1, _ARG2);
if (_ARG1 == sexp_make_integer(0))
sexp_raise("divide by zero", SEXP_NULL);
tmp1 = sexp_fx_rem(_ARG1, _ARG2);
top--;
_ARG1 = tmp1;
}
else sexp_raise("modulo: not a number", sexp_list2(_ARG1, _ARG2));
else sexp_raise("remainder: not an integer", sexp_list2(_ARG1, _ARG2));
break;
case OP_NEG:
case OP_NEGATIVE:
if (sexp_integerp(_ARG1))
_ARG1 = sexp_make_integer(-sexp_unbox_integer(_ARG1));
#if USE_FLONUMS
@ -1303,7 +1308,7 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
#endif
else sexp_raise("-: not a number", sexp_list1(_ARG1));
break;
case OP_INV:
case OP_INVERSE:
if (sexp_integerp(_ARG1))
_ARG1 = sexp_make_flonum(1/(double)sexp_unbox_integer(_ARG1));
#if USE_FLONUMS
@ -1483,14 +1488,21 @@ sexp sexp_load (sexp source, sexp env) {
return res;
}
#if USE_MATH
static sexp sexp_math_exception (char *message, sexp obj) {
static sexp sexp_type_exception (char *message, sexp obj) {
return sexp_make_exception(sexp_intern("type-error"),
sexp_make_string(message),
sexp_c_string(message),
sexp_list1(obj), SEXP_FALSE, SEXP_FALSE);
}
static sexp sexp_range_exception (sexp obj, sexp start, sexp end) {
return sexp_make_exception(sexp_intern("range-error"),
sexp_c_string("bad index range"),
sexp_list3(obj, start, end),
SEXP_FALSE, SEXP_FALSE);
}
#if USE_MATH
#define define_math_op(name, cname) \
static sexp name (sexp z) { \
double d; \
@ -1499,7 +1511,7 @@ static sexp sexp_math_exception (char *message, sexp obj) {
else if (sexp_integerp(z)) \
d = (double)sexp_unbox_integer(z); \
else \
return sexp_math_exception("not a number", z); \
return sexp_type_exception("not a number", z); \
return sexp_make_flonum(cname(d)); \
}
@ -1528,7 +1540,7 @@ static sexp sexp_expt (sexp x, sexp e) {
x1 = sexp_flonum_value(x);
#endif
else
return sexp_math_exception("not a number", x);
return sexp_type_exception("not a number", x);
if (sexp_integerp(e))
e1 = (double)sexp_unbox_integer(e);
#if USE_FLONUMS
@ -1536,7 +1548,7 @@ static sexp sexp_expt (sexp x, sexp e) {
e1 = sexp_flonum_value(e);
#endif
else
return sexp_math_exception("not a number", e);
return sexp_type_exception("not a number", e);
res = pow(x1, e1);
#if USE_FLONUMS
if ((res > SEXP_MAX_INT) || sexp_flonump(x) || sexp_flonump(e))
@ -1545,6 +1557,79 @@ static sexp sexp_expt (sexp x, sexp e) {
return sexp_make_integer((sexp_sint_t)round(res));
}
static sexp sexp_substring (sexp str, sexp start, sexp end) {
sexp res;
if (! sexp_stringp(str))
return sexp_type_exception("not a string", str);
if (! sexp_integerp(start))
return sexp_type_exception("not a number", start);
if (end == SEXP_FALSE)
end = sexp_make_integer(sexp_string_length(str));
if (! sexp_integerp(end))
return sexp_type_exception("not a number", end);
if ((sexp_unbox_integer(start) < 0)
|| (sexp_unbox_integer(start) > sexp_string_length(str))
|| (sexp_unbox_integer(end) < 0)
|| (sexp_unbox_integer(end) > sexp_string_length(str))
|| (end < start))
return sexp_range_exception(str, start, end);
res = sexp_make_string(sexp_fx_sub(end, start),
SEXP_UNDEF);
memcpy(sexp_string_data(res),
sexp_string_data(str)+sexp_unbox_integer(start),
sexp_string_length(res));
return res;
}
static sexp sexp_string_concatenate (sexp str_ls) {
sexp res, ls;
sexp_uint_t len=0;
char *p;
for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls))
if (! sexp_stringp(sexp_car(ls)))
return sexp_type_exception("not a string", sexp_car(ls));
else
len += sexp_string_length(sexp_car(ls));
res = sexp_make_string(sexp_make_integer(len), SEXP_UNDEF);
p = sexp_string_data(res);
for (ls=str_ls; sexp_pairp(ls); ls=sexp_cdr(ls)) {
len = sexp_string_length(sexp_car(ls));
memcpy(p, sexp_string_data(sexp_car(ls)), len);
p += len;
}
return res;
}
static sexp sexp_string_cmp (sexp str1, sexp str2) {
sexp_sint_t len1, len2, len, diff;
if (! sexp_stringp(str1))
return sexp_type_exception("not a string", str1);
if (! sexp_stringp(str2))
return sexp_type_exception("not a string", str2);
len1 = sexp_string_length(str1);
len2 = sexp_string_length(str2);
len = ((len1<len2) ? len1 : len2);
diff = strncmp(sexp_string_data(str1), sexp_string_data(str2), len);
if (! diff)
diff = len1 - len2;
return sexp_make_integer(diff);
}
static sexp sexp_string_cmp_ci (sexp str1, sexp str2) {
sexp_sint_t len1, len2, len, diff;
if (! sexp_stringp(str1))
return sexp_type_exception("not a string", str1);
if (! sexp_stringp(str2))
return sexp_type_exception("not a string", str2);
len1 = sexp_string_length(str1);
len2 = sexp_string_length(str2);
len = ((len1<len2) ? len1 : len2);
diff = strncasecmp(sexp_string_data(str1), sexp_string_data(str2), len);
if (! diff)
diff = len1 - len2;
return sexp_make_integer(diff);
}
/*********************** standard environment *************************/
static struct sexp_struct core_forms[] = {
@ -1717,7 +1802,7 @@ void run_main (int argc, char **argv) {
case 'e':
case 'p':
if (! init_loaded) {
sexp_load(sexp_make_string(sexp_init_file), env);
sexp_load(sexp_c_string(sexp_init_file), env);
init_loaded = 1;
}
obj = sexp_read_from_string(argv[i+1]);
@ -1741,10 +1826,10 @@ void run_main (int argc, char **argv) {
if (! quit) {
if (! init_loaded)
sexp_load(sexp_make_string(sexp_init_file), env);
sexp_load(sexp_c_string(sexp_init_file), env);
if (i < argc)
for ( ; i < argc; i++)
sexp_load(sexp_make_string(argv[i]), env);
sexp_load(sexp_c_string(argv[i]), env);
else
repl(context);
}

8
eval.h
View file

@ -98,10 +98,10 @@ enum opcode_names {
OP_SUB,
OP_MUL,
OP_DIV,
OP_QUOT,
OP_MOD,
OP_NEG,
OP_INV,
OP_QUOTIENT,
OP_REMAINDER,
OP_NEGATIVE,
OP_INVERSE,
OP_LT,
OP_LE,
OP_EQN,

40
init.scm
View file

@ -1,13 +1,7 @@
;; let-syntax letrec-syntax syntax-rules
;; remainder modulo
;; number->string string->number
;; symbol->string string->symbol
;; make-string
;; string=? string-ci=? string<? string>?
;; string<=? string>=? string-ci<? string-ci>? string-ci<=? string-ci>=?
;; substring string-append string-copy
;; values call-with-values dynamic-wind
;; call-with-input-file call-with-output-file
;; with-input-from-file with-output-to-file
@ -341,6 +335,20 @@
(if (>= i 0) (begin (string-set! str i ch) (lp (- i 1))))))
(define (string . args) (list->string args))
(define (string-append . args) (string-concatenate args))
(define (string-copy s) (substring s 0 (string-length s)))
(define (string=? s1 s2) (eq? (string-cmp s1 s2) 0))
(define (string<? s1 s2) (< (string-cmp s1 s2) 0))
(define (string<=? s1 s2) (<= (string-cmp s1 s2) 0))
(define (string>? s1 s2) (> (string-cmp s1 s2) 0))
(define (string>=? s1 s2) (>= (string-cmp s1 s2) 0))
(define (string-ci=? s1 s2) (eq? (string-cmp-ci s1 s2) 0))
(define (string-ci<? s1 s2) (< (string-cmp-ci s1 s2) 0))
(define (string-ci<=? s1 s2) (<= (string-cmp-ci s1 s2) 0))
(define (string-ci>? s1 s2) (> (string-cmp-ci s1 s2) 0))
(define (string-ci>=? s1 s2) (>= (string-cmp-ci s1 s2) 0))
;; math utils
@ -360,6 +368,12 @@
(define (abs x) (if (< x 0) (- x) x))
(define (modulo a b)
(let ((res (remainder a b)))
(if (< b 0)
(if (< res 0) res (- res b))
(if (> res 0) res (+ res b)))))
(define (gcd a b)
(if (= b 0)
a
@ -413,3 +427,17 @@
(define (load file) (%load file (interaction-environment)))
;; values
(define *values-tag* (list 'values))
(define (values . ls)
(if (and (pair? ls) (null? (cdr ls)))
(car ls)
(cons *values-tag* ls)))
(define (call-with-values producer consumer)
(let ((res (producer)))
(if (and (pair? res) (eq? *values-tag* (car res)))
(apply consumer (cdr res))
(consumer res))))

13
opcodes.c
View file

@ -27,10 +27,10 @@ _OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", NULL, NUL
_OP(OPC_GENERIC, OP_CHAR_DOWNCASE, 1, 0, SEXP_CHAR, 0, 0, "char-downcase", NULL, NULL),
_OP(OPC_ARITHMETIC, OP_ADD, 0, 1, SEXP_FIXNUM, 0, 0, "+", NULL, NULL),
_OP(OPC_ARITHMETIC, OP_MUL, 0, 1, SEXP_FIXNUM, 0, 0, "*", NULL, NULL),
_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEG, "-", NULL, NULL),
_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INV, "/", NULL, NULL),
_OP(OPC_ARITHMETIC, OP_QUOT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL),
_OP(OPC_ARITHMETIC, OP_MOD, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "modulo", NULL, NULL),
_OP(OPC_ARITHMETIC_INV, OP_SUB, 0, 1, SEXP_FIXNUM, 0, OP_NEGATIVE, "-", NULL, NULL),
_OP(OPC_ARITHMETIC_INV, OP_DIV, 0, 1, SEXP_FIXNUM, 0, OP_INVERSE, "/", NULL, NULL),
_OP(OPC_ARITHMETIC, OP_QUOTIENT, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "quotient", NULL, NULL),
_OP(OPC_ARITHMETIC, OP_REMAINDER, 2, 0, SEXP_FIXNUM, SEXP_FIXNUM, 0, "remainder", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL),
@ -78,6 +78,11 @@ _FN1(SEXP_OPORT, "close-output-port", sexp_close_port),
_FN1(SEXP_FIXNUM, "null-environment", sexp_make_null_env),
_FN1(SEXP_FIXNUM, "scheme-report-environment", sexp_make_standard_env),
_FN2(0, SEXP_ENV, "%load", sexp_load),
_FN2(SEXP_FIXNUM, SEXP_CHAR, "make-string", sexp_make_string),
_FN2(SEXP_STRING, SEXP_STRING, "string-cmp", sexp_string_cmp),
_FN2(SEXP_STRING, SEXP_STRING, "string-cmp-ci", sexp_string_cmp_ci),
_FN3(SEXP_STRING, SEXP_FIXNUM, "substring", sexp_substring),
_FN1(SEXP_PAIR, "string-concatenate", sexp_string_concatenate),
#if USE_MATH
_FN1(0, "exp", sexp_exp),
_FN1(0, "log", sexp_log),

29
sexp.c
View file

@ -139,9 +139,9 @@ sexp sexp_print_exception (sexp exn, sexp out) {
static sexp sexp_read_error (char *message, sexp irritants, sexp port) {
sexp name = (sexp_port_name(port)
? sexp_make_string(sexp_port_name(port)) : SEXP_FALSE);
? sexp_c_string(sexp_port_name(port)) : SEXP_FALSE);
return sexp_make_exception(the_read_error_symbol,
sexp_make_string(message),
sexp_c_string(message),
irritants,
name,
sexp_make_integer(sexp_port_line(port)));
@ -269,13 +269,22 @@ sexp sexp_make_flonum(double f) {
return x;
}
sexp sexp_make_string(char *str) {
sexp sexp_make_string(sexp len, sexp ch) {
sexp s = sexp_alloc_type(string, SEXP_STRING);
sexp_uint_t clen = sexp_unbox_integer(len);
char *cstr = sexp_alloc(clen+1);
if (sexp_charp(ch))
memset(cstr, sexp_unbox_character(ch), clen);
cstr[clen] = '\0';
sexp_string_length(s) = clen;
sexp_string_data(s) = cstr;
return s;
}
sexp sexp_c_string(char *str) {
sexp_uint_t len = strlen(str);
char *mystr = sexp_alloc(len+1);
memcpy(mystr, str, len+1);
sexp_string_length(s) = len;
sexp_string_data(s) = mystr;
sexp s = sexp_make_string(sexp_make_integer(len), SEXP_UNDEF);
memcpy(sexp_string_data(s), str, len);
return s;
}
@ -754,7 +763,7 @@ sexp sexp_read_raw (sexp in) {
break;
case '"':
str = sexp_read_string(in);
res = sexp_make_string(str);
res = sexp_c_string(str);
sexp_free(str);
break;
case '(':
@ -847,7 +856,7 @@ sexp sexp_read_raw (sexp in) {
res = sexp_make_character('\t');
else {
res = sexp_read_error("unknown character name",
sexp_list1(sexp_make_string(str)),
sexp_list1(sexp_c_string(str)),
in);
}
}
@ -928,7 +937,7 @@ sexp sexp_read (sexp in) {
}
sexp sexp_read_from_string(char *str) {
sexp s = sexp_make_string(str);
sexp s = sexp_c_string(str);
sexp in = sexp_make_input_string_port(s);
sexp res = sexp_read(in);
sexp_deep_free(s);

8
sexp.h
View file

@ -344,7 +344,8 @@ struct sexp_struct {
#define sexp_fx_sub(a, b) ((sexp)(((sexp_sint_t)a)-((sexp_sint_t)b)+SEXP_FIXNUM_TAG))
#define sexp_fx_mul(a, b) ((sexp)((((((sexp_sint_t)a)-SEXP_FIXNUM_TAG)*(((sexp_sint_t)b)>>SEXP_FIXNUM_BITS))+SEXP_FIXNUM_TAG)))
#define sexp_fx_div(a, b) (sexp_make_integer(sexp_unbox_integer(a) / sexp_unbox_integer(b)))
#define sexp_fx_mod(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b)))
#define sexp_fx_rem(a, b) (sexp_make_integer(sexp_unbox_integer(a) % sexp_unbox_integer(b)))
#define sexp_fx_sign(a) (-((sexp_sint_t)(a) < 0)) /* -1 or 0 */
#define sexp_fp_add(a, b) (sexp_make_flonum(sexp_flonum_value(a) + sexp_flonum_value(b)))
#define sexp_fp_sub(a, b) (sexp_make_flonum(sexp_flonum_value(a) - sexp_flonum_value(b)))
@ -368,7 +369,6 @@ struct sexp_struct {
#define sexp_cadr(x) (sexp_car(sexp_cdr(x)))
#define sexp_cdar(x) (sexp_cdr(sexp_car(x)))
#define sexp_cddr(x) (sexp_cdr(sexp_cdr(x)))
#define sexp_caaar(x) (sexp_car(sexp_caar(x)))
#define sexp_caadr(x) (sexp_car(sexp_cadr(x)))
#define sexp_cadar(x) (sexp_car(sexp_cdar(x)))
@ -377,7 +377,6 @@ struct sexp_struct {
#define sexp_cdadr(x) (sexp_cdr(sexp_cadr(x)))
#define sexp_cddar(x) (sexp_cdr(sexp_cdar(x)))
#define sexp_cdddr(x) (sexp_cdr(sexp_cddr(x)))
#define sexp_cadddr(x) (sexp_cadr(sexp_cddr(x)))
#define sexp_cddddr(x) (sexp_cddr(sexp_cddr(x)))
@ -417,7 +416,8 @@ sexp sexp_append(sexp a, sexp b);
sexp sexp_memq(sexp x, sexp ls);
sexp sexp_assq(sexp x, sexp ls);
sexp sexp_length(sexp ls);
sexp sexp_make_string(char *str);
sexp sexp_c_string(char *str);
sexp sexp_make_string(sexp len, sexp ch);
sexp sexp_make_flonum(double f);
int sexp_string_hash(char *str, int acc);
sexp sexp_intern(char *str);