diff --git a/piclib/picrin/array.scm b/piclib/picrin/array.scm index 66aaa5b5..d8a2d45a 100644 --- a/piclib/picrin/array.scm +++ b/piclib/picrin/array.scm @@ -1,5 +1,7 @@ (define-library (picrin array) - (import (scheme base)) + (import (scheme base) + (scheme write) + (picrin record)) (define-record-type (create-array data size head tail) @@ -87,6 +89,20 @@ (define (array-for-each proc ary) (for-each proc (array->list ary))) + (define (print-array array) + (call-with-port (open-output-string) + (lambda (port) + (display "#.(array" port) + (array-for-each + (lambda (obj) + (display " " port) + (write obj port)) + array) + (display ")" port) + (get-output-string port)))) + + (record-set! 'writer print-array) + (export make-array array array? diff --git a/piclib/picrin/user.scm b/piclib/picrin/user.scm index db615a43..5121ddc3 100644 --- a/piclib/picrin/user.scm +++ b/piclib/picrin/user.scm @@ -11,4 +11,6 @@ (scheme cxr) (scheme lazy) (scheme time) - (picrin macro))) + (picrin macro) + (picrin dictionary) + (picrin array))) diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm index 02f3c9e2..186b2f57 100644 --- a/piclib/scheme/base.scm +++ b/piclib/scheme/base.scm @@ -750,19 +750,34 @@ ;; 5.5 Recored-type definitions - (import (picrin record)) + (import (picrin record) + (scheme write)) + + (define ((default-record-writer ctor) obj) + (let ((port (open-output-string))) + (display "#.(" port) + (display (car ctor) port) + (for-each + (lambda (field) + (display " " port) + (write (record-ref obj field) port)) + (cdr ctor)) + (display ")" port) + (get-output-string port))) + + (define ((boot-make-record-type ) name ctor) + (let ((rectype (make-record ))) + (record-set! rectype 'name name) + (record-set! rectype 'writer (default-record-writer ctor)) + rectype)) (define - (let (( (make-record #t))) ; bootstrap - (let ((type-type (make-record ))) - (record-set! '@@type type-type) - (record-set! type-type 'name ') - ))) + (let (( + ((boot-make-record-type #t) 'record-type '(record-type name writer)))) + (record-set! '@@type ) + )) - (define (make-record-type name) - (let ((rectype (make-record ))) - (record-set! rectype 'name name) - rectype)) + (define make-record-type (boot-make-record-type )) (define-syntax define-record-constructor (ir-macro-transformer @@ -817,7 +832,7 @@ (pred (car (cdr (cdr (cdr form))))) (fields (cdr (cdr (cdr (cdr form)))))) `(begin - (define ,name (make-record-type ',name)) + (define ,name (make-record-type ',name ',ctor)) (define-record-constructor ,name ,@ctor) (define-record-predicate ,name ,pred) ,@(map (lambda (field) `(define-record-field ,pred ,@field)) diff --git a/src/codegen.c b/src/codegen.c index b8023e5c..c1264dfb 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -796,35 +796,9 @@ analyze_node(analyze_state *state, pic_value obj, bool tailpos) return analyze_call(state, obj, tailpos); } - case PIC_TT_BOOL: - case PIC_TT_FLOAT: - case PIC_TT_INT: - case PIC_TT_NIL: - case PIC_TT_CHAR: - case PIC_TT_STRING: - case PIC_TT_VECTOR: - case PIC_TT_BLOB: { + default: return pic_list2(pic, pic_symbol_value(pic->sQUOTE), obj); } - case PIC_TT_CONT: - case PIC_TT_ENV: - case PIC_TT_PROC: - case PIC_TT_UNDEF: - case PIC_TT_EOF: - case PIC_TT_PORT: - case PIC_TT_ERROR: - case PIC_TT_SENV: - case PIC_TT_MACRO: - case PIC_TT_LIB: - case PIC_TT_VAR: - case PIC_TT_IREP: - case PIC_TT_DATA: - case PIC_TT_DICT: - case PIC_TT_RECORD: - case PIC_TT_BLK: - pic_errorf(pic, "invalid expression given: ~s", obj); - } - UNREACHABLE(); } pic_value diff --git a/src/read.c b/src/read.c index 8c9621ee..489426b5 100644 --- a/src/read.c +++ b/src/read.c @@ -149,6 +149,18 @@ read_directive(pic_state *pic, struct pic_port *port, int c) return read_comment(pic, port, c); } +static pic_value +read_eval(pic_state *pic, struct pic_port *port, int c) +{ + pic_value form; + + UNUSED(c); + + form = read(pic, port, next(port)); + + return pic_eval(pic, form, pic->lib); +} + static pic_value read_quote(pic_state *pic, struct pic_port *port, int c) { @@ -655,6 +667,8 @@ read_dispatch(pic_state *pic, struct pic_port *port, int c) return read_label(pic, port, c); case 'u': return read_unsigned_blob(pic, port, c); + case '.': + return read_eval(pic, port, c); default: read_error(pic, "unexpected dispatch character"); } diff --git a/src/write.c b/src/write.c index bd13ac44..70a547b9 100644 --- a/src/write.c +++ b/src/write.c @@ -10,7 +10,9 @@ #include "picrin/string.h" #include "picrin/vector.h" #include "picrin/blob.h" -#include "picrin/macro.h" +#include "picrin/dict.h" +#include "picrin/record.h" +#include "picrin/proc.h" static bool is_tagged(pic_state *pic, pic_sym tag, pic_value pair) @@ -172,6 +174,35 @@ write_str(pic_state *pic, struct pic_string *str, xFILE *file) } } +static void +write_record(pic_state *pic, struct pic_record *rec, xFILE *file) +{ + const pic_sym sWRITER = pic_intern_cstr(pic, "writer"); + pic_value type, writer, str; + +#if DEBUG + + xfprintf(file, "#", rec); + +#else + + type = pic_record_type(pic, rec); + if (! pic_record_p(type)) { + pic_errorf(pic, "\"@@type\" property of record object is not of record type"); + } + writer = pic_record_ref(pic, pic_record_ptr(type), sWRITER); + if (! pic_proc_p(writer)) { + pic_errorf(pic, "\"writer\" property of record type object is not a procedure"); + } + str = pic_apply1(pic, pic_proc_ptr(writer), pic_obj_value(rec)); + if (! pic_str_p(str)) { + pic_errorf(pic, "return value from writer procedure is not of string type"); + } + xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(str))); + +#endif +} + static void write_core(struct writer_control *p, pic_value obj) { @@ -179,6 +210,7 @@ write_core(struct writer_control *p, pic_value obj) xFILE *file = p->file; size_t i; xh_entry *e; + xh_iter it; int c; float f; @@ -198,6 +230,9 @@ write_core(struct writer_control *p, pic_value obj) } switch (pic_type(obj)) { + case PIC_TT_UNDEF: + xfprintf(file, "#"); + break; case PIC_TT_NIL: xfprintf(file, "()"); break; @@ -266,16 +301,7 @@ write_core(struct writer_control *p, pic_value obj) xfprintf(file, "%d", pic_int(obj)); break; case PIC_TT_EOF: - xfprintf(file, "#"); - break; - case PIC_TT_UNDEF: - xfprintf(file, "#"); - break; - case PIC_TT_PROC: - xfprintf(file, "#", pic_ptr(obj)); - break; - case PIC_TT_PORT: - xfprintf(file, "#", pic_ptr(obj)); + xfprintf(file, "#.(eof-object)"); break; case PIC_TT_STRING: if (p->mode == DISPLAY_MODE) { @@ -306,8 +332,21 @@ write_core(struct writer_control *p, pic_value obj) } xfprintf(file, ")"); break; + case PIC_TT_DICT: + xfprintf(file, "#.(dictionary"); + xh_begin(&it, &pic_dict_ptr(obj)->hash); + while (xh_next(&it)) { + xfprintf(file, " '%s ", pic_symbol_name(pic, xh_key(it.e, pic_sym))); + write_core(p, xh_val(it.e, pic_value)); + } + xfprintf(file, ")"); + break; + case PIC_TT_RECORD: + write_record(pic, pic_record_ptr(obj), file); + break; default: xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); + break; } }