From 111cf6f3a64f65a2160112e9dd181d9ce3587cb1 Mon Sep 17 00:00:00 2001 From: Justin Ethier Date: Mon, 8 Jun 2015 23:01:16 -0400 Subject: [PATCH] WIP --- cgen.scm | 6 +- runtime.c | 158 ++++++++++++++++++++++++++++++++---------------- runtime.h | 10 ++- scheme/base.sld | 22 +++---- 4 files changed, 127 insertions(+), 69 deletions(-) diff --git a/cgen.scm b/cgen.scm index 7ef911b0..8269e1b3 100644 --- a/cgen.scm +++ b/cgen.scm @@ -442,8 +442,8 @@ ((eq? p 'close-input-port) "Cyc_io_close_input_port") ((eq? p 'read-char) "Cyc_io_read_char") ((eq? p 'peek-char) "Cyc_io_peek_char") - ((eq? p 'display) "Cyc_display") - ((eq? p 'write) "Cyc_write") + ((eq? p 'display) "Cyc_display_va") + ((eq? p 'write) "Cyc_write_va") ((eq? p 'car) "car") ((eq? p 'cdr) "cdr") ((eq? p 'caar) "caar") @@ -560,7 +560,7 @@ ;; Pass an integer arg count as the function's first parameter? (define (prim:arg-count? exp) (and (prim? exp) - (member exp '(error string-append + - * /)))) + (member exp '(error write display string-append + - * /)))) ;; Does primitive allocate an object? (define (prim:allocates-object? exp) diff --git a/runtime.c b/runtime.c index 783cf962..d26d1e56 100644 --- a/runtime.c +++ b/runtime.c @@ -165,7 +165,7 @@ object Cyc_exception_handler_stack = nil; object Cyc_default_exception_handler(int argc, closure _, object err) { printf("Error: "); - Cyc_display(err); + Cyc_display_va(1, err); printf("\n"); exit(1); return nil; @@ -292,18 +292,39 @@ object Cyc_has_cycle(object lst) { // to the value returned by (current-output-port). It is an // error to attempt an output operation on a closed port // -//object dispatch_display_va(int argc, object x, ...) { -//object Cyc_display_va(int argc, object x, ...) { -// object Cyc_display_va_list(int argc, object x, va_list ap) { +object dispatch_display_va(int argc, object x, ...) { + object result; + va_list ap; + va_start(ap, x); + result = Cyc_display_va_list(argc - 1, x, ap); + va_end(ap); + return result; +} -TODO: change all printf's below: +object Cyc_display_va(int argc, object x, ...) { + object result; + va_list ap; + va_start(ap, x); + result = Cyc_display_va_list(argc, x, ap); + va_end(ap); + return result; +} + +object Cyc_display_va_list(int argc, object x, va_list ap) { + FILE *fp = stdout; // TODO: just a placeholder, should use current-output-port + if (argc > 1) { + object tmp; + tmp = va_arg(ap, object); + fp = ((port_type *)tmp)->fp; + } + return Cyc_display(x, fp);} object Cyc_display(object x, FILE *port) {object tmp = nil; object has_cycle = boolean_f; int i = 0; if (nullp(x)) {fprintf(port, "()"); return x;} - if (obj_is_char(x)) {printf("%c", obj_obj2char(x)); return x;} + if (obj_is_char(x)) {fprintf(port, "%c", obj_obj2char(x)); return x;} switch (type_of(x)) {case closure0_tag: case closure1_tag: @@ -311,57 +332,57 @@ object Cyc_display(object x, FILE *port) case closure3_tag: case closure4_tag: case closureN_tag: - printf("",(void *)((closure) x)->fn); + fprintf(port, "",(void *)((closure) x)->fn); break; case eof_tag: - printf(""); + fprintf(port, ""); break; case port_tag: - printf(""); + fprintf(port, ""); break; case primitive_tag: - printf("", prim_name(x)); + fprintf(port, "", prim_name(x)); break; case cvar_tag: - Cyc_display(Cyc_get_cvar(x)); + Cyc_display(Cyc_get_cvar(x), port); break; case boolean_tag: - printf("#%s",((boolean_type *) x)->pname); + fprintf(port, "#%s",((boolean_type *) x)->pname); break; case symbol_tag: - printf("%s",((symbol_type *) x)->pname); + fprintf(port, "%s",((symbol_type *) x)->pname); break; case integer_tag: - printf("%d", ((integer_type *) x)->value); + fprintf(port, "%d", ((integer_type *) x)->value); break; case double_tag: - printf("%lf", ((double_type *) x)->value); + fprintf(port, "%lf", ((double_type *) x)->value); break; case string_tag: - printf("%s", ((string_type *) x)->str); + fprintf(port, "%s", ((string_type *) x)->str); break; case vector_tag: - printf("#("); + fprintf(port, "#("); for (i = 0; i < ((vector) x)->num_elt; i++) { if (i > 0) { - printf(" "); + fprintf(port, " "); } - Cyc_display(((vector)x)->elts[i]); + Cyc_display(((vector)x)->elts[i], port); } - printf(")"); + fprintf(port, ")"); break; case cons_tag: has_cycle = Cyc_has_cycle(x); - printf("("); - Cyc_display(car(x)); + fprintf(port, "("); + Cyc_display(car(x), port); // Experimenting with displaying lambda defs in REPL // not good enough but this is a start. would probably need // the same code in write() if (equal(quote_Cyc_191procedure, car(x))) { - printf(" "); - Cyc_display(cadr(x)); - printf(" ...)"); /* skip body and env for now */ + fprintf(port, " "); + Cyc_display(cadr(x), port); + fprintf(port, " ...)"); /* skip body and env for now */ break; } @@ -369,44 +390,71 @@ object Cyc_display(object x, FILE *port) if (has_cycle == boolean_t) { if (i++ > 20) break; /* arbitrary number, for now */ } - printf(" "); - Cyc_display(car(tmp)); + fprintf(port, " "); + Cyc_display(car(tmp), port); } if (has_cycle == boolean_t) { - printf(" ..."); + fprintf(port, " ..."); } else if (tmp) { - printf(" . "); - Cyc_display(tmp); + fprintf(port, " . "); + Cyc_display(tmp, port); } - printf(")"); + fprintf(port, ")"); break; default: - printf("Cyc_display: bad tag x=%ld\n", ((closure)x)->tag); getchar(); exit(0);} + fprintf(port, "Cyc_display: bad tag x=%ld\n", ((closure)x)->tag); getchar(); exit(0);} return x;} -static object _Cyc_write(x) object x; +object dispatch_write_va(int argc, object x, ...) { + object result; + va_list ap; + va_start(ap, x); + result = Cyc_write_va_list(argc - 1, x, ap); + va_end(ap); + return result; +} + +object Cyc_write_va(int argc, object x, ...) { + object result; + va_list ap; + va_start(ap, x); + result = Cyc_write_va_list(argc, x, ap); + va_end(ap); + return result; +} + +object Cyc_write_va_list(int argc, object x, va_list ap) { + FILE *fp = stdout; // TODO: just a placeholder, should use current-output-port + if (argc > 1) { + object tmp; + tmp = va_arg(ap, object); + fp = ((port_type *)tmp)->fp; + } + return Cyc_write(x, fp);} + +static object _Cyc_write(object x, FILE *port) {object tmp = nil; object has_cycle = boolean_f; int i = 0; - if (nullp(x)) {printf("()"); return x;} - if (obj_is_char(x)) {printf("#\\%c", obj_obj2char(x)); return x;} + if (nullp(x)) {fprintf(port, "()"); return x;} + if (obj_is_char(x)) {fprintf(port, "#\\%c", obj_obj2char(x)); return x;} switch (type_of(x)) {case string_tag: - printf("\"%s\"", ((string_type *) x)->str); + fprintf(port, "\"%s\"", ((string_type *) x)->str); break; // TODO: what about a list? contents should be displayed per (write) case cons_tag: has_cycle = Cyc_has_cycle(x); - printf("("); - _Cyc_write(car(x)); + fprintf(port, "("); + _Cyc_write(car(x), port); // Experimenting with displaying lambda defs in REPL // not good enough but this is a start. would probably need // the same code in write() if (equal(quote_Cyc_191procedure, car(x))) { - printf(" "); - _Cyc_write(cadr(x)); - printf(" ...)"); /* skip body and env for now */ + fprintf(port, " "); + _Cyc_write(cadr(x), port); + fprintf(port, " ...)"); /* skip body and env for now */ break; } @@ -414,24 +462,24 @@ static object _Cyc_write(x) object x; if (has_cycle == boolean_t) { if (i++ > 20) break; /* arbitrary number, for now */ } - printf(" "); - _Cyc_write(car(tmp)); + fprintf(port, " "); + _Cyc_write(car(tmp), port); } if (has_cycle == boolean_t) { - printf(" ..."); + fprintf(port, " ..."); } else if (tmp) { - printf(" . "); - _Cyc_write(tmp); + fprintf(port, " . "); + _Cyc_write(tmp, port); } - printf(")"); + fprintf(port, ")"); break; default: - Cyc_display(x);} + Cyc_display(x, port);} return x;} -object Cyc_write(x) object x; -{object y = _Cyc_write(x); - printf("\n"); +object Cyc_write(object x, FILE *port) +{object y = _Cyc_write(x, port); + fprintf(port, "\n"); return y;} /* Some of these non-consing functions have been optimized from CPS. */ @@ -1205,9 +1253,13 @@ void _read_91char(object cont, object args) { void _peek_91char(object cont, object args) { return_funcall1(cont, Cyc_io_peek_char(car(args)));} void _write(object cont, object args) { - return_funcall1(cont, Cyc_write(car(args))); } + + TODO: this and _display below are broken and crashing in icyc. not sure what is going on? + integer_type argc = Cyc_length(args); + dispatch(argc.value, (function_type)dispatch_write_va, cont, cont, args); } void _display(object cont, object args) { - return_funcall1(cont, Cyc_display(car(args)));} + integer_type argc = Cyc_length(args); + dispatch(argc.value, (function_type)dispatch_display_va, cont, cont, args); } void _call_95cc(object cont, object args){ return_funcall2(__glo_call_95cc, cont, car(args)); } diff --git a/runtime.h b/runtime.h index 87d9535c..5fd2a6f9 100644 --- a/runtime.h +++ b/runtime.h @@ -68,8 +68,14 @@ string_type Cyc_string_append_va_list(int, object, va_list); list mcons(object,object); cvar_type *mcvar(object *var); object terpri(void); -object Cyc_display(object); -object Cyc_write(object); +object Cyc_display(object, FILE *port); +object dispatch_display_va(int argc, object x, ...); +object Cyc_display_va(int argc, object x, ...); +object Cyc_display_va_list(int argc, object x, va_list ap); +object Cyc_write(object, FILE *port); +object dispatch_write_va(int argc, object x, ...); +object Cyc_write_va(int argc, object x, ...); +object Cyc_write_va_list(int argc, object x, va_list ap); object Cyc_has_cycle(object lst); list assoc(object x, list l); diff --git a/scheme/base.sld b/scheme/base.sld index 7c01da04..0b295692 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -6,9 +6,9 @@ ;delete-duplicates call-with-current-continuation call/cc - call-with-values - dynamic-wind - values + ;call-with-values + ;dynamic-wind + ;values ;(Cyc-bin-op cmp x lst) ;(Cyc-bin-op-char cmp c cs) char=? @@ -70,14 +70,14 @@ (lambda (cont) (apply cont things)))) ;; TODO: just need something good enough for bootstrapping (for now) ;; does not have to be perfect (this is not, does not handle call/cc or exceptions) - (define (dynamic-wind before thunk after) - (before) - (call-with-values - thunk - (lambda (result) ;results - (after) - result))) - ;(apply values results)))) + ;(define (dynamic-wind before thunk after) + ; (before) + ; (call-with-values + ; thunk + ; (lambda (result) ;results + ; (after) + ; result))) + ; ;(apply values results)))) (define (Cyc-bin-op cmp x lst) (cond ((null? lst) #t)