diff --git a/Makefile b/Makefile index 05579c84..f8627fe7 100644 --- a/Makefile +++ b/Makefile @@ -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 diff --git a/README b/README index bfd07571..e6c01034 100644 --- a/README +++ b/README @@ -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 + 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 ) + => ; a fixnum + +(make-type-predicate ) + => ; takes 1 arg, returns #t iff that arg is of the type + +(make-constructor ) + => ; takes 0 args, returns a newly allocated instance of type + +(make-getter ) + => ; takes 1 args, retrieves the field located at the index + +(make-setter ) + => ; takes 2 args, sets the field located at the index + diff --git a/TODO b/TODO index f1d1da2a..98e4e0d6 100644 --- a/TODO +++ b/TODO @@ -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 diff --git a/eval.c b/eval.c index fb4c6b2c..cc553b2f 100644 --- a/eval.c +++ b/eval.c @@ -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; } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index f069437a..5312893d 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -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); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 5ffacc13..d25dc6a4 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -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; diff --git a/lib/srfi/69.module b/lib/srfi/69.module new file mode 100644 index 00000000..8c64a4e9 --- /dev/null +++ b/lib/srfi/69.module @@ -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")) + diff --git a/lib/srfi/69/hash.c b/lib/srfi/69/hash.c new file mode 100644 index 00000000..c08a3708 --- /dev/null +++ b/lib/srfi/69/hash.c @@ -0,0 +1,196 @@ + +#include + +#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 0) { + depth--; + for (i=0; ialist 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)) + diff --git a/lib/srfi/69/type.scm b/lib/srfi/69/type.scm new file mode 100644 index 00000000..849d6a14 --- /dev/null +++ b/lib/srfi/69/type.scm @@ -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)) + diff --git a/lib/srfi/9.module b/lib/srfi/9.module index 87af7e73..aca550a4 100644 --- a/lib/srfi/9.module +++ b/lib/srfi/9.module @@ -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))))))))))))))))) diff --git a/opcodes.c b/opcodes.c index 191d6811..4e135bf8 100644 --- a/opcodes.c +++ b/opcodes.c @@ -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) diff --git a/sexp.c b/sexp.c index ebe94201..dd8dac2b 100644 --- a/sexp.c +++ b/sexp.c @@ -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 */