mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
Merge branch 'master' into identifier-macros
This commit is contained in:
Alex Shinn
GitHub
commit
9d2875b05e
14 changed files with 118 additions and 68 deletions
30
bignum.c
30
bignum.c
|
|
@ -999,8 +999,8 @@ sexp sexp_complex_sub (sexp ctx, sexp a, sexp b) {
|
|||
sexp_gc_var2(res, tmp);
|
||||
sexp_gc_preserve2(ctx, res, tmp);
|
||||
tmp = sexp_complex_copy(ctx, b);
|
||||
sexp_negate(sexp_complex_real(tmp));
|
||||
sexp_negate(sexp_complex_imag(tmp));
|
||||
sexp_negate_maybe_ratio(sexp_complex_real(tmp));
|
||||
sexp_negate_maybe_ratio(sexp_complex_imag(tmp));
|
||||
res = sexp_complex_add(ctx, a, tmp);
|
||||
sexp_gc_release2(ctx);
|
||||
return res;
|
||||
|
|
@ -1453,11 +1453,7 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
|
|||
sexp_negate_exact(sexp_ratio_numerator(tmp2));
|
||||
r = sexp_ratio_add(ctx, a, tmp2);
|
||||
if (negatep) {
|
||||
if (sexp_ratiop(r)) {
|
||||
sexp_negate_exact(sexp_ratio_numerator(r));
|
||||
} else {
|
||||
sexp_negate_exact(r);
|
||||
}
|
||||
sexp_negate_maybe_ratio(r);
|
||||
}
|
||||
break;
|
||||
#endif
|
||||
|
|
@ -1489,10 +1485,10 @@ sexp sexp_sub (sexp ctx, sexp a, sexp b) {
|
|||
if (negatep) {
|
||||
if (sexp_complexp(r)) {
|
||||
r = sexp_complex_copy(ctx, r);
|
||||
sexp_negate(sexp_complex_real(r));
|
||||
sexp_negate(sexp_complex_imag(r));
|
||||
sexp_negate_maybe_ratio(sexp_complex_real(r));
|
||||
sexp_negate_maybe_ratio(sexp_complex_imag(r));
|
||||
} else {
|
||||
sexp_negate(r);
|
||||
sexp_negate_maybe_ratio(r);
|
||||
}
|
||||
}
|
||||
break;
|
||||
|
|
@ -1886,12 +1882,13 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
|
|||
r = sexp_make_fixnum(sexp_unbox_fixnum(a) - sexp_unbox_fixnum(b));
|
||||
break;
|
||||
case SEXP_NUM_FIX_FLO:
|
||||
f = sexp_fixnum_to_double(a);
|
||||
g = sexp_flonum_value(b);
|
||||
if (isnan(g))
|
||||
if (isinf(sexp_flonum_value(b))) {
|
||||
r = sexp_flonum_value(b) > 0 ? SEXP_NEG_ONE : SEXP_ONE;
|
||||
} else if (isnan(sexp_flonum_value(b))) {
|
||||
r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", b);
|
||||
else
|
||||
r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
|
||||
} else {
|
||||
r = sexp_compare(ctx, a, tmp=sexp_inexact_to_exact(ctx, NULL, 1, b));
|
||||
}
|
||||
break;
|
||||
case SEXP_NUM_FIX_BIG:
|
||||
if ((sexp_bignum_hi(b) > 1) ||
|
||||
|
|
@ -1933,8 +1930,7 @@ sexp sexp_compare (sexp ctx, sexp a, sexp b) {
|
|||
} else if (isnan(f)) {
|
||||
r = sexp_xtype_exception(ctx, NULL, "can't compare NaN", a);
|
||||
} else {
|
||||
g = sexp_ratio_to_double(ctx, b);
|
||||
r = sexp_make_fixnum(f < g ? -1 : f == g ? 0 : 1);
|
||||
r = sexp_compare(ctx, tmp=sexp_inexact_to_exact(ctx, NULL, 1, a), b);
|
||||
}
|
||||
break;
|
||||
case SEXP_NUM_FIX_RAT:
|
||||
|
|
|
|||
|
|
@ -684,7 +684,9 @@ need to check manually before applying the predicate.
|
|||
\item{\ccode{sexp_fixnump(obj)} - \var{obj} is an immediate integer}
|
||||
\item{\ccode{sexp_flonump(obj)} - \var{obj} is an inexact real}
|
||||
\item{\ccode{sexp_bignump(obj)} - \var{obj} is a heap-allocated integer}
|
||||
\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer}
|
||||
\item{\ccode{sexp_integerp(obj)} - \var{obj} is an integer (or flonum truncating without loss)}
|
||||
\item{\ccode{sexp_ratiop(obj)} - \var{obj} is an exact rational (with SEXP_USE_RATIOS)}
|
||||
\item{\ccode{sexp_complexp(obj)} - \var{obj} is a complex number (with SEXP_USE_COMPLEX)}
|
||||
\item{\ccode{sexp_numberp(obj)} - \var{obj} is any kind of number}
|
||||
\item{\ccode{sexp_charp(obj)} - \var{obj} is a character}
|
||||
\item{\ccode{sexp_stringp(obj)} - \var{obj} is a string}
|
||||
|
|
@ -780,6 +782,8 @@ once.
|
|||
\item{\ccode{sexp_unbox_boolean(obj)} - 1 if \var{obj} is \scheme{#t}, 0 otherwise}
|
||||
\item{\ccode{sexp_make_fixnum(n)} - creates a new fixnum representing int \var{n}}
|
||||
\item{\ccode{sexp_unbox_fixnum(obj)} - converts a fixnum to a C integer}
|
||||
\item{\ccode{sexp_make_flonum(sexp ctx, float f)} - creates a new floating point value}
|
||||
\item{\ccode{sexp_flonum_value(obj)} - converts a flonum to a C float}
|
||||
\item{\ccode{sexp_make_character(ch)} - creates a new character representing char \var{ch}}
|
||||
\item{\ccode{sexp_unbox_character(obj)} - converts a character to a C char}
|
||||
\item{\ccode{sexp sexp_make_string_cursor(int offset)} - creates a string cursor for the given byte offset}
|
||||
|
|
@ -812,6 +816,7 @@ Any of these may fail and return the OOM exception object.
|
|||
\item{\ccode{sexp_cons(sexp ctx, sexp obj1, sexp obj2)} - create a new pair whose car is \var{obj1} and whose cdr is \var{obj2}}
|
||||
\item{\ccode{sexp_list1(sexp ctx, sexp obj)} - alias for sexp_cons(ctx, obj, SEXP_NULL)}
|
||||
\item{\ccode{sexp_list2(sexp ctx, sexp obj1, sexp obj2)} - create a list of two elements}
|
||||
\item{\ccode{sexp_list3(sexp ctx, sexp obj1, sexp obj2, sexp obj3)} - create a list of three elements}
|
||||
\item{\ccode{sexp_make_string(sexp ctx, sexp len, sexp ch)} - create a new Scheme string of \var{len} characters, all initialized to \var{ch}}
|
||||
\item{\ccode{sexp_c_string(sexp ctx, const char* str, int len)} - create a new Scheme string copying the first \var{len} characters of the C string \var{str}. If \var{len} is -1, uses strlen(\var{str}).}
|
||||
\item{\ccode{sexp_intern(sexp ctx, const char* str, int len)} - interns a symbol from the first \var{len} characters of the C string \var{str}. If \var{len} is -1, uses strlen(\var{str}).}
|
||||
|
|
@ -850,7 +855,7 @@ Any of these may fail and return the OOM exception object.
|
|||
\item{\ccode{sexp_assq(sexp ctx, sexp x, sexp ls)} - \scheme{assq}}
|
||||
\item{\ccode{sexp_reverse(sexp ctx, sexp ls)} - \scheme{reverse}}
|
||||
\item{\ccode{sexp_nreverse(sexp ctx, sexp ls)} - \scheme{reverse!}}
|
||||
\item{\ccode{sexp_append2(sexp ctx, sexp ls)} - \scheme{append} for two arguments}
|
||||
\item{\ccode{sexp_append2(sexp ctx, sexp ls1, sexp ls2)} - \scheme{append} for two arguments}
|
||||
\item{\ccode{sexp_copy_list(sexp ctx, sexp ls)} - return a shallow copy of \var{ls}}
|
||||
\item{\ccode{sexp_list_to_vector(sexp ctx, sexp ls)} - \scheme{list->vector}}
|
||||
\item{\ccode{sexp_symbol_to_string(sexp ctx, sexp sym)} - \scheme{symbol->string}}
|
||||
|
|
|
|||
4
gc.c
4
gc.c
|
|
@ -37,7 +37,7 @@ static sexp_heap sexp_heap_last (sexp_heap h) {
|
|||
return h;
|
||||
}
|
||||
|
||||
#if !SEXP_USE_FIXED_CHUNK_SIZE_HEAPS
|
||||
#if !SEXP_USE_FIXED_CHUNK_SIZE_HEAPS && !SEXP_USE_MALLOC
|
||||
static size_t sexp_heap_total_size (sexp_heap h) {
|
||||
size_t total_size = 0;
|
||||
for (; h; h=h->next)
|
||||
|
|
@ -696,6 +696,7 @@ int sexp_find_fixed_chunk_heap_usage(sexp ctx, size_t size, size_t* sum_freed, s
|
|||
}
|
||||
#endif
|
||||
|
||||
#if ! SEXP_USE_MALLOC
|
||||
void* sexp_alloc (sexp ctx, size_t size) {
|
||||
void *res;
|
||||
size_t max_freed, sum_freed, total_size=0;
|
||||
|
|
@ -741,6 +742,7 @@ void* sexp_alloc (sexp ctx, size_t size) {
|
|||
#endif
|
||||
return res;
|
||||
}
|
||||
#endif
|
||||
|
||||
|
||||
void sexp_gc_init (void) {
|
||||
|
|
|
|||
|
|
@ -129,6 +129,7 @@ SEXP_API sexp sexp_make_lit (sexp ctx, sexp value);
|
|||
SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
|
||||
SEXP_API sexp sexp_make_procedure_op (sexp ctx, sexp self, sexp_sint_t n, sexp flags, sexp num_args, sexp bc, sexp vars);
|
||||
SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
|
||||
SEXP_API sexp sexp_define_foreign_proc_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, const char *fname, sexp_proc1 f, sexp data);
|
||||
SEXP_API sexp sexp_register_optimization(sexp ctx, sexp self, sexp_sint_t n, sexp f, sexp i);
|
||||
#if SEXP_USE_AUTO_FORCE
|
||||
SEXP_API sexp sexp_make_promise (sexp ctx, sexp self, sexp_sint_t n, sexp done, sexp val);
|
||||
|
|
@ -194,6 +195,8 @@ SEXP_API sexp sexp_define_foreign_param_aux(sexp ctx, sexp env, const char *name
|
|||
#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(const char*)#f,(sexp_proc1)f,NULL)
|
||||
#define sexp_define_foreign_param(c,e,s,n,f,p) sexp_define_foreign_param_aux(c,e,s,n,(const char*)#f,(sexp_proc1)f,p)
|
||||
#define sexp_define_foreign_opt(c,e,s,n,f,p) sexp_define_foreign_aux(c,e,s,n,1,(const char*)#f,(sexp_proc1)f,p)
|
||||
#define sexp_define_foreign_proc(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_NONE,(const char*)#f,(sexp_proc1)f,NULL)
|
||||
#define sexp_define_foreign_proc_rest(c,e,s,n,f) sexp_define_foreign_proc_aux(c,e,s,n,SEXP_PROC_VARIADIC,(const char*)#f,(sexp_proc1)f,NULL)
|
||||
|
||||
#define sexp_env_key(x) sexp_car(x)
|
||||
#define sexp_env_value(x) sexp_cdr(x)
|
||||
|
|
|
|||
|
|
@ -324,6 +324,15 @@
|
|||
#define SEXP_MAX_ANALYZE_DEPTH 8192
|
||||
#endif
|
||||
|
||||
/* The size of flexible arrays (empty arrays at the end of a struct */
|
||||
/* representing the trailing data), when compiled with C++. Technically */
|
||||
/* 0 is an illegal value here, and the C++ idiom is to use 1, but this */
|
||||
/* breaks compatibility with C when computing the size of structs, and */
|
||||
/* in practice all of the major C++ compilers support 0. */
|
||||
#ifndef SEXP_FLEXIBLE_ARRAY_SIZE
|
||||
#define SEXP_FLEXIBLE_ARRAY_SIZE 0
|
||||
#endif
|
||||
|
||||
/************************************************************************/
|
||||
/* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */
|
||||
/************************************************************************/
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
/* sexp.h -- header for sexp library */
|
||||
/* Copyright (c) 2009-2015 Alex Shinn. All rights reserved. */
|
||||
/* Copyright (c) 2009-2022 Alex Shinn. All rights reserved. */
|
||||
/* BSD-style license: http://synthcode.com/license.txt */
|
||||
|
||||
#ifndef SEXP_H
|
||||
|
|
@ -7,7 +7,7 @@
|
|||
|
||||
#ifdef __cplusplus
|
||||
extern "C" {
|
||||
#define SEXP_FLEXIBLE_ARRAY [1]
|
||||
#define SEXP_FLEXIBLE_ARRAY [SEXP_FLEXIBLE_ARRAY_SIZE]
|
||||
#else
|
||||
#define SEXP_FLEXIBLE_ARRAY []
|
||||
#endif
|
||||
|
|
@ -523,7 +523,6 @@ struct sexp_struct {
|
|||
sexp parent;
|
||||
sexp_uint_t length;
|
||||
void *value;
|
||||
char body SEXP_FLEXIBLE_ARRAY;
|
||||
} cpointer;
|
||||
/* runtime types */
|
||||
struct {
|
||||
|
|
@ -1082,6 +1081,13 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
|
|||
else \
|
||||
sexp_negate_exact(x)
|
||||
|
||||
#define sexp_negate_maybe_ratio(x) \
|
||||
if (sexp_ratiop(x)) { \
|
||||
sexp_negate_exact(sexp_ratio_numerator(x)); \
|
||||
} else { \
|
||||
sexp_negate(x); \
|
||||
}
|
||||
|
||||
#if SEXP_USE_FLONUMS || SEXP_USE_BIGNUMS
|
||||
|
||||
#if SEXP_64_BIT
|
||||
|
|
@ -1258,7 +1264,6 @@ enum sexp_uniform_vector_type {
|
|||
|
||||
#define sexp_cpointer_freep(x) (sexp_freep(x))
|
||||
#define sexp_cpointer_length(x) (sexp_cpointer_field(x, length))
|
||||
#define sexp_cpointer_body(x) (sexp_cpointer_field(x, body))
|
||||
#define sexp_cpointer_parent(x) (sexp_cpointer_field(x, parent))
|
||||
#define sexp_cpointer_value(x) (sexp_cpointer_field(x, value))
|
||||
#define sexp_cpointer_maybe_null_value(x) (sexp_not(x) ? NULL : sexp_cpointer_value(x))
|
||||
|
|
@ -1760,6 +1765,7 @@ SEXP_API sexp sexp_file_exception (sexp ctx, sexp self, const char *msg, sexp x)
|
|||
SEXP_API sexp sexp_type_exception (sexp ctx, sexp self, sexp_uint_t type_id, sexp x);
|
||||
SEXP_API sexp sexp_xtype_exception (sexp ctx, sexp self, const char *msg, sexp x);
|
||||
SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end);
|
||||
SEXP_API sexp sexp_get_stack_trace (sexp ctx);
|
||||
SEXP_API sexp sexp_print_exception_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
|
||||
SEXP_API sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out);
|
||||
SEXP_API sexp sexp_print_exception_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp exn, sexp out);
|
||||
|
|
|
|||
|
|
@ -689,25 +689,6 @@
|
|||
(cond ((current-test-group)
|
||||
=> test-group-indent-width)
|
||||
(else 0)))))
|
||||
;; update group info
|
||||
(cond
|
||||
((current-test-group)
|
||||
=> (lambda (group)
|
||||
(if (not (eq? 'SKIP status))
|
||||
(test-group-inc! group 'count))
|
||||
(test-group-inc! group status)
|
||||
;; maybe wrap long status lines
|
||||
(let ((width (max (- (current-column-width)
|
||||
(test-group-indent-width group))
|
||||
(current-group-indent)))
|
||||
(column
|
||||
(+ (string-length (test-group-name group))
|
||||
(test-group-ref group 'count 0)
|
||||
1)))
|
||||
(if (and (zero? (modulo column width))
|
||||
(not (test-group-ref group 'verbose)))
|
||||
(display
|
||||
(string-copy indent (current-group-indent))))))))
|
||||
;; update global failure count for exit status
|
||||
(cond
|
||||
((or (eq? status 'FAIL) (eq? status 'ERROR))
|
||||
|
|
@ -730,6 +711,25 @@
|
|||
(test-group-push! group 'failures (list indent status info)))))
|
||||
(cond ((current-test-group)
|
||||
=> (lambda (group) (test-group-set! group 'trailing #t))))))
|
||||
;; update group info
|
||||
(cond
|
||||
((current-test-group)
|
||||
=> (lambda (group)
|
||||
(if (not (eq? 'SKIP status))
|
||||
(test-group-inc! group 'count))
|
||||
(test-group-inc! group status)
|
||||
;; maybe wrap long status lines
|
||||
(let ((width (max (- (current-column-width)
|
||||
(test-group-indent-width group))
|
||||
(current-group-indent)))
|
||||
(column
|
||||
(+ (string-length (test-group-name group))
|
||||
(test-group-ref group 'count 0)
|
||||
1)))
|
||||
(when (and (zero? (modulo column width))
|
||||
(not (test-group-ref group 'verbose)))
|
||||
(newline)
|
||||
(display (string-copy indent (current-group-indent))))))))
|
||||
(flush-output-port)
|
||||
status)
|
||||
|
||||
|
|
|
|||
|
|
@ -873,8 +873,8 @@
|
|||
(set! count (+ count 1))
|
||||
(rename (string->symbol (string-append s (%number->string count)))))
|
||||
(define (expand-pattern pat tmpl)
|
||||
(let lp ((p pat)
|
||||
(x _expr)
|
||||
(let lp ((p (if (pair? pat) (cdr pat) pat))
|
||||
(x (if (pair? pat) (list _cdr _expr) _expr))
|
||||
(dim 0)
|
||||
(vars '())
|
||||
(k (lambda (vars)
|
||||
|
|
|
|||
|
|
@ -82,9 +82,9 @@ static int sexp_isymbol_compare (sexp ctx, sexp a, sexp b) {
|
|||
#define sexp_non_immediate_ordered_numberp(x) 0
|
||||
#endif
|
||||
|
||||
static int sexp_object_compare (sexp ctx, sexp a, sexp b, int depth) {
|
||||
static sexp_sint_t sexp_object_compare (sexp ctx, sexp a, sexp b, int depth) {
|
||||
sexp ls1, ls2;
|
||||
int i, res, len;
|
||||
sexp_sint_t i, res, len;
|
||||
if (a == b)
|
||||
return 0;
|
||||
if (sexp_pointerp(a)) {
|
||||
|
|
|
|||
|
|
@ -122,8 +122,8 @@
|
|||
(test "sort various mixed" '(3 3.14 355/113 22/7 4)
|
||||
(sort '(355/113 4 22/7 3 3.14)))
|
||||
|
||||
(test "sort complex" '(3 3.14 355/113 22/7 3.14+0.0i 3.14+3.14i)
|
||||
(sort '(3.14+3.14i 355/113 3 22/7 3.14+0.0i 3.14)))
|
||||
;; (test "sort complex" '(3 3.14 355/113 22/7 3.14+0.0i 3.14+3.14i)
|
||||
;; (sort '(3.14+3.14i 355/113 3 22/7 3.14+0.0i 3.14)))
|
||||
|
||||
(test "sort stable" '((0 2) (0 3) (0 4) (1 1) (1 2) (1 3) (2 1) (2 2))
|
||||
(sort '((1 1) (0 2) (1 2) (2 1) (0 3) (2 2) (0 4) (1 3)) < car))
|
||||
|
|
|
|||
2
main.c
2
main.c
|
|
@ -560,7 +560,7 @@ sexp run_main (int argc, char **argv) {
|
|||
sym=sexp_intern(ctx, sexp_raw_script_file_symbol, -1), tmp);
|
||||
for (j=argc-1; j>=i; j--)
|
||||
args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args);
|
||||
if (main_symbol)
|
||||
if (main_module)
|
||||
args = sexp_cons(ctx, tmp=sexp_c_string(ctx,main_symbol,-1), args);
|
||||
if (args == SEXP_NULL)
|
||||
args = sexp_cons(ctx, tmp=sexp_c_string(ctx,"",-1), args);
|
||||
|
|
|
|||
16
sexp.c
16
sexp.c
|
|
@ -3634,9 +3634,9 @@ sexp sexp_read_raw (sexp ctx, sexp in, sexp *shares) {
|
|||
#if SEXP_USE_COMPLEX
|
||||
if (sexp_complexp(res)) {
|
||||
if (sexp_complex_real(res) == SEXP_ZERO) {
|
||||
sexp_negate(sexp_complex_imag(res));
|
||||
sexp_negate_maybe_ratio(sexp_complex_imag(res));
|
||||
} else {
|
||||
sexp_negate(sexp_complex_real(res));
|
||||
sexp_negate_maybe_ratio(sexp_complex_real(res));
|
||||
}
|
||||
} else
|
||||
#endif
|
||||
|
|
@ -3753,7 +3753,7 @@ sexp sexp_read_from_string (sexp ctx, const char *str, sexp_sint_t len) {
|
|||
|
||||
sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sexp b) {
|
||||
int base;
|
||||
sexp_gc_var1(in);
|
||||
sexp_gc_var2(in, res);
|
||||
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
|
||||
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, b);
|
||||
if (((base=sexp_unbox_fixnum(b)) < 2) || (base > 36))
|
||||
|
|
@ -3761,20 +3761,22 @@ sexp sexp_string_to_number_op (sexp ctx, sexp self, sexp_sint_t n, sexp str, sex
|
|||
if (sexp_string_data(str)[0]=='\0'
|
||||
|| (sexp_string_data(str)[1]=='\0' && !sexp_isxdigit((unsigned char)(sexp_string_data(str)[0]))))
|
||||
return SEXP_FALSE;
|
||||
sexp_gc_preserve1(ctx, in);
|
||||
sexp_gc_preserve2(ctx, in, res);
|
||||
in = sexp_open_input_string(ctx, str);
|
||||
if (sexp_string_data(str)[0] == '+') {
|
||||
if (sexp_isdigit((unsigned char)(sexp_string_data(str)[1]))
|
||||
|| sexp_string_data(str)[1] == '.' || sexp_string_data(str)[1] == '#')
|
||||
sexp_read_char(ctx, in);
|
||||
}
|
||||
in = ((sexp_string_data(str)[0] == '#' &&
|
||||
res = ((sexp_string_data(str)[0] == '#' &&
|
||||
sexp_tolower((unsigned char)sexp_string_data(str)[1]) != 'e' &&
|
||||
sexp_tolower((unsigned char)sexp_string_data(str)[1]) != 'i')
|
||||
|| base == 10 ? sexp_read(ctx, in) :
|
||||
sexp_read_number(ctx, in, base, 0));
|
||||
sexp_gc_release1(ctx);
|
||||
return sexp_numberp(in) ? in : SEXP_FALSE;
|
||||
if (!sexp_numberp(res) || sexp_peek_char(ctx, in) != EOF)
|
||||
res = SEXP_FALSE;
|
||||
sexp_gc_release2(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_write_to_string (sexp ctx, sexp obj) {
|
||||
|
|
|
|||
|
|
@ -798,6 +798,7 @@
|
|||
(test #f (< +nan.0 0.0))
|
||||
(test #f (> +nan.0 0.0))
|
||||
(test '(#t #f) (list (<= 1 1 2) (<= 2 1 3)))
|
||||
(test #f (= 9007199254740992.0 9007199254740993))
|
||||
|
||||
;; From R7RS 6.2.6 Numerical operations:
|
||||
;;
|
||||
|
|
@ -888,6 +889,8 @@
|
|||
(test -1 (- 3 4))
|
||||
(test -6 (- 3 4 5))
|
||||
(test -3 (- 3))
|
||||
(test -3/2 (- 3/2))
|
||||
(test -3/2-i (- 3/2+i))
|
||||
(test 3/20 (/ 3 4 5))
|
||||
(test 1/3 (/ 3))
|
||||
|
||||
|
|
@ -1025,6 +1028,7 @@
|
|||
(test 100 (string->number "100"))
|
||||
(test 256 (string->number "100" 16))
|
||||
(test 100.0 (string->number "1e2"))
|
||||
(test #f (string->number "1 2"))
|
||||
|
||||
(test-end)
|
||||
|
||||
|
|
|
|||
37
vm.c
37
vm.c
|
|
@ -787,18 +787,19 @@ static sexp make_param_list (sexp ctx, sexp_uint_t i) {
|
|||
return res;
|
||||
}
|
||||
|
||||
static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
|
||||
static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i, sexp_sint_t flags) {
|
||||
int j = i+(flags & SEXP_PROC_VARIADIC);
|
||||
sexp ls, res, env;
|
||||
sexp_gc_var6(bc, params, ref, refs, lambda, ctx2);
|
||||
if (i == sexp_opcode_num_args(op)) { /* return before preserving */
|
||||
if (j == sexp_opcode_num_args(op)) { /* return before preserving */
|
||||
if (sexp_opcode_proc(op)) return sexp_opcode_proc(op);
|
||||
} else if (i < sexp_opcode_num_args(op)) {
|
||||
} else if (j < sexp_opcode_num_args(op)) {
|
||||
return sexp_compile_error(ctx, "not enough args for opcode", op);
|
||||
} else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */
|
||||
return sexp_compile_error(ctx, "too many args for opcode", op);
|
||||
}
|
||||
sexp_gc_preserve6(ctx, bc, params, ref, refs, lambda, ctx2);
|
||||
params = make_param_list(ctx, i);
|
||||
params = make_param_list(ctx, j);
|
||||
lambda = sexp_make_lambda(ctx, params);
|
||||
ctx2 = sexp_make_child_context(ctx, lambda);
|
||||
env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda);
|
||||
|
|
@ -819,8 +820,8 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
|
|||
generate_opcode_app(ctx2, refs);
|
||||
bc = sexp_complete_bytecode(ctx2);
|
||||
sexp_bytecode_name(bc) = sexp_opcode_name(op);
|
||||
res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID);
|
||||
if (i == sexp_opcode_num_args(op))
|
||||
res=sexp_make_procedure(ctx2, sexp_make_fixnum(flags), sexp_make_fixnum(i), bc, SEXP_VOID);
|
||||
if (j == sexp_opcode_num_args(op))
|
||||
sexp_opcode_proc(op) = res;
|
||||
}
|
||||
}
|
||||
|
|
@ -828,6 +829,28 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) {
|
|||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_make_foreign_proc(sexp ctx, const char *name, int num_args, int flags,
|
||||
const char *fname, sexp_proc1 f) {
|
||||
sexp_gc_var1(res);
|
||||
sexp_gc_preserve1(ctx, res);
|
||||
res = sexp_make_foreign (ctx, name, num_args+((flags & SEXP_PROC_VARIADIC)>0), 0, fname, f, NULL);
|
||||
if (!sexp_exceptionp(res))
|
||||
res = make_opcode_procedure (ctx, res, num_args, flags);
|
||||
sexp_gc_release1(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
sexp sexp_define_foreign_proc_aux (sexp ctx, sexp env, const char *name,int num_args,
|
||||
int flags, const char *fname, sexp_proc1 f, sexp data) {
|
||||
sexp_gc_var2(sym, res);
|
||||
sexp_gc_preserve2(ctx, sym, res);
|
||||
res = sexp_make_foreign_proc(ctx, name, num_args, flags, fname, f);
|
||||
if (!sexp_exceptionp(res))
|
||||
sexp_env_define(ctx, env, sym = sexp_intern(ctx, name, -1), res);
|
||||
sexp_gc_release2(ctx);
|
||||
return res;
|
||||
}
|
||||
|
||||
/*********************** the virtual machine **************************/
|
||||
|
||||
sexp sexp_make_trampoline (sexp ctx, sexp proc, sexp args) {
|
||||
|
|
@ -1274,7 +1297,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
|
|||
sexp_context_top(ctx) = top;
|
||||
if (sexp_opcodep(tmp1)) {
|
||||
/* compile non-inlined opcode applications on the fly */
|
||||
tmp1 = make_opcode_procedure(ctx, tmp1, i);
|
||||
tmp1 = make_opcode_procedure(ctx, tmp1, i, SEXP_PROC_NONE);
|
||||
if (sexp_exceptionp(tmp1)) {
|
||||
_ARG1 = tmp1;
|
||||
goto call_error_handler;
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue