diff --git a/eval.c b/eval.c index 3da2615c..a3fce89a 100644 --- a/eval.c +++ b/eval.c @@ -1089,19 +1089,23 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { #endif sexp tmp, out=SEXP_FALSE; sexp_gc_var4(ctx2, x, in, res); - sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source); if (!env) env = sexp_context_env(ctx); sexp_assert_type(ctx, sexp_envp, SEXP_ENV, env); #if SEXP_USE_DL || SEXP_USE_STATIC_LIBS - suffix = sexp_string_data(source) - + sexp_string_length(source) - strlen(sexp_so_extension); + suffix = sexp_stringp(source) ? sexp_string_data(source) + + sexp_string_length(source) - strlen(sexp_so_extension) : "..."; if (strcmp(suffix, sexp_so_extension) == 0) { res = sexp_load_dl(ctx, source, env); } else { #endif - sexp_gc_preserve4(ctx, ctx2, x, in, res); res = SEXP_VOID; - in = sexp_open_input_file(ctx, source); + if (sexp_iportp(source)) { + in = source; + } else { + sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, source); + in = sexp_open_input_file(ctx, source); + } + sexp_gc_preserve4(ctx, ctx2, x, in, res); out = sexp_current_error_port(ctx); ctx2 = sexp_make_eval_context(ctx, NULL, env, 0, 0); sexp_context_parent(ctx2) = ctx; diff --git a/include/chibi/eval.h b/include/chibi/eval.h index d1cd61f9..189ae2cc 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -176,6 +176,17 @@ SEXP_API sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp fl SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); +#if SEXP_USE_NATIVE_X86 +SEXP_API sexp sexp_write_char_op(sexp ctx sexp_api_params(self, n), sexp ch, sexp out); +SEXP_API sexp sexp_newline_op(sexp ctx sexp_api_params(self, n), sexp out); +SEXP_API sexp sexp_read_char_op(sexp ctx sexp_api_params(self, n), sexp in); +SEXP_API sexp sexp_peek_char_op(sexp ctx sexp_api_params(self, n), sexp in); +SEXP_API sexp sexp_exact_to_inexact(sexp ctx sexp_api_params(self, n), sexp i); +SEXP_API sexp sexp_inexact_to_exact(sexp ctx sexp_api_params(self, n), sexp x); +SEXP_API sexp sexp_char_upcase(sexp ctx sexp_api_params(self, n), sexp ch); +SEXP_API sexp sexp_char_downcase(sexp ctx sexp_api_params(self, n), sexp ch); +#endif + #define sexp_define_foreign(c,e,s,n,f) sexp_define_foreign_aux(c,e,s,n,0,(sexp_proc1)f,NULL) #define sexp_define_foreign_opt(c,e,s,n,f,d) sexp_define_foreign_aux(c,e,s,n,1,(sexp_proc1)f,d) diff --git a/include/chibi/features.h b/include/chibi/features.h index 31884e94..9afc0d66 100644 --- a/include/chibi/features.h +++ b/include/chibi/features.h @@ -537,6 +537,8 @@ #define SEXP_USE_RATIOS 0 #undef SEXP_USE_COMPLEX #define SEXP_USE_COMPLEX 0 +#undef SEXP_USE_UTF8_STRINGS +#define SEXP_USE_UTF8_STRINGS 0 #undef SEXP_USE_SIMPLIFY #define SEXP_USE_SIMPLIFY 0 #endif diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index fa1b1e0c..0974a89c 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -1142,6 +1142,9 @@ SEXP_API sexp sexp_write_simple_object (sexp ctx sexp_api_params(self, n), sexp SEXP_API sexp sexp_finalize_port (sexp ctx sexp_api_params(self, n), sexp port); SEXP_API sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name); SEXP_API sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name); +#if SEXP_USE_FOLD_CASE_SYMS +SEXP_API sexp sexp_set_port_fold_case (sexp ctx sexp_api_params(self, n), sexp in, sexp x); +#endif SEXP_API sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str); SEXP_API sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)); SEXP_API sexp sexp_get_output_string_op (sexp ctx sexp_api_params(self, n), sexp port); diff --git a/lib/config.scm b/lib/config.scm index f3b4174a..53865c48 100644 --- a/lib/config.scm +++ b/lib/config.scm @@ -95,12 +95,20 @@ (define (eval-module name mod) (let ((env (make-environment)) (dir (module-name-prefix name))) - (define (load-modules files extension) + (define (load-modules files extension fold?) (for-each (lambda (f) (let ((f (string-append dir f extension))) - (cond ((find-module-file f) => (lambda (x) (load x env))) - (else (error "couldn't find include" f))))) + (cond + ((find-module-file f) + => (lambda (path) + (cond (fold? + (let ((in (open-input-file path))) + (set-port-fold-case! in #t) + (load in env))) + (else + (load path env))))) + (else (error "couldn't find include" f))))) files)) (for-each (lambda (x) @@ -117,9 +125,11 @@ (lambda (x) (case (and (pair? x) (car x)) ((include) - (load-modules (cdr x) "")) + (load-modules (cdr x) "" #f)) + ((include-ci) + (load-modules (cdr x) "" #t)) ((include-shared) - (load-modules (cdr x) *shared-object-extension*)) + (load-modules (cdr x) *shared-object-extension* #f)) ((body begin) (for-each (lambda (expr) (eval expr env)) (cdr x))))) (module-meta-data mod)) @@ -131,7 +141,7 @@ (module-env-set! mod (eval-module name mod))) mod)) -(define-syntax define-module +(define define-library-transformer (er-macro-transformer (lambda (expr rename compare) (let ((name (cadr expr)) @@ -156,10 +166,9 @@ *modules*))) (set! *this-module* tmp)))))) -(define-syntax module - (er-macro-transformer - (lambda (expr rename compare) - (cons (rename 'define-module) (cdr expr))))) +(define-syntax define-library define-library-transformer) +(define-syntax define-module define-library-transformer) +(define-syntax module define-library-transformer) (define-syntax define-config-primitive (er-macro-transformer @@ -173,6 +182,7 @@ (define-config-primitive import-immutable) (define-config-primitive export) (define-config-primitive include) +(define-config-primitive include-ci) (define-config-primitive include-shared) (define-config-primitive body) (define-config-primitive begin) diff --git a/opcodes.c b/opcodes.c index c257ff8b..e69d8e53 100644 --- a/opcodes.c +++ b/opcodes.c @@ -12,6 +12,7 @@ #define _FN3(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL3, 3, 0, rt, a1, a2, a3, s, d, f) #define _FN3OPT(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL3, 2, 1, rt, a1, a2, a3, s, d, f) #define _FN4(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALL4, 4, 0, rt, a1, a2, a3, s, d, f) +#define _FN5(rt, a1, a2, a3, s, d, f) _FN(SEXP_OP_FCALLN, 5, 0, rt, a1, a2, a3, s, d, f) #define _PARAM(n, t) _OP(SEXP_OPC_PARAMETER, SEXP_OP_PARAMETER_REF, 0, 1, t, t, SEXP_FALSE, SEXP_FALSE, 0, n, SEXP_FALSE, 0) static struct sexp_opcode_struct opcodes[] = { @@ -46,12 +47,19 @@ _OP(SEXP_OPC_SETTER, SEXP_OP_STRING_SET, 3, 0, SEXP_VOID, _I(SEXP_STRING), _I(SE #endif #endif _OP(SEXP_OPC_GETTER, SEXP_OP_STRING_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), SEXP_FALSE, SEXP_FALSE, 0,"string-length", 0, NULL), +#if SEXP_USE_NATIVE_X86 +_FN1(_I(SEXP_FLONUM), _I(SEXP_FIXNUM), "exact->inexact", 0, sexp_exact_to_inexact), +_FN1(_I(SEXP_FIXNUM), _I(SEXP_FLONUM), "inexact->exact", 0, sexp_inexact_to_exact), +_FN1(_I(SEXP_CHAR), _I(SEXP_CHAR), "char-upcase", 0, sexp_char_upcase), +_FN1(_I(SEXP_CHAR), _I(SEXP_CHAR), "char-downcase", 0, sexp_char_downcase), +#else _OP(SEXP_OPC_GENERIC, SEXP_OP_FIX2FLO, 1, 0, _I(SEXP_FLONUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "exact->inexact", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_FLO2FIX, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_NUMBER), SEXP_FALSE, SEXP_FALSE, 0, "inexact->exact", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char->integer", 0, NULL), -_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, _I(SEXP_CHAR), _I(SEXP_FIXNUM), SEXP_FALSE, SEXP_FALSE, 0, "integer->char", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_UPCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-upcase", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR_DOWNCASE, 1, 0, _I(SEXP_CHAR), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char-downcase", 0, NULL), +#endif +_OP(SEXP_OPC_GENERIC, SEXP_OP_CHAR2INT, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_CHAR), SEXP_FALSE, SEXP_FALSE, 0, "char->integer", 0, NULL), +_OP(SEXP_OPC_GENERIC, SEXP_OP_INT2CHAR, 1, 0, _I(SEXP_CHAR), _I(SEXP_FIXNUM), SEXP_FALSE, SEXP_FALSE, 0, "integer->char", 0, NULL), _OP(SEXP_OPC_ARITHMETIC, SEXP_OP_ADD, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "+", SEXP_ZERO, NULL), _OP(SEXP_OPC_ARITHMETIC, SEXP_OP_MUL, 0, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 0, "*", SEXP_ONE, NULL), _OP(SEXP_OPC_ARITHMETIC, SEXP_OP_SUB, 1, 1, _I(SEXP_NUMBER), _I(SEXP_NUMBER), _I(SEXP_NUMBER), SEXP_FALSE, 1, "-", SEXP_ZERO, NULL), @@ -99,10 +107,18 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP, 1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJ _OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL), _OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL), +#if SEXP_USE_NATIVE_X86 +_FN2OPTP(SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), "write-char", (sexp)"current-output-port", sexp_write_char_op), +_FN1OPTP(SEXP_VOID, _I(SEXP_OPORT), "newline", (sexp)"current-output-port", sexp_newline_op), +_FN1OPTP(SEXP_VOID, _I(SEXP_IPORT), "read-char", (sexp)"current-input-port", sexp_read_char_op), +_FN1OPTP(SEXP_VOID, _I(SEXP_IPORT), "peek-char", (sexp)"current-input-port", sexp_peek_char_op), +_FN5(_I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), _I(SEXP_OBJECT), "five", 0, sexp_five), +#else _OP(SEXP_OPC_IO, SEXP_OP_WRITE_CHAR, 1, 3, SEXP_VOID, _I(SEXP_CHAR), _I(SEXP_OPORT), SEXP_FALSE, 0, "write-char", (sexp)"current-output-port", NULL), _OP(SEXP_OPC_IO, SEXP_OP_NEWLINE, 0, 3, SEXP_VOID, _I(SEXP_OPORT), SEXP_FALSE, SEXP_FALSE, 0, "newline", (sexp)"current-output-port", NULL), _OP(SEXP_OPC_IO, SEXP_OP_READ_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "read-char", (sexp)"current-input-port", NULL), _OP(SEXP_OPC_IO, SEXP_OP_PEEK_CHAR, 0, 3, _I(SEXP_CHAR), _I(SEXP_IPORT), SEXP_FALSE, SEXP_FALSE, 0, "peek-char", (sexp)"current-input-port", NULL), +#endif _FN1OPTP(_I(SEXP_OBJECT), _I(SEXP_IPORT), "read", (sexp)"current-input-port", sexp_read_op), _FN2OPTP(SEXP_VOID,_I(SEXP_OBJECT), _I(SEXP_OPORT), "write", (sexp)"current-output-port", sexp_write_op), _FN2OPTP(SEXP_VOID, _I(SEXP_OBJECT), _I(SEXP_OPORT), "display", (sexp)"current-output-port", sexp_display_op), @@ -169,6 +185,9 @@ _FN3OPT(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "sub #else _FN3OPT(_I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "substring", SEXP_FALSE, sexp_substring_op), #endif +#if SEXP_USE_FOLD_CASE_SYMS +_FN2(SEXP_VOID, _I(SEXP_IPORT), _I(SEXP_BOOLEAN), "set-port-fold-case!", 0, sexp_set_port_fold_case), +#endif #if SEXP_USE_TYPE_DEFS _FN3(_I(SEXP_TYPE), _I(SEXP_STRING), _I(SEXP_TYPE), SEXP_NULL, "register-simple-type", 0, sexp_register_simple_type_op), _FN2(_I(SEXP_OPCODE), _I(SEXP_STRING), _I(SEXP_FIXNUM), "make-type-predicate", 0, sexp_make_type_predicate_op), diff --git a/sexp.c b/sexp.c index 37cbd889..e2d04a5c 100644 --- a/sexp.c +++ b/sexp.c @@ -1318,6 +1318,15 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) { return p; } +#if SEXP_USE_FOLD_CASE_SYMS +sexp sexp_set_port_fold_case (sexp ctx sexp_api_params(self, n), sexp in, sexp x) { + sexp_assert_type(ctx, sexp_iportp, SEXP_IPORT, in); + sexp_assert_type(ctx, sexp_booleanp, SEXP_BOOLEAN, x); + sexp_port_fold_casep(in) = x; + return SEXP_VOID; +} +#endif + #define NUMBUF_LEN 32 sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {