diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm index ea2699b3..b3542cbd 100644 --- a/piclib/scheme/base.scm +++ b/piclib/scheme/base.scm @@ -750,13 +750,26 @@ (define #t) ; bootstrap - (define (make-record-type name) + (import (scheme write)) + + (define (make-record-type name ctor) (let ((rectype (make-record ))) (record-set! rectype 'name name) + (record-set! rectype 'writer (lambda (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)))) rectype)) (set! - (let (( (make-record-type '))) + (let (( (make-record-type ' '(name writer)))) (record-set! '@@type ) )) @@ -813,7 +826,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/write.c b/src/write.c index bb782fe0..074feba7 100644 --- a/src/write.c +++ b/src/write.c @@ -11,6 +11,8 @@ #include "picrin/vector.h" #include "picrin/blob.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,27 @@ 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; + + 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))); +} + static void write_core(struct writer_control *p, pic_value obj) { @@ -310,6 +333,9 @@ write_core(struct writer_control *p, pic_value obj) } 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;