conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

user-defined printers for record objects

This commit is contained in:
Yuichi Nishiwaki 2014-08-06 16:54:18 +09:00
parent 0f89e04548
commit 7de95e2817
2 changed files with 42 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
piclib/scheme/base.scm
View File

@ -750,13 +750,26 @@
(define <record-type> #t) ; bootstrap
(define (make-record-type name)
(import (scheme write))
(define (make-record-type name ctor)
(let ((rectype (make-record <record-type>)))
(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! <record-type>
(let ((<record-type> (make-record-type '<record-type>)))
(let ((<record-type> (make-record-type '<record-type> '(name writer))))
(record-set! <record-type> '@@type <record-type>)
<record-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))

26
src/write.c
View File

@ -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;