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

adding hash-tables and a more friendly FFI

Browse source
This commit is contained in:
Alex Shinn 2009-11-16 00:52:16 +09:00
parent 311c567c06
commit 0581b41b1e
13 changed files with 485 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
Makefile
View file

@ -1,6 +1,6 @@
# -*- makefile-gmake -*-
.PHONY: all doc dist clean cleaner test install uninstall
.PHONY: all libs doc dist clean cleaner test install uninstall
CC ?= cc
PREFIX ?= /usr/local
@ -48,7 +48,9 @@ STATICFLAGS = -static
endif
endif
all: chibi-scheme$(EXE)
all: chibi-scheme$(EXE) libs
libs: lib/srfi/69/hash$(SO)
ifeq ($(USE_BOEHM),1)
GCLDFLAGS := -lgc
@ -90,6 +92,9 @@ chibi-scheme$(EXE): main.o libchibi-scheme$(SO)
chibi-scheme-static$(EXE): main.o eval.o sexp.o
$(CC) $(XCFLAGS) $(STATICFLAGS) -o $@ $^ $(XLDFLAGS)
lib/srfi/69/hash$(SO): lib/srfi/69/hash.c
$(CC) $(CLIBFLAGS) $(XCPPFLAGS) $(XCFLAGS) -o $@ $< -L. -lchibi-scheme
clean:
rm -f *.o *.i *.s *.8

48
README
View file

@ -41,6 +41,8 @@ directly from make with:
See the file main.c for an example of using chibi-scheme as a library.
The essential functions to remember are:
#include <chibi/eval.h>
sexp_make_context(NULL, NULL, NULL)
returns a new context
@ -50,3 +52,49 @@ The essential functions to remember are:
sexp_eval_string(context, str)
reads an s-expression from str and evaluates it
sexp_env_define(context, env, symbol, value)
A minimal module system is provided by default. Currently you can
load the following SRFIs with (import (srfi N)):
1, 2, 6, 8, 9, 11, 16, 26, 69
LOAD is extended to accept an optional environment argument, like
EVAL. You can also LOAD shared libraries in addition to Scheme source
files - in this case the function sexp_init_library is automatically
called with the following signature:
sexp_init_library(sexp context, sexp environment)
To define new primitive functions from C, use sexp_define_foreign,
which takes a Scheme environment, a name, a number of arguments the C
function takes (not counting the context argument), and a C function.
/* sexp_define_foreign(context, env, name, num_args, f) */
sexp add1 (sexp context, sexp x) {
return sexp_fx_add(x, sexp_make_fixnum(1));
}
sexp_define_foreign(context, env, "add1", 1, add1)
See the SRFI-69 implementation for more detailed examples of this.
You can define new data types with SRFI-9. This is just syntactic
sugar for the following more primitive type constructors:
(register-simple-type <name-string> <num-fields>)
=> <type-id> ; a fixnum
(make-type-predicate <opcode-name-string> <type-id>)
=> <opcode> ; takes 1 arg, returns #t iff that arg is of the type
(make-constructor <constructor-name-string> <type-id>)
=> <opcode> ; takes 0 args, returns a newly allocated instance of type
(make-getter <getter-name-string> <type-id> <field-index>)
=> <opcode> ; takes 1 args, retrieves the field located at the index
(make-setter <setter-name-string> <type-id> <field-index>)
=> <opcode> ; takes 2 args, sets the field located at the index

3
TODO
View file

@ -46,4 +46,7 @@
*- type inference with warnings
*- SRFI-0 cond-expand
*+ SRFI-9 define-record-type
*+ SRFI-69 hash-tables
*- tcp interface
*- posix interface
*- code repository with install tools

66
eval.c
View file

@ -2035,7 +2035,7 @@ sexp sexp_load_dl (sexp ctx, sexp file, sexp env) {
#endif
sexp sexp_load (sexp ctx, sexp source, sexp env) {
sexp tmp, out;
sexp tmp, out=SEXP_FALSE;
sexp_gc_var4(ctx2, x, in, res);
#if USE_DL
char *suffix = sexp_string_data(source)
@ -2053,9 +2053,10 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) {
tmp = sexp_env_bindings(env);
sexp_context_tailp(ctx2) = 0;
if (sexp_exceptionp(in)) {
if (! sexp_oportp(out))
if (sexp_not(out))
out = sexp_env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE);
sexp_print_exception(ctx, in, out);
if (sexp_oportp(out))
sexp_print_exception(ctx, in, out);
res = in;
} else {
sexp_port_sourcep(in) = 1;
@ -2219,7 +2220,7 @@ static sexp sexp_copy_opcode (sexp ctx, sexp op) {
sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code,
sexp num_args, sexp flags, sexp arg1t, sexp arg2t,
sexp invp, sexp data, sexp data2, sexp_proc0 func) {
sexp invp, sexp data, sexp data2, sexp_proc1 func) {
sexp res;
if (! sexp_stringp(name))
res = sexp_type_exception(ctx, "make-opcode: not a string", name);
@ -2250,6 +2251,36 @@ sexp sexp_make_opcode (sexp ctx, sexp name, sexp op_class, sexp code,
return res;
}
sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f) {
sexp res;
if (num_args > 6) {
res = sexp_type_exception(ctx, "make-foreign: exceeded foreign arg limit",
sexp_make_fixnum(num_args));
} else {
res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
sexp_opcode_class(res) = OPC_FOREIGN;
sexp_opcode_code(res) = OP_FCALL1+num_args-1;
sexp_opcode_num_args(res) = num_args;
sexp_opcode_name(res) = name;
sexp_opcode_func(res) = f;
}
return res;
}
sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name,
int num_args, sexp_proc1 f) {
sexp_gc_var1(op);
sexp_gc_preserve1(ctx, op);
sexp res = SEXP_VOID;
op = sexp_make_foreign(ctx, name, num_args, (sexp_proc1)f);
if (sexp_exceptionp(op))
res = op;
else
sexp_env_define(ctx, env, sexp_intern(ctx, name), op);
sexp_gc_release1(ctx);
return res;
}
#if USE_TYPE_DEFS
sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type) {
@ -2389,16 +2420,23 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx));
sexp_sint_t top = sexp_context_top(ctx), len, offset;
len = sexp_unbox_fixnum(sexp_length(ctx, args));
offset = top + len;
for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++)
stack[--offset] = sexp_car(ls);
stack[top] = sexp_make_fixnum(len);
top++;
stack[top++] = sexp_make_fixnum(0);
stack[top++] = final_resumer;
stack[top++] = sexp_make_fixnum(0);
sexp_context_top(ctx) = top;
res = sexp_vm(ctx, proc);
if (sexp_opcodep(proc))
proc = make_opcode_procedure(ctx, proc, len);
if (! sexp_procedurep(proc)) {
res = sexp_exceptionp(proc) ? proc :
sexp_type_exception(ctx, "apply: not a procedure", proc);
} else {
offset = top + len;
for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++)
stack[--offset] = sexp_car(ls);
stack[top] = sexp_make_fixnum(len);
top++;
stack[top++] = sexp_make_fixnum(0);
stack[top++] = final_resumer;
stack[top++] = sexp_make_fixnum(0);
sexp_context_top(ctx) = top;
res = sexp_vm(ctx, proc);
}
return res;
}

25
include/chibi/eval.h
View file

@ -124,17 +124,20 @@ enum opcode_names {
/**************************** prototypes ******************************/
SEXP_API void sexp_scheme_init(void);
SEXP_API sexp sexp_apply(sexp context, sexp proc, sexp args);
SEXP_API sexp sexp_eval(sexp context, sexp obj, sexp env);
SEXP_API sexp sexp_eval_string(sexp context, char *str, sexp env);
SEXP_API sexp sexp_load(sexp context, sexp expr, sexp env);
SEXP_API sexp sexp_make_env(sexp context);
SEXP_API sexp sexp_env_copy(sexp context, sexp to, sexp from, sexp ls);
SEXP_API void sexp_env_define(sexp context, sexp env, sexp sym, sexp val);
SEXP_API sexp sexp_make_context(sexp context, sexp stack, sexp env);
SEXP_API void sexp_warn_undefs(sexp ctx, sexp from, sexp to, sexp out);
SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc0);
SEXP_API void sexp_scheme_init (void);
SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args);
SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env);
SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env);
SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env);
SEXP_API sexp sexp_make_env (sexp context);
SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls);
SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val);
SEXP_API sexp sexp_make_context (sexp context, sexp stack, sexp env);
SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out);
SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1);
SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, sexp_proc1 f);
SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, char *name, int num_args, sexp_proc1 f);
#define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,(sexp_proc1)f)
#if USE_TYPE_DEFS
SEXP_API sexp sexp_make_type_predicate (sexp ctx, sexp name, sexp type);

2
include/chibi/sexp.h
View file

@ -208,7 +208,7 @@ struct sexp_struct {
arg1_type, arg2_type, inverse;
char *name;
sexp data, data2, proc;
sexp_proc0 func;
sexp_proc1 func;
} opcode;
struct {
char code;

18
lib/srfi/69.module Normal file
View file

@ -0,0 +1,18 @@
(define-module (srfi 69)
(export
make-hash-table hash-table? alist->hash-table
hash-table-equivalence-function hash-table-hash-function
hash-table-ref hash-table-ref/default hash-table-set!
hash-table-delete! hash-table-exists?
hash-table-update! hash-table-update!/default
hash-table-size hash-table-keys hash-table-values
hash-table-walk hash-table-fold hash-table->alist
hash-table-copy hash-table-merge!
hash string-hash string-ci-hash hash-by-identity)
(import (scheme))
(import (srfi 9))
(include "srfi/69/type.scm"
"srfi/69/hash.so"
"srfi/69/interface.scm"))

196
lib/srfi/69/hash.c Normal file
View file

@ -0,0 +1,196 @@
#include <chibi/eval.h>
#define HASH_DEPTH 5
#define FNV_PRIME 16777619
#define FNV_OFFSET_BASIS 2166136261uL
#define sexp_hash_table_buckets(x) sexp_slot_ref(x, 0)
#define sexp_hash_table_size(x) sexp_slot_ref(x, 1)
#define sexp_hash_table_hash_fn(x) sexp_slot_ref(x, 2)
#define sexp_hash_table_eq_fn(x) sexp_slot_ref(x, 3)
static sexp_uint_t string_hash (char *str, sexp_uint_t bound) {
sexp_uint_t acc = FNV_OFFSET_BASIS;
while (*str) {acc *= FNV_PRIME; acc ^= *str++;}
return acc % bound;
}
static sexp sexp_string_hash (sexp ctx, sexp str, sexp bound) {
return sexp_make_fixnum(string_hash(sexp_string_data(str),
sexp_unbox_fixnum(bound)));
}
static sexp_uint_t string_ci_hash (char *str, sexp_uint_t bound) {
sexp_uint_t acc = FNV_OFFSET_BASIS;
while (*str) {acc *= FNV_PRIME; acc ^= tolower(*str++);}
return acc % bound;
}
static sexp sexp_string_ci_hash (sexp ctx, sexp str, sexp bound) {
return sexp_make_fixnum(string_ci_hash(sexp_string_data(str),
sexp_unbox_fixnum(bound)));
}
static sexp_uint_t hash_one (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;
char *p0;
loop:
#if USE_FLONUMS
if (sexp_flonump(obj))
acc ^= (sexp_sint_t) sexp_flonum_value(obj);
else
#endif
if (sexp_pointerp(obj)) {
if (depth) {
t = &(sexp_type_specs[sexp_pointer_tag(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;
/* hash trailing non-object data */
size = sexp_type_size_of_object(t, obj)-offsetof(struct sexp_struct, value);
p0 = ((char*)p + sexp_type_num_slots_of_object(t,obj)*sizeof(sexp));
if (((char*)obj + size) > p0)
for (i=0; i<size; i++) {acc *= FNV_PRIME; acc ^= p0[i];}
/* hash eq-object slots */
len = sexp_type_num_eq_slots_of_object(t, obj);
if (len > 0) {
depth--;
for (i=0; i<len-1; i++) {
acc *= FNV_PRIME;
acc ^= hash_one(p[i], 0, depth);
}
/* tail-recurse on the last value */
obj = p[len-1]; goto loop;
}
} else {
acc ^= sexp_pointer_tag(obj);
}
} else {
acc ^= (sexp_uint_t)obj;
}
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) {
return sexp_make_fixnum(hash(obj, sexp_unbox_fixnum(bound)));
}
static sexp sexp_hash_by_identity (sexp ctx, sexp obj, sexp bound) {
return sexp_make_fixnum((sexp_uint_t)obj % sexp_unbox_fixnum(bound));
}
static sexp sexp_get_bucket (sexp ctx, sexp ht, sexp obj) {
sexp_gc_var1(args);
sexp buckets = sexp_hash_table_buckets(ht), hash_fn, res;
sexp_uint_t len = sexp_vector_length(buckets);
hash_fn = sexp_hash_table_hash_fn(ht);
if (hash_fn == sexp_make_fixnum(1))
res = sexp_hash_by_identity(ctx, obj, sexp_make_fixnum(len));
else if (hash_fn == sexp_make_fixnum(2))
res = sexp_hash(ctx, obj, sexp_make_fixnum(len));
else {
sexp_gc_preserve1(ctx, args);
args = sexp_list2(ctx, obj, sexp_make_fixnum(len));
res = sexp_apply(ctx, hash_fn, args);
if (sexp_exceptionp(res)) {
args = sexp_eval_string(ctx, "(current-error-port)", sexp_context_env(ctx));
sexp_print_exception(ctx, res, args);
res = sexp_make_fixnum(0);
}
sexp_gc_release1(ctx);
}
return res;
}
static sexp sexp_scan_bucket (sexp ctx, sexp ls, sexp obj, sexp eq_fn) {
sexp_gc_var1(res);
sexp p;
res = SEXP_FALSE;
if ((eq_fn == sexp_make_fixnum(1))
|| ((eq_fn == sexp_make_fixnum(2))
&& (sexp_pointerp(obj) ?
(sexp_pointer_tag(obj) == SEXP_SYMBOL) : ! sexp_fixnump(obj)))) {
for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
if (sexp_caar(p) == obj) {
res = p;
break;
}
}
} else if (eq_fn == sexp_make_fixnum(2)) {
for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
if (sexp_truep(sexp_equalp(ctx, sexp_caar(p), obj))) {
res = p;
break;
}
}
} else {
sexp_gc_preserve1(ctx, res);
for (p=ls; sexp_pairp(p); p=sexp_cdr(p)) {
res = sexp_list2(ctx, sexp_caar(p), obj);
if (sexp_truep(sexp_apply(ctx, eq_fn, res))) {
res = p;
break;
} else {
res = SEXP_FALSE;
}
}
sexp_gc_release1(ctx);
}
return res;
}
static sexp sexp_hash_table_cell (sexp ctx, sexp ht, sexp obj, sexp createp) {
sexp_gc_var1(res);
sexp_uint_t size;
sexp buckets=sexp_hash_table_buckets(ht), eq_fn=sexp_hash_table_eq_fn(ht),
i=sexp_get_bucket(ctx, ht, obj);
res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn);
if (sexp_truep(res)) {
res = sexp_car(res);
} else if (sexp_truep(createp)) {
sexp_gc_preserve1(ctx, res);
size = sexp_unbox_fixnum(sexp_hash_table_size(ht));
res = sexp_cons(ctx, obj, createp);
sexp_vector_set(buckets, i, sexp_cons(ctx, res, sexp_vector_ref(buckets, i)));
sexp_hash_table_size(ht) = sexp_make_fixnum(size+1);
sexp_gc_release1(ctx);
}
return res;
}
static sexp sexp_hash_table_delete (sexp ctx, sexp ht, sexp obj) {
sexp buckets=sexp_hash_table_buckets(ht), eq_fn=sexp_hash_table_eq_fn(ht),
i=sexp_get_bucket(ctx, ht, obj), p, res;
res = sexp_scan_bucket(ctx, sexp_vector_ref(buckets, i), obj, eq_fn);
if (sexp_pairp(res)) {
if (res == sexp_vector_ref(buckets, i)) {
sexp_vector_set(buckets, i, sexp_cdr(res));
} else {
for (p=sexp_vector_ref(buckets, i); sexp_cdr(p)!=res; p=sexp_cdr(p))
;
sexp_cdr(p) = sexp_cdr(res);
}
}
return SEXP_VOID;
}
sexp sexp_init_library (sexp ctx, sexp env) {
sexp_define_foreign(ctx, env, "string-hash", 2, sexp_string_hash);
sexp_define_foreign(ctx, env, "string-ci-hash", 2, sexp_string_ci_hash);
sexp_define_foreign(ctx, env, "hash", 2, sexp_hash);
sexp_define_foreign(ctx, env, "hash-by-identity", 2, sexp_hash_by_identity);
sexp_define_foreign(ctx, env, "hash-table-cell", 3, sexp_hash_table_cell);
sexp_define_foreign(ctx, env, "hash-table-delete!", 2, sexp_hash_table_delete);
return SEXP_VOID;
}

110
lib/srfi/69/interface.scm Normal file
View file

@ -0,0 +1,110 @@
(define (make-hash-table . o)
(let ((eq-fn (if (pair? o) (car o) equal?))
(hash-fn (if (and (pair? o) (pair? (cdr o))) (car (cdr o)) hash)))
(cond
((not (procedure? eq-fn))
(error "make-hash-table: bad equivalence function" eq-fn))
((not (procedure? hash-fn))
(error "make-hash-table: bad hash function" hash-fn))
(else
(%make-hash-table
(make-vector 23 '())
0
(if (eq? hash-fn hash-by-identity) 1 (if (eq? hash-fn hash) 2 hash-fn))
(if (eq? eq-fn eq?) 1 (if (eq? eq-fn equal?) 2 eq-fn)))))))
(define (hash-table-hash-function table)
(let ((f (%hash-table-hash-function table)))
(case f ((1) hash-by-identity) ((2) hash) (else f))))
(define (hash-table-equivalence-function table)
(let ((f (%hash-table-equivalence-function table)))
(case f ((1) eq?) ((2) equal?) (else f))))
(define-syntax assert-hash-table
(syntax-rules ()
((assert-hash-table from obj)
(if (not (hash-table? obj))
(error (string-append from ": not a hash-table") obj)))))
(define (hash-table-ref table key . o)
(assert-hash-table "hash-table-ref" table)
(let ((cell (hash-table-cell table key #f)))
(cond (cell (cdr cell))
((pair? o) ((car o)))
(else (error "hash-table-ref: key not found" key)))))
(define (hash-table-ref/default table key default)
(assert-hash-table "hash-table-ref/default" table)
(let ((cell (hash-table-cell table key #f)))
(if cell (cdr cell) default)))
(define (hash-table-set! table key value)
(assert-hash-table "hash-table-set!" table)
(let ((cell (hash-table-cell table key #t)))
(set-cdr! cell value)))
(define (hash-table-exists? table key)
(assert-hash-table "hash-table-exists?" table)
(and (hash-table-cell table key #f) #t))
(define hash-table-update!
(let ((not-found (cons 'not-found '())))
(lambda (table key func . o)
(assert-hash-table "hash-table-update!" table)
(let ((cell (hash-table-cell table key not-found)))
(set-cdr! cell (if (eq? not-found (cdr cell))
(if (pair? o)
(func ((car o)))
(error "hash-table-update!: key not found" key))
(func (cdr cell))))))))
(define hash-table-update!/default
(let ((not-found (cons 'not-found '())))
(lambda (table key func default)
(assert-hash-table "hash-table-update!/default" table)
(let ((cell (hash-table-cell table key not-found)))
(set-cdr! cell (func (if (eq? not-found (cdr cell)) default (cdr cell))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (hash-table-fold table kons knil)
(assert-hash-table "hash-table-fold" table)
(let ((vec (hash-table-buckets table)))
(let lp1 ((i (- (vector-length vec) 1)) (acc knil))
(if (< i 0)
acc
(let lp2 ((ls (vector-ref vec i)) (acc acc))
(if (null? ls)
(lp1 (- i 1) acc)
(lp2 (cdr ls) (kons (car (car ls)) (cdr (car ls)) acc))))))))
(define (hash-table-walk table proc)
(hash-table-fold table (lambda (k v a) (proc k v)) #f)
(if #f #f))
(define (hash-table->alist table)
(hash-table-fold table (lambda (k v a) (cons (cons k v) a)) '()))
(define (hash-table-keys table)
(hash-table-fold table (lambda (k v a) (cons k a)) '()))
(define (hash-table-values table)
(hash-table-fold table (lambda (k v a) (cons v a)) '()))
(define (alist->hash-table ls . o)
(let ((res (apply make-hash-table o)))
(for-each (lambda (x) (hash-table-set! res (car x) (cdr x))) ls)
res))
(define (hash-table-merge! a b)
(hash-table-walk b (lambda (k v) (hash-table-set! a k v)))
a)
(define (hash-table-copy table)
(assert-hash-table "hash-table-copy" table)
(let ((res (make-hash-table (hash-table-equivalence-function table))))
(hash-table-merge! res table)
res))

9
lib/srfi/69/type.scm Normal file
View file

@ -0,0 +1,9 @@
(define-record-type hash-table
(%make-hash-table buckets size hash-fn eq-fn)
hash-table?
(buckets hash-table-buckets hash-table-buckets-set!)
(size hash-table-size hash-table-size-set!)
(hash-fn %hash-table-hash-function)
(eq-fn %hash-table-equivalence-function))

50
lib/srfi/9.module
View file

@ -20,6 +20,30 @@
(let lp ((ls ls) (i 0))
(if (eq? field (caar ls)) i (lp (cdr ls) (+ i 1)))))
`(,(rename 'begin)
(,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string pred)
,index))
,@(let lp ((ls fields) (i 0) (res '()))
(if (null? ls)
res
(let ((res
(cons `(,_define ,(cadar ls)
(,(rename 'make-getter)
,(symbol->string (cadar ls))
,index
,i))
res)))
(lp (cdr ls)
(+ i 1)
(if (pair? (cddar ls))
(cons
`(,_define ,(caddar ls)
(,(rename 'make-setter)
,(symbol->string (caddar ls))
,index
,i))
res)
res)))))
(,_define ,make
,(let lp ((ls make-fields) (sets '()) (set-defs '()))
(cond
@ -54,29 +78,5 @@
setter-name
index
(index-of (car ls) fields)))
set-defs))))))))))
(,_define ,pred (,(rename 'make-type-predicate)
,(symbol->string pred)
,index))
,@(let lp ((ls fields) (i 0) (res '()))
(if (null? ls)
res
(let ((res
(cons `(,_define ,(cadar ls)
(,(rename 'make-getter)
,(symbol->string (cadar ls))
,index
,i))
res)))
(lp (cdr ls)
(+ i 1)
(if (pair? (cddar ls))
(cons
`(,_define ,(caddar ls)
(,(rename 'make-setter)
,(symbol->string (caddar ls))
,index
,i))
res)
res))))))))))))
set-defs)))))))))))))))))

2
opcodes.c
View file

@ -2,7 +2,7 @@
#define _OP(c,o,n,m,t,u,i,s,d,f) \
{.tag=SEXP_OPCODE, \
.value={.opcode={c, o, n, m, t, u, i, s, d, NULL, NULL, f}}}
#define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc0)p)
#define _FN(o,n,m,t,u,s,f,p) _OP(OPC_FOREIGN, o, n, m, t, u, 0, s, f, (sexp_proc1)p)
#define _FN0(s, f, d) _FN(OP_FCALL0, 0, 0, 0, 0, s, f, d)
#define _FN1(t, s, f, d) _FN(OP_FCALL1, 1, 0, t, 0, s, f, d)
#define _FN2(t, u, s, f, d) _FN(OP_FCALL2, 2, 0, t, u, s, f, d)

2
sexp.c
View file

@ -446,7 +446,7 @@ sexp sexp_equalp (sexp ctx, sexp a, sexp b) {
q0 = ((char*)q + sexp_type_num_slots_of_object(t,b)*sizeof(sexp));
if (size != sexp_type_size_of_object(t,b)-offsetof(struct sexp_struct,value))
return SEXP_FALSE;
if (memcmp(p0, q0, size-((char*)p0-(char*)p)))
if (memcmp(p0, q0, size))
return SEXP_FALSE;
}
/* check eq-object slots */