aboutsummaryrefslogtreecommitdiff
path: root/exts/io.c
diff options
context:
space:
mode:
Diffstat (limited to 'exts/io.c')
-rw-r--r--exts/io.c295
1 files changed, 295 insertions, 0 deletions
diff --git a/exts/io.c b/exts/io.c
new file mode 100644
index 0000000..76c1520
--- /dev/null
+++ b/exts/io.c
@@ -0,0 +1,295 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include <ctype.h>
+
+#include <bamboo_lisp/interp.h>
+#include <bamboo_lisp/sexp.h>
+
+#define STREAM_TYPEID "ext.core.stream"
+
+typedef struct {
+ FILE *fp;
+ bool should_close;
+} LispStream;
+
+LispUserdataMeta bamboo_lisp_stream_meta;
+
+static bool is_stream_impl(Interp *interp, SExpRef obj) {
+ if (VALTYPE(obj) == kUserDataSExp &&
+ strcmp(STREAM_TYPEID, REF(obj)->userdata_meta->type) == 0) {
+ return true;
+ }
+ return false;
+}
+
+static SExpRef make_stream(Interp* interp, FILE *fp, bool should_close) {
+ SExpRef ret = new_sexp(interp);
+ REF(ret)->type = kUserDataSExp;
+ REF(ret)->userdata_meta = &bamboo_lisp_stream_meta;
+
+ LispStream *s = malloc(sizeof(LispStream));
+ s->fp = fp;
+ s->should_close = should_close;
+
+ REF(ret)->userdata = s;
+ return ret;
+}
+
+static FILE* get_input_stream(Interp* interp, SExpRef args, const char* func_name) {
+ if (NILP(args)) return stdin;
+
+ SExpRef first = CAR(args);
+ if (!is_stream_impl(interp, first)) {
+ new_error(interp, "%s: argument is not a stream.\n", func_name);
+ return NULL;
+ }
+ LispStream *s = (LispStream*)REF(first)->userdata;
+ return s->fp;
+}
+
+static FILE* get_output_stream(Interp* interp, SExpRef args, const char* func_name) {
+ if (NILP(args)) return stdout;
+
+ SExpRef first = CAR(args);
+ if (!is_stream_impl(interp, first)) {
+ new_error(interp, "%s: argument is not a stream.\n", func_name);
+ return NULL;
+ }
+ LispStream *s = (LispStream*)REF(first)->userdata;
+ return s->fp;
+}
+
+// (stream? obj)
+static SExpRef ext_is_stream(Interp* interp, SExpRef args) {
+ if (LENGTH(args) != 1) return new_error(interp, "stream?: wrong args num.\n");
+ return new_boolean(interp, is_stream_impl(interp, CAR(args)));
+}
+
+// (open-file filename mode) -> stream
+static SExpRef ext_open_file(Interp* interp, SExpRef args) {
+ if (LENGTH(args) != 2) return new_error(interp, "open-file: wrong args num.\n");
+
+ SExpRef arg_fname = CAR(args);
+ SExpRef arg_mode = CADR(args);
+
+ if (VALTYPE(arg_fname) != kStringSExp || VALTYPE(arg_mode) != kStringSExp) {
+ return new_error(interp, "open-file: filename and mode must be strings.\n");
+ }
+
+ const char *fname = REF(arg_fname)->str;
+ const char *mode = REF(arg_mode)->str;
+
+ FILE *fp = fopen(fname, mode);
+ if (!fp) {
+ return new_error(interp, "open-file: failed to open file '%s'.\n", fname);
+ }
+
+ return make_stream(interp, fp, true);
+}
+
+// (read-char [stream])
+static SExpRef ext_read_char(Interp* interp, SExpRef args) {
+ if (LENGTH(args) > 1) return new_error(interp, "read-char: too many args.\n");
+
+ FILE *fp = get_input_stream(interp, args, "read-char");
+ if (!fp) return NIL; // Error handled in get_input_stream but returns NULL
+
+ int c = fgetc(fp);
+ if (c == EOF) return NIL; // End of file returns NIL
+
+ return new_char(interp, (char)c);
+}
+
+// (read-integer [stream])
+static SExpRef ext_read_integer(Interp* interp, SExpRef args) {
+ if (LENGTH(args) > 1) return new_error(interp, "read-integer: too many args.\n");
+
+ FILE *fp = get_input_stream(interp, args, "read-integer");
+ if (!fp) return NIL;
+
+ long long val;
+
+ int c;
+ while(isspace(c = fgetc(fp)));
+ ungetc(c, fp);
+
+ if (fscanf(fp, "%lld", &val) == 1) {
+ return new_integer(interp, val);
+ }
+ return NIL;
+}
+
+static SExpRef ext_read_number(Interp* interp, SExpRef args) {
+ if (LENGTH(args) > 1) return new_error(interp, "read-number: too many args.\n");
+
+ FILE *fp = get_input_stream(interp, args, "read-number");
+ if (!fp) return NIL;
+
+ char buffer[64];
+ int idx = 0;
+ int c;
+
+ while ((c = fgetc(fp)) != EOF && isspace(c));
+
+ if (c == EOF) return NIL;
+
+ do {
+ if (idx < 63) buffer[idx++] = (char)c;
+ c = fgetc(fp);
+ } while (c != EOF && !isspace(c) && c != ')' && c != '(');
+
+ if (c != EOF) ungetc(c, fp);
+ buffer[idx] = '\0';
+
+ if (strchr(buffer, '.') != NULL) {
+ char *end;
+ double d = strtod(buffer, &end);
+ if (end != buffer) return new_real(interp, d);
+ } else {
+ char *end;
+ long long i = strtoll(buffer, &end, 10);
+ if (end != buffer) return new_integer(interp, i);
+ }
+
+ return NIL;
+}
+
+static char* internal_read_line(FILE *fp) {
+ size_t cap = 128;
+ size_t len = 0;
+ char *buf = malloc(cap);
+ if (!buf) return NULL;
+
+ int c = fgetc(fp);
+ if (c == EOF) {
+ free(buf);
+ return NULL;
+ }
+
+ while (c != EOF && c != '\n') {
+ if (len + 1 >= cap) {
+ cap *= 2;
+ char *new_buf = realloc(buf, cap);
+ if (!new_buf) { free(buf); return NULL; }
+ buf = new_buf;
+ }
+ buf[len++] = (char)c;
+ c = fgetc(fp);
+ }
+ buf[len] = '\0';
+ return buf;
+}
+
+// (read-line [stream])
+static SExpRef ext_read_line(Interp* interp, SExpRef args) {
+ if (LENGTH(args) > 1) return new_error(interp, "read-line: too many args.\n");
+
+ FILE *fp = get_input_stream(interp, args, "read-line");
+ if (!fp) return NIL;
+
+ char *line = internal_read_line(fp);
+ if (line) {
+ SExpRef ret = new_string(interp, line);
+ free(line);
+ return ret;
+ }
+ return NIL;
+}
+
+// (lines stream) -> list of strings
+static SExpRef ext_lines(Interp* interp, SExpRef args) {
+ if (LENGTH(args) != 1) return new_error(interp, "lines: wrong args num.\n");
+
+ FILE *fp = get_input_stream(interp, args, "lines");
+ if (!fp) return NIL;
+
+ SExpRef list_head = NIL;
+
+ char *line_str;
+ while ((line_str = internal_read_line(fp)) != NULL) {
+ SExpRef s = new_string(interp, line_str);
+ free(line_str);
+ list_head = CONS(s, list_head);
+ }
+
+ return lisp_nreverse(interp, list_head);
+}
+
+static SExpRef ext_stream_close(Interp *interp, SExpRef args) {
+ if (LENGTH(args) != 1) return new_error(interp, "stream-close: wrong args num.\n");
+ SExpRef first = CAR(args);
+ if (!is_stream_impl(interp, first)) {
+ return new_error(interp, "stream-close: argument is not a stream.\n");
+ }
+ LispStream *s = (LispStream*)REF(first)->userdata;
+ if (s->should_close && s->fp != NULL) {
+ fclose(s->fp);
+ s->fp = NULL;
+ s->should_close = false;
+ }
+ return NIL;
+}
+
+// (write-char c [stream])
+static SExpRef ext_write_char(Interp* interp, SExpRef args) {
+ int len = LENGTH(args);
+ if (len < 1 || len > 2) return new_error(interp, "write-char: wrong args num.\n");
+
+ if (VALTYPE(CAR(args)) != kCharSExp)
+ return new_error(interp, "write-char: first arg must be char.\n");
+
+ char c = REF(CAR(args))->character;
+
+ FILE *fp = get_output_stream(interp, CDR(args), "write-char"); // CDR is the rest of args
+ if (!fp) return NIL;
+
+ fputc(c, fp);
+ return NIL;
+}
+
+// (write-obj obj [stream])
+static SExpRef ext_write_obj(Interp* interp, SExpRef args) {
+ int len = LENGTH(args);
+ if (len < 1 || len > 2) return new_error(interp, "write-obj: wrong args num.\n");
+
+ SExpRef obj = CAR(args);
+ FILE *fp = get_output_stream(interp, CDR(args), "write-obj");
+ if (!fp) return NIL;
+
+ lisp_print(interp, obj, fp);
+ return NIL;
+}
+
+static void stream_free(void *vself) {
+ LispStream *self = (LispStream*)vself;
+ if (self->should_close && self->fp) {
+ fclose(self->fp);
+ }
+ free(self);
+}
+
+static void stream_gcmark(Interp *interp, SExpPtrVector *gcstack, void *vself) {
+ (void)interp;
+ (void)gcstack;
+ (void)vself;
+}
+
+int bamboo_lisp_ext_init(Interp *interp) {
+ bamboo_lisp_stream_meta.type = STREAM_TYPEID;
+ bamboo_lisp_stream_meta.free = &stream_free;
+ bamboo_lisp_stream_meta.gcmark = &stream_gcmark;
+
+ Interp_add_userfunc(interp, "stream?", &ext_is_stream);
+ Interp_add_userfunc(interp, "open-file", &ext_open_file);
+ Interp_add_userfunc(interp, "stream-close", &ext_stream_close);
+ Interp_add_userfunc(interp, "read-char", &ext_read_char);
+ Interp_add_userfunc(interp, "read-integer", &ext_read_integer);
+ Interp_add_userfunc(interp, "read-number", &ext_read_number);
+ Interp_add_userfunc(interp, "read-line", &ext_read_line);
+ Interp_add_userfunc(interp, "lines", &ext_lines);
+ Interp_add_userfunc(interp, "write-char", &ext_write_char);
+ Interp_add_userfunc(interp, "write-obj", &ext_write_obj);
+
+ return 1;
+} \ No newline at end of file
generated by cgit v1.0 at 2025-12-29 12:06:59 +0000