diff options
| -rw-r--r-- | Makefile | 1 | ||||
| -rw-r--r-- | lib.c | 2 | ||||
| -rw-r--r-- | lisplib.c | 18 | ||||
| -rw-r--r-- | share/txr/stdlib/stream-wrap.tl | 68 | ||||
| -rw-r--r-- | stream.c | 52 | ||||
| -rw-r--r-- | stream.h | 5 | ||||
| -rw-r--r-- | strudel.c | 271 | ||||
| -rw-r--r-- | strudel.h | 30 |
8 files changed, 434 insertions, 13 deletions
@@ -50,6 +50,7 @@ EXTRA_OBJS-y := OBJS := txr.o lex.yy.o y.tab.o match.o lib.o regex.o gc.o unwind.o stream.o OBJS += arith.o hash.o utf8.o filter.o eval.o parser.o rand.o combi.o sysif.o OBJS += args.o lisplib.o cadr.o struct.o itypes.o buf.o jmp.o protsym.o ffi.o +OBJS += strudel.o OBJS-$(debug_support) += debug.o OBJS-$(have_syslog) += syslog.o OBJS-$(have_glob) += glob.o @@ -55,6 +55,7 @@ #include "unwind.h" #include "args.h" #include "stream.h" +#include "strudel.h" #include "utf8.h" #include "filter.h" #include "eval.h" @@ -11704,6 +11705,7 @@ void init(val *stack_bottom) arith_init(); rand_init(); stream_init(); + strudel_init(); #if HAVE_POSIX_SIGS sig_init(); #endif @@ -562,6 +562,23 @@ static val doloop_instantiate(val set_fun) return nil; } +static val stream_wrap_set_entries(val dlt, val fun) +{ + val name[] = { + lit("stream-wrap"), + nil + }; + set_dlt_entries(dlt, name, fun); + return nil; +} + +static val stream_wrap_instantiate(val set_fun) +{ + funcall1(set_fun, nil); + load(format(nil, lit("~astream-wrap.tl"), stdlib_path, nao)); + return nil; +} + static val op_set_entries(val dlt, val fun) { val name[] = { @@ -620,6 +637,7 @@ void lisplib_init(void) dlt_register(dl_table, keyparams_instantiate, keyparams_set_entries); dlt_register(dl_table, ffi_instantiate, ffi_set_entries); dlt_register(dl_table, doloop_instantiate, doloop_set_entries); + dlt_register(dl_table, stream_wrap_instantiate, stream_wrap_set_entries); if (!opt_compat || opt_compat >= 185) dlt_register(dl_table, op_instantiate, op_set_entries); diff --git a/share/txr/stdlib/stream-wrap.tl b/share/txr/stdlib/stream-wrap.tl new file mode 100644 index 00000000..2bda62ae --- /dev/null +++ b/share/txr/stdlib/stream-wrap.tl @@ -0,0 +1,68 @@ +;; Copyright 2017 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are met: +;; +;; 1. Redistributions of source code must retain the above copyright notice, this +;; list of conditions and the following disclaimer. +;; +;; 2. Redistributions in binary form must reproduce the above copyright notice, +;; this list of conditions and the following disclaimer in the documentation +;; and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +(defstruct stream-wrap nil + stream + (:method put-string (me str) + (put-string str me.stream)) + (:method put-char (me chr) + (put-char chr me.stream)) + (:method put-byte (me byte) + (put-byte byte me.stream)) + (:method get-line (me) + (get-line me.stream)) + (:method get-char (me) + (get-char me.stream)) + (:method get-byte (me) + (get-byte me.stream)) + (:method unget-char (me chr) + (unget-char chr me.stream)) + (:method unget-byte (me byte) + (unget-byte byte me.stream)) + (:method put-buf (me buf pos) + (put-buf buf pos me.stream)) + (:method fill-buf (me buf pos) + (fill-buf buf pos me.stream)) + (:method close (me) + (close-stream me.stream)) + (:method flush (me) + (flush-stream me.stream)) + (:method seek (me offs whence) + (seek-stream me.stream offs whence)) + (:method truncate (me len) + (truncate-stream me.stream len)) + (:method get-prop (me sym) + (stream-get-prop me.stream sym)) + (:method set-prop (me sym nval) + (stream-set-prop me.stream sym nval)) + (:method get-error (me) + (get-error me.stream)) + (:method get-error-str (me) + (get-error-str me.stream)) + (:method clear-error (me) + (clear-error me.stream)) + (:method get-fd (me) + (fileno me.stream))) @@ -70,6 +70,7 @@ #include "txr.h" #include "arith.h" #include "buf.h" +#include "struct.h" /* Adhere to ISO C rules about direction switching on update streams. */ #ifndef __gnu_linux__ @@ -78,6 +79,11 @@ val stdin_s, stdout_s, stddebug_s, stderr_s, stdnull_s; +val put_string_s, put_char_s, put_byte_s, get_line_s, get_char_s; +val get_byte_s, unget_char_s, unget_byte_s, put_buf_s, fill_buf_s; +val flush_s, seek_s, truncate_s, get_prop_s, set_prop_s; +val get_error_s, get_error_str_s, clear_error_s, get_fd_s; + val print_flo_precision_s, print_flo_digits_s, print_flo_format_s; val pprint_flo_format_s, print_base_s, print_circle_s; @@ -4460,6 +4466,26 @@ void stream_init(void) socket_error_s = intern(lit("socket-error"), user_package); #endif + put_string_s = intern(lit("put-string"), user_package); + put_char_s = intern(lit("put-char"), user_package); + put_byte_s = intern(lit("put-byte"), user_package); + get_line_s = intern(lit("get-line"), user_package); + get_char_s = intern(lit("get-char"), user_package); + get_byte_s = intern(lit("get-byte"), user_package); + unget_char_s = intern(lit("unget-char"), user_package); + unget_byte_s = intern(lit("unget-byte"), user_package); + put_buf_s = intern(lit("put-buf"), user_package); + fill_buf_s = intern(lit("fill-buf"), user_package); + flush_s = intern(lit("flush"), user_package); + seek_s = intern(lit("seek"), user_package); + truncate_s = intern(lit("truncate"), user_package); + get_prop_s = intern(lit("get-prop"), user_package); + set_prop_s = intern(lit("set-prop"), user_package); + get_error_s = intern(lit("get-error"), user_package); + get_error_str_s = intern(lit("get-error-str"), user_package); + clear_error_s = intern(lit("clear-error"), user_package); + get_fd_s = intern(lit("get-fd"), user_package); + reg_var(stdin_s = intern(lit("*stdin*"), user_package), make_stdio_stream(stdin, lit("stdin"))); reg_var(stdout_s = intern(lit("*stdout*"), user_package), @@ -4502,23 +4528,23 @@ void stream_init(void) reg_fun(intern(lit("make-strlist-output-stream"), user_package), func_n0(make_strlist_output_stream)); reg_fun(intern(lit("get-list-from-stream"), user_package), func_n1(get_list_from_stream)); reg_fun(intern(lit("close-stream"), user_package), func_n2o(close_stream, 1)); - reg_fun(intern(lit("get-error"), user_package), func_n1(get_error)); - reg_fun(intern(lit("get-error-str"), user_package), func_n1(get_error_str)); - reg_fun(intern(lit("clear-error"), user_package), func_n1(clear_error)); - reg_fun(intern(lit("get-line"), user_package), func_n1o(get_line, 0)); - reg_fun(intern(lit("get-char"), user_package), func_n1o(get_char, 0)); - reg_fun(intern(lit("get-byte"), user_package), func_n1o(get_byte, 0)); + reg_fun(get_error_s, func_n1(get_error)); + reg_fun(get_error_str_s, func_n1(get_error_str)); + reg_fun(clear_error_s, func_n1(clear_error)); + reg_fun(get_line_s, func_n1o(get_line, 0)); + reg_fun(get_char_s, func_n1o(get_char, 0)); + reg_fun(get_byte_s, func_n1o(get_byte, 0)); reg_fun(intern(lit("get-string"), user_package), func_n3o(get_string, 0)); - reg_fun(intern(lit("put-string"), user_package), func_n2o(put_string, 1)); + reg_fun(put_string_s, func_n2o(put_string, 1)); reg_fun(intern(lit("put-line"), user_package), func_n2o(put_line, 0)); - reg_fun(intern(lit("put-char"), user_package), func_n2o(put_char, 1)); - reg_fun(intern(lit("put-byte"), user_package), func_n2o(put_byte, 1)); + reg_fun(put_char_s, func_n2o(put_char, 1)); + reg_fun(put_byte_s, func_n2o(put_byte, 1)); reg_fun(intern(lit("put-lines"), user_package), func_n2o(put_lines, 1)); reg_fun(intern(lit("put-strings"), user_package), func_n2o(put_strings, 1)); - reg_fun(intern(lit("unget-char"), user_package), func_n2o(unget_char, 1)); - reg_fun(intern(lit("unget-byte"), user_package), func_n2o(unget_byte, 1)); - reg_fun(intern(lit("put-buf"), user_package), func_n3o(put_buf, 1)); - reg_fun(intern(lit("fill-buf"), user_package), func_n3o(fill_buf, 1)); + reg_fun(unget_char_s, func_n2o(unget_char, 1)); + reg_fun(unget_byte_s, func_n2o(unget_byte, 1)); + reg_fun(put_buf_s, func_n3o(put_buf, 1)); + reg_fun(fill_buf_s, func_n3o(fill_buf, 1)); reg_fun(intern(lit("flush-stream"), user_package), func_n1o(flush_stream, 0)); reg_fun(intern(lit("seek-stream"), user_package), func_n3(seek_stream)); reg_fun(intern(lit("truncate-stream"), user_package), func_n2o(truncate_stream, 1)); @@ -125,6 +125,11 @@ extern val stdio_stream_s; extern val stdin_s, stdout_s, stddebug_s, stderr_s, stdnull_s; +extern val put_string_s, put_char_s, put_byte_s, get_line_s, get_char_s; +extern val get_byte_s, unget_char_s, unget_byte_s, put_buf_s, fill_buf_s; +extern val close_s, flush_s, seek_s, truncate_s, get_prop_s, set_prop_s; +extern val get_error_s, get_error_str_s, clear_error_s, get_fd_s; + extern val print_flo_precision_s, print_flo_digits_s, print_flo_format_s; extern val pprint_flo_format_s, print_base_s, print_circle_s; diff --git a/strudel.c b/strudel.c new file mode 100644 index 00000000..05971cac --- /dev/null +++ b/strudel.c @@ -0,0 +1,271 @@ +/* Copyright 2017 + * Kaz Kylheku <kaz@kylheku.com> + * Vancouver, Canada + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, this + * list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#include <stddef.h> +#include <stdio.h> +#include <stdlib.h> +#include <stdarg.h> +#include <wchar.h> +#include <signal.h> +#include <dirent.h> +#include <syslog.h> +#include "config.h" +#include ALLOCA_H +#include "lib.h" +#include "stream.h" +#include "gc.h" +#include "args.h" +#include "utf8.h" +#include "eval.h" +#include "struct.h" +#include "strudel.h" + +struct strudel_base { /* stru-ct del-egate :) */ + struct strm_base a; + val obj; +}; + +static void strudel_base_mark(struct strudel_base *sb) +{ + strm_base_mark(&sb->a); + gc_mark(sb->obj); +} + +static void strudel_mark_op(val stream) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + strudel_base_mark(sb); +} + +static val strudel_put_string(val stream, val str) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, put_string_s); + return funcall2(meth, obj, str); +} + +static val strudel_put_char(val stream, val ch) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, put_char_s); + return funcall2(meth, obj, ch); +} + +static val strudel_put_byte(val stream, int byte) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, put_byte_s); + return funcall2(meth, obj, num_fast(byte)); +} + +static val strudel_get_line(val stream) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, get_line_s); + return funcall1(meth, obj); +} + +static val strudel_get_char(val stream) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, get_char_s); + return funcall1(meth, obj); +} + +static val strudel_get_byte(val stream) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, get_byte_s); + return funcall1(meth, obj); +} + +static val strudel_unget_char(val stream, val ch) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, unget_char_s); + return funcall2(meth, obj, ch); +} + +static val strudel_unget_byte(val stream, int byte) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, unget_byte_s); + return funcall2(meth, obj, num_fast(byte)); +} + +static val strudel_put_buf(val stream, val buf, cnum pos) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, put_buf_s); + return funcall3(meth, obj, buf, num(pos)); +} + +static val strudel_fill_buf(val stream, val buf, cnum pos) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, fill_buf_s); + return funcall3(meth, obj, buf, num(pos)); +} + +static val strudel_close(val stream, val throw_on_error) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, close_s); + return funcall2(meth, obj, throw_on_error); +} + +static val strudel_flush(val stream) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, flush_s); + return funcall1(meth, obj); +} + +static val strudel_seek(val stream, val off, enum strm_whence whence) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val wh; + val obj = sb->obj; + val meth = slot(obj, seek_s); + + switch (whence) { + default: + case strm_start: + wh = from_start_k; + break; + case strm_cur: + wh = from_current_k; + break; + case strm_end: + wh = from_end_k; + break; + } + + return funcall3(meth, obj, off, wh); +} + +static val strudel_truncate(val stream, val len) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, truncate_s); + return funcall2(meth, obj, len); +} + +static val strudel_get_prop(val stream, val ind) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, get_prop_s); + return funcall2(meth, obj, ind); +} + +static val strudel_set_prop(val stream, val ind, val value) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, set_prop_s); + return funcall3(meth, obj, ind, value); +} + +static val strudel_get_error(val stream) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, get_error_s); + return funcall1(meth, obj); +} + +static val strudel_get_error_str(val stream) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, get_error_str_s); + return funcall1(meth, obj); +} + +static val strudel_clear_error(val stream) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, clear_error_s); + return funcall1(meth, obj); +} + +static val strudel_get_fd(val stream) +{ + struct strudel_base *sb = coerce(struct strudel_base *, stream->co.handle); + val obj = sb->obj; + val meth = slot(obj, get_fd_s); + return funcall1(meth, obj); +} + +static struct strm_ops strudel_ops = + strm_ops_init(cobj_ops_init(eq, + stream_print_op, + stream_destroy_op, + strudel_mark_op, + cobj_eq_hash_op), + wli("struct-delegate-stream"), + strudel_put_string, strudel_put_char, strudel_put_byte, + strudel_get_line, strudel_get_char, strudel_get_byte, + strudel_unget_char, strudel_unget_byte, + strudel_put_buf, strudel_fill_buf, + strudel_close, strudel_flush, strudel_seek, + strudel_truncate, strudel_get_prop, strudel_set_prop, + strudel_get_error, strudel_get_error_str, + strudel_clear_error, strudel_get_fd); + +val make_struct_delegate_stream(val target_obj) +{ + struct strudel_base *sb = coerce(struct strudel_base *, + chk_malloc(sizeof *sb)); + val stream; + strm_base_init(&sb->a); + sb->obj = nil; + stream = cobj(coerce(mem_t *, sb), stream_s, &strudel_ops.cobj_ops); + sb->obj = target_obj; + return stream; +} + +void strudel_init(void) +{ + reg_fun(intern(lit("make-struct-delegate-stream"), user_package), func_n1(make_struct_delegate_stream)); + fill_stream_ops(&strudel_ops); +} diff --git a/strudel.h b/strudel.h new file mode 100644 index 00000000..ba41a08a --- /dev/null +++ b/strudel.h @@ -0,0 +1,30 @@ +/* Copyright 2017 + * Kaz Kylheku <kaz@kylheku.com> + * Vancouver, Canada + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * 1. Redistributions of source code must retain the above copyright notice, this + * list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND + * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED + * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE + * DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE + * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL + * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR + * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER + * CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, + * OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + * OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + + +val make_struct_delegate_stream(val target_obj); +void strudel_init(void); |