diff --git a/cgen.scm b/cgen.scm index 1f168339..47c3357e 100644 --- a/cgen.scm +++ b/cgen.scm @@ -445,6 +445,7 @@ ((eq? p 'peek-char) "Cyc_io_peek_char") ((eq? p 'Cyc-display) "Cyc_display_va") ((eq? p 'Cyc-write) "Cyc_write_va") + ((eq? p 'Cyc-write-char) "Cyc_write_char") ((eq? p 'car) "car") ((eq? p 'cdr) "cdr") ((eq? p 'caar) "caar") diff --git a/eval.scm b/eval.scm index 4235beb2..df70d0e6 100644 --- a/eval.scm +++ b/eval.scm @@ -289,6 +289,7 @@ (list 'close-input-port close-input-port) (list 'read-char read-char) (list 'peek-char peek-char) + (list 'Cyc-write-char Cyc-write-char) (list 'Cyc-write Cyc-write) (list 'Cyc-display Cyc-display))) diff --git a/runtime.c b/runtime.c index ab98e108..63a1bcae 100644 --- a/runtime.c +++ b/runtime.c @@ -483,6 +483,16 @@ object Cyc_write(object x, FILE *port) fprintf(port, "\n"); return y;} +object Cyc_write_char(object c, object port) +{ + if (obj_is_char(c)) { + fprintf(((port_type *)port)->fp, "%c", obj_obj2char(c)); return c; + } else { + Cyc_rt_raise2("Argument is not a character", c); + } + return c; +} + /* Some of these non-consing functions have been optimized from CPS. */ // TODO: should not be a predicate, may end up moving these to Scheme code @@ -1258,6 +1268,8 @@ void _read_91char(object cont, object args) { return_funcall1(cont, Cyc_io_read_char(car(args)));} void _peek_91char(object cont, object args) { return_funcall1(cont, Cyc_io_peek_char(car(args)));} +void _Cyc_91write_91char(object cont, object args) { + return_funcall1(cont, Cyc_write_char(car(args), cadr(args)));} void _Cyc_91write(object cont, object args) { integer_type argc = Cyc_length(args); dispatch(argc.value, (function_type)dispatch_write_va, cont, cont, args); } @@ -1948,6 +1960,7 @@ static primitive_type close_91input_91port_primitive = {primitive_tag, "close-in static primitive_type read_91char_primitive = {primitive_tag, "read-char", &_read_91char}; static primitive_type peek_91char_primitive = {primitive_tag, "peek-char", &_peek_91char}; static primitive_type Cyc_91write_primitive = {primitive_tag, "Cyc-write", &_Cyc_91write}; +static primitive_type Cyc_91write_91char_primitive = {primitive_tag, "Cyc-write-char", &_Cyc_91write_91char}; static primitive_type Cyc_91display_primitive = {primitive_tag, "Cyc-display", &_display}; static primitive_type call_95cc_primitive = {primitive_tag, "call/cc", &_call_95cc}; @@ -2050,6 +2063,7 @@ const object primitive_open_91input_91file = &open_91input_91file_primitive; const object primitive_close_91input_91port = &close_91input_91port_primitive; const object primitive_read_91char = &read_91char_primitive; const object primitive_peek_91char = &peek_91char_primitive; +const object primitive_Cyc_91write_91char = &Cyc_91write_91char_primitive; const object primitive_Cyc_91write = &Cyc_91write_primitive; const object primitive_Cyc_91display = &Cyc_91display_primitive; const object primitive_call_95cc = &call_95cc_primitive; diff --git a/runtime.h b/runtime.h index c2aff99b..21a92634 100644 --- a/runtime.h +++ b/runtime.h @@ -73,6 +73,7 @@ object Cyc_display(object, FILE *port); object dispatch_display_va(int argc, object clo, object cont, 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_char(object c, object port); object Cyc_write(object, FILE *port); object dispatch_write_va(int argc, object clo, object cont, object x, ...); object Cyc_write_va(int argc, object x, ...); @@ -324,6 +325,7 @@ extern const object primitive_open_91input_91file; extern const object primitive_close_91input_91port; extern const object primitive_read_91char; extern const object primitive_peek_91char; +extern const object primitive_Cyc_91write_91char; extern const object primitive_Cyc_91write; extern const object primitive_Cyc_91display; extern const object primitive_call_95cc; diff --git a/scheme/base.sld b/scheme/base.sld index 803e23cf..c3266854 100644 --- a/scheme/base.sld +++ b/scheme/base.sld @@ -119,11 +119,12 @@ (if (null? lst) end (func (car lst) (foldr func end (cdr lst))))) - (define (newline) (display "\n")) (define (write-char char . port) (if (null? port) (Cyc-write-char char (current-output-port)) (Cyc-write-char char (car port)))) + (define (newline . port) + (apply write-char (cons #\newline port))) (define (not x) (if x #f #t)) (define (list? o) (define (_list? obj) diff --git a/transforms.scm b/transforms.scm index 07acf597..5c5c3d23 100644 --- a/transforms.scm +++ b/transforms.scm @@ -555,6 +555,7 @@ close-input-port read-char peek-char + Cyc-write-char Cyc-write Cyc-display))