adding support for define-library and include-ci

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)
+  suffix = sexp_stringp(source) ? sexp_string_data(source)
-    + sexp_string_length(source) - strlen(sexp_so_extension);
+    + 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;

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)
 

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

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);

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)))
+           (cond
-                 (else (error "couldn't find include" f)))))
+            ((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
+(define-syntax define-library define-library-transformer)
-  (er-macro-transformer
+(define-syntax define-module define-library-transformer)
-   (lambda (expr rename compare)
+(define-syntax module define-library-transformer)
-     (cons (rename 'define-module) (cdr expr)))))
 
 (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)

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),

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) {