From b64cdd67249c6367a967af8c317ecd571a35bd40 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 14:58:23 +0900 Subject: [PATCH 01/12] remove redundant code --- src/write.c | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/write.c b/src/write.c index bd13ac44..0d558f35 100644 --- a/src/write.c +++ b/src/write.c @@ -271,12 +271,6 @@ write_core(struct writer_control *p, pic_value obj) 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)); - break; case PIC_TT_STRING: if (p->mode == DISPLAY_MODE) { xfprintf(file, "%s", pic_str_cstr(pic_str_ptr(obj))); From 312914fa0d1051fd595fcaa387cd31910d8ca318 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 15:02:19 +0900 Subject: [PATCH 02/12] use #, reader literal to write eof-object --- src/write.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/write.c b/src/write.c index 0d558f35..aac56071 100644 --- a/src/write.c +++ b/src/write.c @@ -198,6 +198,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,10 +269,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, "#"); + xfprintf(file, "#,(eof-object)"); break; case PIC_TT_STRING: if (p->mode == DISPLAY_MODE) { From e339b7c64a957ff13c96535c87da1ece83d9a79f Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 15:10:48 +0900 Subject: [PATCH 03/12] external form using srfi-10 for dictionaries --- src/write.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/write.c b/src/write.c index aac56071..ba09cdcb 100644 --- a/src/write.c +++ b/src/write.c @@ -10,7 +10,7 @@ #include "picrin/string.h" #include "picrin/vector.h" #include "picrin/blob.h" -#include "picrin/macro.h" +#include "picrin/dict.h" static bool is_tagged(pic_state *pic, pic_sym tag, pic_value pair) @@ -179,6 +179,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; @@ -300,8 +301,18 @@ 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; default: xfprintf(file, "#<%s %p>", pic_type_repr(pic_type(obj)), pic_ptr(obj)); + break; } } From d62727bef95328f642573956585aad569519ad82 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 15:53:22 +0900 Subject: [PATCH 04/12] add read-time eval --- src/read.c | 14 ++++++++++++++ 1 file changed, 14 insertions(+) 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"); } From a4a2bde6baf769329d12c3a6b2a3737526919198 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 15:53:29 +0900 Subject: [PATCH 05/12] use read-time eval literals for eof-object and dictionries --- src/write.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/write.c b/src/write.c index ba09cdcb..bb782fe0 100644 --- a/src/write.c +++ b/src/write.c @@ -270,7 +270,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)"); + xfprintf(file, "#.(eof-object)"); break; case PIC_TT_STRING: if (p->mode == DISPLAY_MODE) { @@ -302,7 +302,7 @@ write_core(struct writer_control *p, pic_value obj) xfprintf(file, ")"); break; case PIC_TT_DICT: - xfprintf(file, "#,(dictionary"); + 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))); From 2b66b7c5a2b12ec4d27ca84393e8077a4ab5d0da Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 15:53:54 +0900 Subject: [PATCH 06/12] allow arbitrary objects at codegen time --- src/codegen.c | 28 +--------------------------- 1 file changed, 1 insertion(+), 27 deletions(-) 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 From 9316ba468b644692feb1c2d0c7baa430b0ce73fc Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 15:54:16 +0900 Subject: [PATCH 07/12] import (picrin array) and (picrin dictionary) in (picrin user) by default --- piclib/picrin/user.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) 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))) From 0f89e04548833b9bf826a62606a4fa810cf93e98 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 16:27:12 +0900 Subject: [PATCH 08/12] small refactoring on --- piclib/scheme/base.scm | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm index d08650b2..ea2699b3 100644 --- a/piclib/scheme/base.scm +++ b/piclib/scheme/base.scm @@ -748,18 +748,18 @@ (import (picrin record)) - (define - (let (( (make-record #t))) ; bootstrap - (let ((type-type (make-record ))) - (record-set! '@@type type-type) - (record-set! type-type 'name ') - ))) + (define #t) ; bootstrap (define (make-record-type name) (let ((rectype (make-record ))) (record-set! rectype 'name name) rectype)) + (set! + (let (( (make-record-type '))) + (record-set! '@@type ) + )) + (define-syntax define-record-constructor (ir-macro-transformer (lambda (form inject compare?) From 7de95e281700e468512f28ce38c0bbcf0cf63495 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 16:54:18 +0900 Subject: [PATCH 09/12] user-defined printers for record objects --- piclib/scheme/base.scm | 19 ++++++++++++++++--- src/write.c | 26 ++++++++++++++++++++++++++ 2 files changed, 42 insertions(+), 3 deletions(-) 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; From 0eecddb5da1adc468a9c2a81eb4c3ec850c605c6 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 17:00:32 +0900 Subject: [PATCH 10/12] set array printer --- piclib/picrin/array.scm | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) 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? From 8a5a3e6b9753ce6fefc36615e2a32f947adc7164 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 22:15:35 +0900 Subject: [PATCH 11/12] refactor record type bootstrap --- piclib/scheme/base.scm | 44 ++++++++++++++++++++++-------------------- 1 file changed, 23 insertions(+), 21 deletions(-) diff --git a/piclib/scheme/base.scm b/piclib/scheme/base.scm index b3542cbd..3e512116 100644 --- a/piclib/scheme/base.scm +++ b/piclib/scheme/base.scm @@ -746,32 +746,34 @@ ;; 5.5 Recored-type definitions - (import (picrin record)) + (import (picrin record) + (scheme write)) - (define #t) ; bootstrap + (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))) - (import (scheme write)) - - (define (make-record-type name ctor) - (let ((rectype (make-record ))) + (define ((boot-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)))) + (record-set! rectype 'writer (default-record-writer ctor)) rectype)) - (set! - (let (( (make-record-type ' '(name writer)))) - (record-set! '@@type ) - )) + (define + (let (( + ((boot-make-record-type #t) 'record-type '(record-type name writer)))) + (record-set! '@@type ) + )) + + (define make-record-type (boot-make-record-type )) (define-syntax define-record-constructor (ir-macro-transformer From 448e3caeaaf0b75d9bcf39b88602849340eb204d Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Wed, 6 Aug 2014 22:15:49 +0900 Subject: [PATCH 12/12] don't use user printer for records in debug mode --- src/write.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/write.c b/src/write.c index 074feba7..70a547b9 100644 --- a/src/write.c +++ b/src/write.c @@ -180,6 +180,12 @@ 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"); @@ -193,6 +199,8 @@ write_record(pic_state *pic, struct pic_record *rec, xFILE *file) 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