Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-21 14:49:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

types are now context-group local by default.

Browse source
This commit is contained in:
Alex Shinn 2009-12-26 23:46:54 +09:00
parent 7eae77d0f9
commit e9d6f1857a
19 changed files with 196 additions and 111 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

7
Makefile
View file

@ -81,10 +81,9 @@ endif
all: chibi-scheme$(EXE) libs
COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) \
lib/chibi/ast$(SO) lib/chibi/net$(SO) \
lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \
lib/chibi/time$(SO) lib/chibi/heap-stats$(SO)
lib/srfi/69/hash$(SO) lib/srfi/98/env$(SO) lib/chibi/ast$(SO) \
lib/chibi/net$(SO) lib/chibi/filesystem$(SO) lib/chibi/process$(SO) \
lib/chibi/time$(SO) lib/chibi/system$(SO) lib/chibi/heap-stats$(SO)
libs: $(COMPILED_LIBS)

2
TODO
View file

@ -60,6 +60,7 @@
- State "DONE" [2009-07-07 Tue 14:42]
** TODO unicode
** TODO threads
** TODO virtual ports
** DONE dynamic-wind
- State "DONE" [2009-12-26 Sat 01:51]
Adapted a version from Scheme48.
@ -138,6 +139,7 @@
** TODO overall cleanup
** TODO user documentation
** TODO thorough source documentation
** TODO full test suite for libraries
* distribution
** TODO packaging format

23
eval.c
View file

@ -1609,13 +1609,13 @@ sexp sexp_vm (sexp ctx, sexp proc) {
break;
case SEXP_OP_SLOT_REF:
if (! sexp_check_tag(_ARG1, _UWORD0))
sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1));
sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1));
_ARG1 = sexp_slot_ref(_ARG1, _UWORD1);
ip += sizeof(sexp)*2;
break;
case SEXP_OP_SLOT_SET:
if (! sexp_check_tag(_ARG1, _UWORD0))
sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(_UWORD0), -1), _ARG1));
sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1));
else if (sexp_immutablep(_ARG1))
sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1));
sexp_slot_set(_ARG1, _UWORD1, _ARG2);
@ -2154,12 +2154,27 @@ define_math_op(sexp_tan, tan)
define_math_op(sexp_asin, asin)
define_math_op(sexp_acos, acos)
define_math_op(sexp_atan, atan)
define_math_op(sexp_sqrt, sqrt)
define_math_op(sexp_round, round)
define_math_op(sexp_trunc, trunc)
define_math_op(sexp_floor, floor)
define_math_op(sexp_ceiling, ceil)
static sexp sexp_sqrt (sexp ctx, sexp z) {
double d, r;
if (sexp_flonump(z))
d = sexp_flonum_value(z);
else if (sexp_fixnump(z))
d = (double)sexp_unbox_fixnum(z);
maybe_convert_bignum(z) /* XXXX add bignum sqrt */
else
return sexp_type_exception(ctx, "not a number", z);
r = sqrt(d);
if (sexp_fixnump(z) && ((r*r) == (double)sexp_unbox_fixnum(z)))
return sexp_make_fixnum(round(r));
else
return sexp_make_flonum(ctx, r);
}
#endif
static sexp sexp_expt (sexp ctx, sexp x, sexp e) {
@ -2354,7 +2369,7 @@ sexp sexp_make_constructor (sexp ctx, sexp name, sexp type) {
sexp_uint_t type_size;
if (! sexp_fixnump(type))
return sexp_type_exception(ctx, "make-constructor: bad type", type);
type_size = sexp_type_size_base(&(sexp_type_specs[sexp_unbox_fixnum(type)]));
type_size = sexp_type_size_base(sexp_type_by_index(ctx, sexp_unbox_fixnum(type)));
return sexp_make_opcode(ctx, name, sexp_make_fixnum(SEXP_OPC_CONSTRUCTOR),
sexp_make_fixnum(SEXP_OP_MAKE), SEXP_ZERO, SEXP_ZERO,
SEXP_ZERO, SEXP_ZERO, SEXP_ZERO, type,

22
gc.c
View file

@ -44,17 +44,17 @@ static sexp_heap sexp_heap_last (sexp_heap h) {
return h;
}
sexp_uint_t sexp_allocated_bytes (sexp x) {
sexp_uint_t sexp_allocated_bytes (sexp ctx, sexp x) {
sexp_uint_t res;
sexp t;
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_num_types))
if ((! sexp_pointerp(x)) || (sexp_pointer_tag(x) >= sexp_context_num_types(ctx)))
return sexp_heap_align(1);
t = &(sexp_type_specs[sexp_pointer_tag(x)]);
t = sexp_object_type(ctx, x);
res = sexp_type_size_of_object(t, x);
return res;
}
void sexp_mark (sexp x) {
void sexp_mark (sexp ctx, sexp x) {
sexp_sint_t i, len;
sexp t, *p;
struct sexp_gc_var_t *saves;
@ -64,13 +64,13 @@ void sexp_mark (sexp x) {
sexp_gc_mark(x) = 1;
if (sexp_contextp(x))
for (saves=sexp_context_saves(x); saves; saves=saves->next)
if (saves->var) sexp_mark(*(saves->var));
t = &(sexp_type_specs[sexp_pointer_tag(x)]);
if (saves->var) sexp_mark(ctx, *(saves->var));
t = sexp_object_type(ctx, x);
p = (sexp*) (((char*)x) + sexp_type_field_base(t));
len = sexp_type_num_slots_of_object(t, x) - 1;
if (len >= 0) {
for (i=0; i<len; i++)
sexp_mark(p[i]);
sexp_mark(ctx, p[i]);
x = p[len];
goto loop;
}
@ -108,10 +108,10 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) {
p = (sexp) (((char*)p) + r->size);
continue;
}
size = sexp_heap_align(sexp_allocated_bytes(p));
size = sexp_heap_align(sexp_allocated_bytes(ctx, p));
if ((! sexp_gc_mark(p)) && (! stack_references_pointer_p(ctx, p))) {
/* free p */
finalizer = sexp_type_finalize(sexp_object_type(p));
finalizer = sexp_type_finalize(sexp_object_type(ctx, p));
if (finalizer) finalizer(ctx, p);
sum_freed += size;
if (((((char*)q) + q->size) == (char*)p) && (q != h->free_list)) {
@ -159,9 +159,9 @@ sexp sexp_gc (sexp ctx, size_t *sum_freed) {
#if SEXP_USE_GLOBAL_SYMBOLS
int i;
for (i=0; i<SEXP_SYMBOL_TABLE_SIZE; i++)
sexp_mark(sexp_symbol_table[i]);
sexp_mark(ctx, sexp_symbol_table[i]);
#endif
sexp_mark(ctx);
sexp_mark(ctx, ctx);
res = sexp_sweep(ctx, sum_freed);
return res;
}

3
include/chibi/config.h
View file

@ -53,6 +53,9 @@
/* #define SEXP_USE_GLOBAL_HEAP 1 */
/* uncomment this to make type definitions common to all contexts */
/* By default types are only global if you don't allow user type */
/* definitions, so new types will be local to a given set of */
/* contexts sharing thei heap. */
/* #define SEXP_USE_GLOBAL_TYPES 1 */
/* uncomment this to make the symbol table common to all contexts */

45
include/chibi/sexp.h
View file

@ -383,23 +383,6 @@ void *sexp_realloc(sexp ctx, sexp x, size_t size);
#define sexp_immutablep(x) ((x)->immutablep)
#define sexp_freep(x) ((x)->freep)
#define sexp_object_type(x) (&(sexp_type_specs[(x)->tag]))
#define sexp_object_type_name(x) (sexp_type_name(sexp_object_type(x)))
#define sexp_type_name_by_index(x) (sexp_type_name(&(sexp_type_specs[(x)])))
#define sexp_type_size_of_object(t, x) \
(((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \
* sexp_type_size_scale(t) \
+ sexp_type_size_base(t))
#define sexp_type_num_slots_of_object(t, x) \
(((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \
* sexp_type_field_len_scale(t) \
+ sexp_type_field_len_base(t))
#define sexp_type_num_eq_slots_of_object(t, x) \
(((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \
* sexp_type_field_len_scale(t) \
+ sexp_type_field_eq_len_base(t))
#define sexp_check_tag(x,t) (sexp_pointerp(x) && (sexp_pointer_tag(x) == (t)))
#define sexp_slot_ref(x,i) (((sexp*)&((x)->value))[i])
@ -645,11 +628,37 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x);
#endif
#if SEXP_USE_GLOBAL_TYPES
SEXP_API struct sexp_struct *sexp_type_specs;
#define sexp_context_types(ctx) sexp_type_specs
#define sexp_type_by_index(ctx,i) (&(sexp_context_types(ctx)[i]))
#define sexp_context_num_types(ctx) sexp_num_types
#define sexp_context_type_array_size(ctx) sexp_type_array_size
#else
#define sexp_context_types(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES))
#define sexp_type_by_index(ctx,i) (sexp_context_types(ctx)[i])
#define sexp_context_num_types(ctx) \
sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_NUM_TYPES))
#define sexp_context_type_array_size(ctx) \
sexp_vector_length(sexp_global(ctx, SEXP_G_TYPES))
#endif
#define sexp_object_type(ctx,x) (sexp_type_by_index(ctx, ((x)->tag)))
#define sexp_object_type_name(ctx,x) (sexp_type_name(sexp_object_type(ctx, x)))
#define sexp_type_name_by_index(ctx,i) (sexp_type_name(sexp_type_by_index(ctx,i)))
#define sexp_type_size_of_object(t, x) \
(((sexp_uint_t*)((char*)x + sexp_type_size_off(t)))[0] \
* sexp_type_size_scale(t) \
+ sexp_type_size_base(t))
#define sexp_type_num_slots_of_object(t, x) \
(((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \
* sexp_type_field_len_scale(t) \
+ sexp_type_field_len_base(t))
#define sexp_type_num_eq_slots_of_object(t, x) \
(((sexp_uint_t*)((char*)x + sexp_type_field_len_off(t)))[0] \
* sexp_type_field_len_scale(t) \
+ sexp_type_field_eq_len_base(t))
#define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x)))
#define sexp_type_tag(x) ((x)->value.type.tag)
@ -692,6 +701,7 @@ enum sexp_context_globals {
#endif
#if ! SEXP_USE_GLOBAL_TYPES
SEXP_G_TYPES,
SEXP_G_NUM_TYPES,
#endif
SEXP_G_OOM_ERROR, /* out of memory exception object */
SEXP_G_OOS_ERROR, /* out of stack exception object */
@ -768,7 +778,6 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p);
#define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p))
SEXP_API struct sexp_struct *sexp_type_specs;
SEXP_API sexp sexp_make_context(sexp ctx);
SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag);
SEXP_API sexp sexp_cons(sexp ctx, sexp head, sexp tail);

5
lib/chibi/filesystem.module
View file

@ -15,6 +15,11 @@
file-regular? file-directory? file-character?
file-block? file-fifo? file-link?
file-socket?
get-file-descriptor-flags set-file-descriptor-flags!
get-file-descriptor-status set-file-descriptor-status!
open/read open/write open/read-write
open/create open/exclusive open/truncate
open/append open/non-block
)
(import-immutable (scheme))
(include-shared "filesystem")

27
lib/chibi/filesystem.stub
View file

@ -2,6 +2,7 @@
(c-system-include "sys/types.h")
(c-system-include "unistd.h")
(c-system-include "dirent.h")
(c-system-include "fcntl.h")
(define-c-type DIR
finalizer: closedir)
@ -86,3 +87,29 @@
(define-c errno (open-pipe "pipe") ((result (array int 2))))
(define-c errno (make-fifo "mkfifo") (string (default #o644 int)))
(define-c int (get-file-descriptor-flags "fcntl")
(int (value F_GETFD int)))
(define-c errno (set-file-descriptor-flags! "fcntl")
(int (value F_SETFD int) long))
(define-c int (get-file-descriptor-status "fcntl")
(int (value F_GETFL int)))
(define-c errno (set-file-descriptor-status! "fcntl")
(int (value F_SETFL int) long))
;; (define-c int (get-file-descriptor-lock "fcntl")
;; (int (value F_GETLK int) flock))
;; (define-c errno (set-file-descriptor-lock! "fcntl")
;; (int (value F_SETLK int) flock))
;; (define-c errno (try-set-file-descriptor-lock! "fcntl")
;; (int (value F_SETLKW int) flock))
(define-c-const int (open/read "O_RDONLY"))
(define-c-const int (open/write "O_WRONLY"))
(define-c-const int (open/read-write "O_RDWR"))
(define-c-const int (open/create "O_CREAT"))
(define-c-const int (open/exclusive "O_EXCL"))
(define-c-const int (open/truncate "O_TRUNC"))
(define-c-const int (open/append "O_APPEND"))
(define-c-const int (open/non-block "O_NONBLOCK"))

4
lib/chibi/heap-stats.c
View file

@ -42,7 +42,7 @@ static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) {
} else {
print_name:
sexp_write_string(ctx, "#<", out);
sexp_write_string(ctx, sexp_object_type_name(x), out);
sexp_write_string(ctx, sexp_object_type_name(ctx, x), out);
sexp_write_string(ctx, ">", out);
}
}
@ -97,7 +97,7 @@ static sexp sexp_heap_walk (sexp ctx, int depth, int printp) {
res = SEXP_NULL;
for (i=hi_type; i>0; i--)
if (stats[i]) {
name = sexp_intern(ctx, sexp_type_name_by_index(i));
name = sexp_intern(ctx, sexp_type_name_by_index(ctx, i));
tmp = sexp_cons(ctx, name, sexp_make_fixnum(stats[i]));
res = sexp_cons(ctx, tmp, res);
}

2
lib/chibi/net.module
View file

@ -4,7 +4,7 @@
address-info-family address-info-socket-type address-info-protocol
address-info-address address-info-address-length address-info-next)
(import-immutable (scheme))
(import (chibi posix))
(import (chibi filesystem))
(include-shared "net")
(include "net.scm"))

4
lib/chibi/net.scm
View file

@ -13,8 +13,8 @@
(address-info-address addr)
(address-info-address-length addr)))
(lp (address-info-next addr))
(let ((in (open-input-fd sock))
(out (open-output-fd sock)))
(let ((in (open-input-file-descriptor sock))
(out (open-output-file-descriptor sock)))
(let ((res (proc in out)))
(close-input-port in)
res))))))))

1
lib/chibi/net.stub
View file

@ -23,4 +23,3 @@
(define-c int listen (int int))
(define-c int socket (int int int))
(define-c int connect (int sockaddr int))

2
lib/chibi/process.module
View file

@ -1,6 +1,6 @@
(define-module (chibi process)
(export exit sleep fork kill execute waitpid
(export exit sleep alarm fork kill execute waitpid
set-signal-action! make-signal-set signal-set-contains?
signal-set-fill! signal-set-add! signal-set-delete!
current-signal-mask

4
lib/chibi/process.stub
View file

@ -59,12 +59,14 @@
(define-c errno (current-signal-mask "sigprocmask")
((value SIG_BLOCK int) (value NULL sigset_t) (result sigset_t)))
(define-c unsigned-int alarm (unsigned-int))
(define-c unsigned-int sleep (unsigned-int))
(define-c pid_t fork ())
;;(define-c pid_t wait ((result int)))
(define-c pid_t waitpid (int (result int) int))
(define-c errno kill (int int))
;;(define-c errno raise (int))
(define-c unsigned-int sleep (unsigned-int))
(define-c void exit (int))
(define-c int (execute execvp) (string (array string)))

5
lib/srfi/1/search.scm
View file

@ -30,10 +30,11 @@
(define (any pred ls . lists)
(if (null? lists)
(let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) #t (lp (cdr ls)))))
(let lp ((ls ls)) (and (pair? ls) (if (pred (car ls)) (car ls) (lp (cdr ls)))))
(let lp ((lists (cons ls lists)))
(and (every pair? lists)
(if (apply pred (map car lists)) #t (lp (map cdr lists)))))))
(let ((args (map car lists)))
(if (apply pred args) args (lp (map cdr lists))))))))
(define (every pred ls . lists)
(if (null? lists)

12
lib/srfi/69/hash.c
View file

@ -44,7 +44,7 @@ static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) {
sexp_unbox_fixnum(bound)));
}
static sexp_uint_t hash_one (sexp obj, sexp_uint_t bound, sexp_sint_t depth) {
static sexp_uint_t hash_one (sexp ctx, sexp obj, sexp_uint_t bound, sexp_sint_t depth) {
sexp_uint_t acc = FNV_OFFSET_BASIS, size;
sexp_sint_t i, len;
sexp t, *p;
@ -57,7 +57,7 @@ static sexp_uint_t hash_one (sexp obj, sexp_uint_t bound, sexp_sint_t depth) {
#endif
if (sexp_pointerp(obj)) {
if (depth) {
t = &(sexp_type_specs[sexp_pointer_tag(obj)]);
t = sexp_object_type(ctx, obj);
p = (sexp*) (((char*)obj) + sexp_type_field_base(t));
p0 = ((char*)obj) + offsetof(struct sexp_struct, value);
if ((sexp)p == obj) p=(sexp*)p0;
@ -72,7 +72,7 @@ static sexp_uint_t hash_one (sexp obj, sexp_uint_t bound, sexp_sint_t depth) {
depth--;
for (i=0; i<len-1; i++) {
acc *= FNV_PRIME;
acc ^= hash_one(p[i], 0, depth);
acc ^= hash_one(ctx, p[i], 0, depth);
}
/* tail-recurse on the last value */
obj = p[len-1]; goto loop;
@ -86,14 +86,10 @@ static sexp_uint_t hash_one (sexp obj, sexp_uint_t bound, sexp_sint_t depth) {
return (bound ? acc % bound : acc);
}
static sexp_uint_t hash (sexp obj, sexp_uint_t bound) {
return hash_one(obj, bound, HASH_DEPTH);
}
static sexp sexp_hash (sexp ctx, sexp obj, sexp bound) {
if (! sexp_exact_integerp(bound))
return sexp_type_exception(ctx, "hash: not an integer", bound);
return sexp_make_fixnum(hash(obj, sexp_unbox_fixnum(bound)));
return sexp_make_fixnum(hash_one(ctx, obj, sexp_unbox_fixnum(bound), HASH_DEPTH));
}
static sexp sexp_hash_by_identity (sexp ctx, sexp obj, sexp bound) {

103
sexp.c
View file

@ -102,39 +102,61 @@ static struct sexp_struct _sexp_type_specs[] = {
};
#undef _DEF_TYPE
#if SEXP_USE_GLOBAL_TYPES
struct sexp_struct *sexp_type_specs = _sexp_type_specs;
#endif
#if SEXP_USE_TYPE_DEFS
#if SEXP_USE_GLOBAL_TYPES
static sexp_uint_t sexp_num_types = SEXP_NUM_CORE_TYPES;
static sexp_uint_t sexp_type_array_size = SEXP_NUM_CORE_TYPES;
#else
#define SEXP_INIT_NUM_TYPES (SEXP_NUM_CORE_TYPES*2)
#endif
sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb,
sexp flo, sexp fls, sexp sb, sexp so, sexp sc,
sexp_proc2 f) {
struct sexp_struct *type, *new, *tmp;
sexp res;
sexp_uint_t i, len;
if (sexp_num_types >= SEXP_MAXIMUM_TYPES) {
fprintf(stderr, "chibi: exceeded maximum type limit\n");
res = SEXP_FALSE;
#if SEXP_USE_GLOBAL_TYPES
struct sexp_struct *new, *tmp;
#else
sexp *v1, *v2;
#endif
sexp res, type;
sexp_uint_t i, len, num_types=sexp_context_num_types(ctx),
type_array_size=sexp_context_type_array_size(ctx);
if (num_types >= SEXP_MAXIMUM_TYPES) {
res = sexp_user_exception(ctx, SEXP_FALSE, "register-type: exceeded maximum type limit", name);
} else if (! sexp_stringp(name)) {
res = sexp_type_exception(ctx, "register-type: not a string", name);
} else {
if (sexp_num_types >= sexp_type_array_size) {
len = sexp_type_array_size*2;
if (num_types >= type_array_size) {
len = type_array_size*2;
if (len > SEXP_MAXIMUM_TYPES) len = SEXP_MAXIMUM_TYPES;
#if SEXP_USE_GLOBAL_TYPES
new = malloc(len * sizeof(_sexp_type_specs[0]));
for (i=0; i<sexp_num_types; i++)
for (i=0; i<num_types; i++)
memcpy(&(new[i]), &(sexp_type_specs[i]), sizeof(_sexp_type_specs[0]));
tmp = sexp_type_specs;
sexp_type_specs = new;
if (sexp_type_array_size > sexp_num_types) free(tmp);
if (type_array_size > num_types) free(tmp);
sexp_type_array_size = len;
#else
res = sexp_make_vector(ctx, sexp_make_fixnum(len), SEXP_VOID);
v1 = sexp_vector_data(res);
v2 = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES));
for (i=0; i<num_types; i++)
v1[i] = v2[i];
sexp_global(ctx, SEXP_G_TYPES) = res;
#endif
}
type = &(sexp_type_specs[sexp_num_types]);
#if ! SEXP_USE_GLOBAL_TYPES
sexp_type_by_index(ctx, num_types) = sexp_alloc_type(ctx, type, SEXP_TYPE);
#endif
type = sexp_type_by_index(ctx, num_types);
sexp_pointer_tag(type) = SEXP_TYPE;
sexp_type_tag(type) = sexp_num_types++;
sexp_type_tag(type) = num_types;
sexp_type_field_base(type) = sexp_unbox_fixnum(fb);
sexp_type_field_eq_len_base(type) = sexp_unbox_fixnum(felb);
sexp_type_field_len_base(type) = sexp_unbox_fixnum(flb);
@ -145,7 +167,12 @@ sexp sexp_register_type (sexp ctx, sexp name, sexp fb, sexp felb, sexp flb,
sexp_type_size_scale(type) = sexp_unbox_fixnum(sc);
sexp_type_name(type) = strdup(sexp_string_data(name));
sexp_type_finalize(type) = f;
res = sexp_make_fixnum(sexp_type_tag(type));
res = sexp_make_fixnum(num_types);
#if SEXP_USE_GLOBAL_TYPES
sexp_num_types = num_types + 1;
#else
sexp_global(ctx, SEXP_G_NUM_TYPES) = sexp_make_fixnum(num_types + 1);
#endif
}
return res;
}
@ -179,6 +206,10 @@ sexp sexp_finalize_c_type (sexp ctx, sexp obj) {
/****************************** contexts ******************************/
void sexp_init_context_globals (sexp ctx) {
#if ! SEXP_USE_GLOBAL_TYPES
sexp type, *vec;
int i;
#endif
sexp_context_globals(ctx)
= sexp_make_vector(ctx, sexp_make_fixnum(SEXP_G_NUM_GLOBALS), SEXP_VOID);
#if ! SEXP_USE_GLOBAL_SYMBOLS
@ -197,6 +228,17 @@ void sexp_init_context_globals (sexp ctx) {
sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL) = sexp_intern(ctx, "*interaction-environment*");
sexp_global(ctx, SEXP_G_EMPTY_VECTOR) = sexp_alloc_type(ctx, vector, SEXP_VECTOR);
sexp_vector_length(sexp_global(ctx, SEXP_G_EMPTY_VECTOR)) = 0;
#if ! SEXP_USE_GLOBAL_TYPES
sexp_global(ctx, SEXP_G_NUM_TYPES) = sexp_make_fixnum(SEXP_NUM_CORE_TYPES);
sexp_global(ctx, SEXP_G_TYPES)
= sexp_make_vector(ctx, sexp_make_fixnum(SEXP_INIT_NUM_TYPES), SEXP_VOID);
vec = sexp_vector_data(sexp_global(ctx, SEXP_G_TYPES));
for (i=0; i<SEXP_NUM_CORE_TYPES; i++) {
type = sexp_alloc_type(ctx, type, SEXP_TYPE);
memcpy(type, &(_sexp_type_specs[i]), sexp_sizeof(type));
vec[i] = type;
}
#endif
}
#if ! SEXP_USE_GLOBAL_HEAP
@ -485,34 +527,9 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
loop:
if (a == b)
return SEXP_TRUE;
#if SEXP_USE_IMMEDIATE_FLONUMS
if ((! sexp_pointerp(a)) || (! sexp_pointerp(b)))
return
sexp_make_boolean((sexp_flonump(a) && sexp_fixnump(b)
&& sexp_flonum_value(a) == sexp_unbox_fixnum(b))
|| (sexp_flonump(b) && sexp_fixnump(a)
&& sexp_flonum_value(b) == sexp_unbox_fixnum(a)));
#else
if (! sexp_pointerp(a))
return sexp_make_boolean(sexp_fixnump(a) && sexp_flonump(b)
&& (sexp_unbox_fixnum(a) == sexp_flonum_value(b)));
else if (! sexp_pointerp(b))
return sexp_make_boolean(sexp_fixnump(b) && sexp_flonump(a)
&& (sexp_unbox_fixnum(b) == sexp_flonum_value(a)));
#endif
if (sexp_pointer_tag(a) != sexp_pointer_tag(b)) {
#if SEXP_USE_BIGNUMS && ! SEXP_USE_IMMEDIATE_FLONUMS
if (sexp_pointer_tag(a) == SEXP_FLONUM) {t=a; a=b; b=t;}
if (sexp_pointer_tag(a) == SEXP_BIGNUM)
return sexp_make_boolean((sexp_pointer_tag(b) == SEXP_FLONUM)
&& sexp_fp_integerp(b)
&& ! sexp_bignum_compare(a, sexp_double_to_bignum(ctx, sexp_flonum_value(b))));
else
#endif
else if ((! sexp_pointerp(a)) || (! sexp_pointerp(b))
|| (sexp_pointer_tag(a) != sexp_pointer_tag(b)))
return SEXP_FALSE;
}
/* a and b are both pointers of the same type */
#if SEXP_USE_BIGNUMS
@ -523,7 +540,7 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
if (sexp_pointer_tag(a) == SEXP_FLONUM)
return sexp_make_boolean(sexp_flonum_value(a) == sexp_flonum_value(b));
#endif
t = &(sexp_type_specs[sexp_pointer_tag(a)]);
t = sexp_object_type(ctx, a);
p0 = ((char*)a) + offsetof(struct sexp_struct, value);
p = (sexp*) (((char*)a) + sexp_type_field_base(t));
q0 = ((char*)b) + offsetof(struct sexp_struct, value);
@ -1075,8 +1092,8 @@ sexp sexp_write (sexp ctx, sexp obj, sexp out) {
i = sexp_pointer_tag(obj);
sexp_write_string(ctx, "#<", out);
sexp_write_string(ctx,
(i < sexp_num_types)
? sexp_type_name_by_index(i) : "invalid",
(i < sexp_context_num_types(ctx))
? sexp_type_name_by_index(ctx, i) : "invalid",
out);
sexp_write_char(ctx, '>', out);
break;

20
tests/r5rs-tests.scm
View file

@ -168,6 +168,10 @@
(test #t (equal? 2 2))
(test #f (eqv? 2 2.0))
(test #f (equal? 2.0 2))
(test #t (equal? (make-vector 5 'a) (make-vector 5 'a)))
(test 4 (max 3 4))
@ -212,21 +216,21 @@
(test 288 (lcm 32 -36))
(test -5 (floor -4.3))
(test #t (= -5 (floor -4.3)))
(test -4 (ceiling -4.3))
(test #t (= -4 (ceiling -4.3)))
(test -4 (truncate -4.3))
(test #t (= -4 (truncate -4.3)))
(test -4 (round -4.3))
(test #t (= -4 (round -4.3)))
(test 3 (floor 3.5))
(test #t (= 3 (floor 3.5)))
(test 4 (ceiling 3.5))
(test #t (= 4 (ceiling 3.5)))
(test 3 (truncate 3.5))
(test #t (= 3 (truncate 3.5)))
(test 4 (round 3.5))
(test #t (= 4 (round 3.5)))
(test 100 (string->number "100"))

10
tools/genstubs.scm
View file

@ -238,6 +238,10 @@
;; function objects
(define (parse-func func)
(if (not (and (= 3 (length func))
(or (identifier? (cadr func)) (list (cadr func)))
(list (caddr func))))
(error "bad function definition" func))
(let* ((ret-type (parse-type (car func)))
(scheme-name (if (pair? (cadr func)) (caadr func) (cadr func)))
(c-name (if (pair? (cadr func))
@ -678,7 +682,7 @@
(lambda (x)
(let ((len (get-array-length func x)))
(cat " " (type-c-name (type-base x)) " ")
(if (or (type-pointer? x) (and (type-array x) (not (number? len))))
(if (and (type-array x) (not (number? len)))
(cat "*"))
(cat (if (type-auto-expand? x) "buf" "tmp") (type-index-string x))
(if (number? len)
@ -747,7 +751,8 @@
(if (not (number? (type-array a)))
(cat " tmp" (type-index a) "[i] = NULL;\n")))
((and (type-result? a) (not (basic-type? a))
(not (type-free? a)) (not (type-auto-expand? a))
(not (type-free? a)) (not (type-pointer? a))
(not (type-auto-expand? a))
(or (not (type-array a))
(not (integer? (get-array-length func a)))))
(cat " tmp" (type-index a) " = malloc(sizeof(tmp" (type-index a)
@ -768,6 +773,7 @@
(cond
((any (lambda (y)
(and (type-array y)
(type-auto-expand? y)
(eq? x (get-array-length func y))))
(func-c-args func))
=> (lambda (y) (cat "len" (type-index y))))