Merge branch 'reader-constructor'

This commit is contained in:
Yuichi Nishiwaki 2014-08-07 00:30:02 +09:00
commit 6996b80f10
6 changed files with 111 additions and 51 deletions

View File

@ -1,5 +1,7 @@
(define-library (picrin array)
(import (scheme base))
(import (scheme base)
(scheme write)
(picrin record))
(define-record-type <array>
(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! <array> 'writer print-array)
(export make-array
array
array?

View File

@ -11,4 +11,6 @@
(scheme cxr)
(scheme lazy)
(scheme time)
(picrin macro)))
(picrin macro)
(picrin dictionary)
(picrin array)))

View File

@ -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 <meta-type>) name ctor)
(let ((rectype (make-record <meta-type>)))
(record-set! rectype 'name name)
(record-set! rectype 'writer (default-record-writer ctor))
rectype))
(define <record-type>
(let ((<record-type> (make-record #t))) ; bootstrap
(let ((type-type (make-record <record-type>)))
(record-set! <record-type> '@@type type-type)
(record-set! type-type 'name '<record-type>)
<record-type>)))
(let ((<record-type>
((boot-make-record-type #t) 'record-type '(record-type name writer))))
(record-set! <record-type> '@@type <record-type>)
<record-type>))
(define (make-record-type name)
(let ((rectype (make-record <record-type>)))
(record-set! rectype 'name name)
rectype))
(define make-record-type (boot-make-record-type <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))

View File

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

View File

@ -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");
}

View File

@ -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, "#<record %p>", 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, "#<undef>");
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, "#<eof-object>");
break;
case PIC_TT_UNDEF:
xfprintf(file, "#<undef>");
break;
case PIC_TT_PROC:
xfprintf(file, "#<proc %p>", pic_ptr(obj));
break;
case PIC_TT_PORT:
xfprintf(file, "#<port %p>", 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;
}
}