more r7rs updates

include/chibi/sexp.h

@@ -294,7 +294,7 @@ struct sexp_struct {
     struct {
       FILE *stream;
       char *buf;
-      char openp, no_closep, sourcep, blockedp, fold_casep;
+      char openp, binaryp, no_closep, sourcep, blockedp, fold_casep;
       sexp_uint_t offset, line, flags;
       size_t size;
       sexp name;
@@ -766,6 +766,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_port_name(p)       (sexp_pred_field(p, port, sexp_portp, name))
 #define sexp_port_line(p)       (sexp_pred_field(p, port, sexp_portp, line))
 #define sexp_port_openp(p)      (sexp_pred_field(p, port, sexp_portp, openp))
+#define sexp_port_binaryp(p)    (sexp_pred_field(p, port, sexp_portp, binaryp))
 #define sexp_port_no_closep(p)  (sexp_pred_field(p, port, sexp_portp, no_closep))
 #define sexp_port_sourcep(p)    (sexp_pred_field(p, port, sexp_portp, sourcep))
 #define sexp_port_blockedp(p)   (sexp_pred_field(p, port, sexp_portp, blockedp))
@@ -1156,6 +1157,8 @@ 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);
+SEXP_API sexp sexp_port_binaryp_op (sexp ctx sexp_api_params(self, n), sexp port);
+SEXP_API sexp sexp_port_openp_op (sexp ctx sexp_api_params(self, n), sexp port);
 #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

lib/init-7.scm

@@ -474,6 +474,8 @@
 
 (define (port? x) (or (input-port? x) (output-port? x)))
 
+(define textual-port? port?)
+
 (define (char-ready? . o)
   (not (eof-object? (peek-char (if (pair? o) (car o) (current-input-port))))))
 

lib/scheme/base.sld

@@ -3,6 +3,11 @@
   (import (except (scheme) equal?)
           (rename (chibi equiv) (equiv? equal?))
           (chibi io)
+          (rename (only (chibi ast)
+                        exception? exception-message exception-irritants)
+                  (exception? error-object?)
+                  (exception-message error-object-message)
+                  (exception-irritants error-object-irritants))
           (srfi 9) (srfi 11) (srfi 39))
   (export
    * + - ... / < <= = => > >= _ abs and append apply assoc assq assv begin

lib/scheme/extras.scm

@@ -1,11 +1,31 @@
 
 (define call/cc call-with-current-continuation)
 
+;; Adapted from Bawden's algorithm.
+(define (rationalize x e)
+  (define (sr x y return)
+    (let ((fx (inexact->exact (floor x))) (fy (inexact->exact (floor y))))
+      (cond
+       ((>= fx x)
+        (return fx 1))
+       ((= fx fy)
+        (sr (/ (- y fy)) (/ (- x fx)) (lambda (n d) (return (+ d (* fx n)) n))))
+       (else
+        (return (+ fx 1) 1)))))
+  (if (exact? x)
+      (let ((return (if (negative? x) (lambda (num den) (/ (- num) den)) /))
+            (x (abs x))
+            (e (abs e)))
+        (sr (- x e) (+ x e) return))
+      x))
+
 (define flush-output-port flush-output)
 
 (define (close-port port)
   ((if (input-port? port) close-input-port close-output-port) port))
 
+(define (u8-ready? port) (char-ready? port))
+
 (define (call-with-port port proc)
   (let ((res (proc port)))
     (close-port port)
@@ -52,3 +72,21 @@
 
 (define (string->vector vec)
   (list->vector (string->list vec)))
+
+(define (bytevector-copy bv)
+  (let ((res (make-bytevector (bytevector-length bv))))
+    (bytevector-copy! bv res)
+    res))
+
+(define (bytevector-copy! from to)
+  (bytevector-copy-partial! from 0 (bytevector-length from) to 0))
+
+(define (bytevector-copy-partial bv start end)
+  (let ((res (make-bytevector (- end start))))
+    (bytevector-copy-partial! bv start end res 0)
+    res))
+
+(define (bytevector-copy-partial! from start end to at)
+  (do ((i start (+ i 1)))
+      ((= i end))
+    (bytevector-u8-set! to (+ i at) (bytevector-u8-ref from i))))

opcodes.c

@@ -32,9 +32,9 @@ _OP(SEXP_OPC_SETTER, SEXP_OP_SET_CDR, 2, 0, SEXP_VOID, _I(SEXP_PAIR), _I(SEXP_OB
 _OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_REF, 2, 0, _I(SEXP_OBJECT), _I(SEXP_VECTOR), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"vector-ref", 0, NULL),
 _OP(SEXP_OPC_SETTER, SEXP_OP_VECTOR_SET, 3, 0, SEXP_VOID, _I(SEXP_VECTOR), _I(SEXP_FIXNUM), _I(SEXP_OBJECT), 0,"vector-set!", 0, NULL),
 _OP(SEXP_OPC_GETTER, SEXP_OP_VECTOR_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_VECTOR), SEXP_FALSE, SEXP_FALSE, 0,"vector-length", 0, NULL),
-_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"byte-vector-ref", 0, NULL),
+_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_REF, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"bytevector-u8-ref", 0, NULL),
-_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET, 3, 0, SEXP_VOID, _I(SEXP_BYTES), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0,"byte-vector-set!", 0, NULL),
+_OP(SEXP_OPC_SETTER, SEXP_OP_BYTES_SET, 3, 0, SEXP_VOID, _I(SEXP_BYTES), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), 0,"bytevector-u8-set!", 0, NULL),
-_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), SEXP_FALSE, SEXP_FALSE, 0,"byte-vector-length", 0, NULL),
+_OP(SEXP_OPC_GETTER, SEXP_OP_BYTES_LENGTH, 1, 0, _I(SEXP_FIXNUM), _I(SEXP_BYTES), SEXP_FALSE, SEXP_FALSE, 0,"bytevector-length", 0, NULL),
 #if SEXP_USE_UTF8_STRINGS
 _OP(SEXP_OPC_GETTER, SEXP_OP_STRING_REF, 2, 0, _I(SEXP_CHAR), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-cursor-ref", 0, NULL),
 _OP(SEXP_OPC_GETTER, SEXP_OP_STRING_CURSOR_NEXT, 2, 0, _I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_FIXNUM), SEXP_FALSE, 0,"string-cursor-next", 0, NULL),
@@ -88,6 +88,7 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_FIXNUMP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_O
 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "pair?", _I(SEXP_PAIR), 0),
 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "string?", _I(SEXP_STRING), 0),
 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "vector?", _I(SEXP_VECTOR), 0),
+_OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "bytevector?", _I(SEXP_BYTES), 0),
 #if SEXP_USE_IMMEDIATE_FLONUMS
 _FN1(_I(SEXP_BOOLEAN), _I(SEXP_OBJECT), "flonum?", 0, sexp_flonump_op),
 #else
@@ -108,6 +109,8 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJ
 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "opcode?", _I(SEXP_OPCODE), 0),
 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "input-port?", _I(SEXP_IPORT), 0),
 _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "output-port?", _I(SEXP_OPORT), 0),
+_FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "binary-port?", 0, sexp_port_binaryp_op),
+_FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "port-open?", 0, sexp_port_openp_op),
 _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),
@@ -151,7 +154,7 @@ _FN4(SEXP_VOID, _I(SEXP_ENV), _I(SEXP_ENV), _I(SEXP_OBJECT), "%import", 0, sexp_
 _FN2(SEXP_VOID, _I(SEXP_EXCEPTION), _I(SEXP_OPORT), "print-exception", 0, sexp_print_exception_op),
 _FN1(_I(SEXP_OBJECT), _I(SEXP_EXCEPTION), "exception-type", 0, sexp_exception_type_op),
 _FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_CHAR), "make-string", sexp_make_character(' '), sexp_make_string_op),
-_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-byte-vector", SEXP_ZERO, sexp_make_bytes_op),
+_FN2OPT(_I(SEXP_STRING), _I(SEXP_FIXNUM), _I(SEXP_FIXNUM), "make-bytevector", SEXP_ZERO, sexp_make_bytes_op),
 _FN2OPT(_I(SEXP_NUMBER), _I(SEXP_STRING), _I(SEXP_FIXNUM), "string->number", SEXP_TEN, sexp_string_to_number_op),
 _FN3(_I(SEXP_FIXNUM), _I(SEXP_STRING), _I(SEXP_STRING), _I(SEXP_BOOLEAN), "string-cmp", 0, sexp_string_cmp_op),
 _FN1(_I(SEXP_SYMBOL), _I(SEXP_STRING), "string->symbol", 0, sexp_string_to_symbol_op),

sexp.c

@@ -1127,6 +1127,7 @@ sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str
   in = funopen(cookie, &sstream_read, NULL, &sstream_seek, NULL);
   res = sexp_make_input_port(ctx, in, SEXP_FALSE);
   sexp_port_cookie(res) = cookie;
+  sexp_port_binaryp(res) = 0;
   sexp_gc_release1(ctx);
   return res;
 }
@@ -1145,6 +1146,7 @@ sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) {
   out = funopen(cookie, NULL, &sstream_write, &sstream_seek, NULL);
   res = sexp_make_output_port(ctx, out, SEXP_FALSE);
   sexp_port_cookie(res) = cookie;
+  sexp_port_binaryp(res) = 0;
   sexp_gc_release1(ctx);
   return res;
 }
@@ -1173,6 +1175,7 @@ sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str
     if (sexp_string_length(str) == 0)
       sexp_port_name(res) = sexp_c_string(ctx, "/dev/null", -1);
     sexp_port_cookie(res) = str;  /* for gc preservation */
+    sexp_port_binaryp(res) = 0;
   } else {
     res = sexp_user_exception(ctx, SEXP_FALSE, "couldn't open string", str);
   }
@@ -1183,6 +1186,7 @@ sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) {
   sexp res = sexp_make_output_port(ctx, NULL, SEXP_FALSE);
   sexp_port_stream(res)
     = open_memstream(&sexp_port_buf(res), &sexp_port_size(res));
+  sexp_port_binaryp(res) = 0;
   return res;
 }
 
@@ -1268,6 +1272,7 @@ sexp sexp_make_input_string_port_op (sexp ctx sexp_api_params(self, n), sexp str
   sexp_port_buf(res) = sexp_string_data(str);
   sexp_port_offset(res) = 0;
   sexp_port_size(res) = sexp_string_length(str);
+  sexp_port_binaryp(res) = 0;
   return res;
 }
 
@@ -1282,6 +1287,7 @@ sexp sexp_make_output_string_port_op (sexp ctx sexp_api_params(self, n)) {
     sexp_port_offset(res) = 0;
     sexp_port_cookie(res) = SEXP_NULL;
   }
+  sexp_port_binaryp(res) = 0;
   return res;
 }
 
@@ -1312,6 +1318,7 @@ sexp sexp_make_input_port (sexp ctx, FILE* in, sexp name) {
   sexp_port_flags(p) = SEXP_PORT_UNKNOWN_FLAGS;
   sexp_port_buf(p) = NULL;
   sexp_port_openp(p) = 1;
+  sexp_port_binaryp(p) = 1;
   sexp_port_no_closep(p) = 0;
   sexp_port_sourcep(p) = 0;
   sexp_port_blockedp(p) = 0;
@@ -1329,6 +1336,16 @@ sexp sexp_make_output_port (sexp ctx, FILE* out, sexp name) {
   return p;
 }
 
+sexp sexp_port_binaryp_op (sexp ctx sexp_api_params(self, n), sexp port) {
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port);
+  return sexp_make_boolean(sexp_port_binaryp(port));
+}
+
+sexp sexp_port_openp_op (sexp ctx sexp_api_params(self, n), sexp port) {
+  sexp_assert_type(ctx, sexp_portp, SEXP_IPORT, port);
+  return sexp_make_boolean(sexp_port_openp(port));
+}
+
 #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);