diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index f1cb5e7f..65e72b42 100755 --- a/include/chibi/sexp.h +++ b/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 diff --git a/lib/init-7.scm b/lib/init-7.scm index 88045fa6..1279b99a 100644 --- a/lib/init-7.scm +++ b/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)))))) diff --git a/lib/scheme/base.sld b/lib/scheme/base.sld index 96fcab2e..0a27bc0e 100644 --- a/lib/scheme/base.sld +++ b/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 diff --git a/lib/scheme/extras.scm b/lib/scheme/extras.scm index d93be0dd..5525d0c6 100644 --- a/lib/scheme/extras.scm +++ b/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)))) diff --git a/opcodes.c b/opcodes.c index c2f92b29..9b50c314 100644 --- a/opcodes.c +++ b/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_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_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_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,"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,"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), diff --git a/sexp.c b/sexp.c index 6c23fbd2..146f51d2 100644 --- a/sexp.c +++ b/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);