split functions related to 'write' procedure into files
This commit is contained in:
Yuichi Nishiwaki
parent
eaf79ce757
commit
41dea6c5d2
|
|
@ -25,6 +25,7 @@ void pic_init_str(pic_state *);
|
||||||
void pic_init_macro(pic_state *);
|
void pic_init_macro(pic_state *);
|
||||||
void pic_init_var(pic_state *);
|
void pic_init_var(pic_state *);
|
||||||
void pic_init_load(pic_state *);
|
void pic_init_load(pic_state *);
|
||||||
|
void pic_init_write(pic_state *);
|
||||||
|
|
||||||
void
|
void
|
||||||
pic_load_stdlib(pic_state *pic)
|
pic_load_stdlib(pic_state *pic)
|
||||||
|
|
@ -115,6 +116,7 @@ pic_init_core(pic_state *pic)
|
||||||
pic_init_macro(pic); DONE;
|
pic_init_macro(pic); DONE;
|
||||||
pic_init_var(pic); DONE;
|
pic_init_var(pic); DONE;
|
||||||
pic_init_load(pic); DONE;
|
pic_init_load(pic); DONE;
|
||||||
|
pic_init_write(pic); DONE;
|
||||||
|
|
||||||
/* native VM procedures */
|
/* native VM procedures */
|
||||||
register_renamed_symbol(pic, rCONS, "cons");
|
register_renamed_symbol(pic, rCONS, "cons");
|
||||||
|
|
|
||||||
166
src/port.c
166
src/port.c
|
|
@ -6,8 +6,6 @@
|
||||||
#include "picrin.h"
|
#include "picrin.h"
|
||||||
#include "picrin/proc.h"
|
#include "picrin/proc.h"
|
||||||
#include "picrin/port.h"
|
#include "picrin/port.h"
|
||||||
#include "picrin/blob.h"
|
|
||||||
#include "picrin/macro.h"
|
|
||||||
|
|
||||||
pic_value
|
pic_value
|
||||||
pic_eof_object()
|
pic_eof_object()
|
||||||
|
|
@ -272,154 +270,6 @@ pic_fputs(const char *str, pic_file *file)
|
||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
static void write_pair(pic_state *pic, struct pic_pair *pair);
|
|
||||||
static void write_str(pic_state *pic, struct pic_string *str);
|
|
||||||
|
|
||||||
static void
|
|
||||||
write(pic_state *pic, pic_value obj)
|
|
||||||
{
|
|
||||||
int i;
|
|
||||||
|
|
||||||
switch (pic_type(obj)) {
|
|
||||||
case PIC_TT_NIL:
|
|
||||||
printf("()");
|
|
||||||
break;
|
|
||||||
case PIC_TT_BOOL:
|
|
||||||
if (pic_true_p(obj))
|
|
||||||
printf("#t");
|
|
||||||
else
|
|
||||||
printf("#f");
|
|
||||||
break;
|
|
||||||
case PIC_TT_PAIR:
|
|
||||||
printf("(");
|
|
||||||
write_pair(pic, pic_pair_ptr(obj));
|
|
||||||
printf(")");
|
|
||||||
break;
|
|
||||||
case PIC_TT_SYMBOL:
|
|
||||||
printf("%s", pic_symbol_name(pic, pic_sym(obj)));
|
|
||||||
break;
|
|
||||||
case PIC_TT_CHAR:
|
|
||||||
switch (pic_char(obj)) {
|
|
||||||
default: printf("#\\%c", pic_char(obj)); break;
|
|
||||||
case '\a': printf("#\\alarm"); break;
|
|
||||||
case '\b': printf("#\\backspace"); break;
|
|
||||||
case 0x7f: printf("#\\delete"); break;
|
|
||||||
case 0x1b: printf("#\\escape"); break;
|
|
||||||
case '\n': printf("#\\newline"); break;
|
|
||||||
case '\r': printf("#\\return"); break;
|
|
||||||
case ' ': printf("#\\space"); break;
|
|
||||||
case '\t': printf("#\\tab"); break;
|
|
||||||
}
|
|
||||||
break;
|
|
||||||
case PIC_TT_FLOAT:
|
|
||||||
printf("%f", pic_float(obj));
|
|
||||||
break;
|
|
||||||
case PIC_TT_INT:
|
|
||||||
printf("%d", pic_int(obj));
|
|
||||||
break;
|
|
||||||
case PIC_TT_EOF:
|
|
||||||
printf("#<eof-object>");
|
|
||||||
break;
|
|
||||||
case PIC_TT_UNDEF:
|
|
||||||
printf("#<undef>");
|
|
||||||
break;
|
|
||||||
case PIC_TT_PROC:
|
|
||||||
printf("#<proc %p>", pic_ptr(obj));
|
|
||||||
break;
|
|
||||||
case PIC_TT_PORT:
|
|
||||||
printf("#<port %p>", pic_ptr(obj));
|
|
||||||
break;
|
|
||||||
case PIC_TT_STRING:
|
|
||||||
printf("\"");
|
|
||||||
write_str(pic, pic_str_ptr(obj));
|
|
||||||
printf("\"");
|
|
||||||
break;
|
|
||||||
case PIC_TT_VECTOR:
|
|
||||||
printf("#(");
|
|
||||||
for (i = 0; i < pic_vec_ptr(obj)->len; ++i) {
|
|
||||||
write(pic, pic_vec_ptr(obj)->data[i]);
|
|
||||||
if (i + 1 < pic_vec_ptr(obj)->len) {
|
|
||||||
printf(" ");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
printf(")");
|
|
||||||
break;
|
|
||||||
case PIC_TT_BLOB:
|
|
||||||
printf("#u8(");
|
|
||||||
for (i = 0; i < pic_blob_ptr(obj)->len; ++i) {
|
|
||||||
printf("%d", pic_blob_ptr(obj)->data[i]);
|
|
||||||
if (i + 1 < pic_blob_ptr(obj)->len) {
|
|
||||||
printf(" ");
|
|
||||||
}
|
|
||||||
}
|
|
||||||
printf(")");
|
|
||||||
break;
|
|
||||||
case PIC_TT_ERROR:
|
|
||||||
printf("#<error %p>", pic_ptr(obj));
|
|
||||||
break;
|
|
||||||
case PIC_TT_ENV:
|
|
||||||
printf("#<env %p>", pic_ptr(obj));
|
|
||||||
break;
|
|
||||||
case PIC_TT_CONT:
|
|
||||||
printf("#<cont %p>", pic_ptr(obj));
|
|
||||||
break;
|
|
||||||
case PIC_TT_SENV:
|
|
||||||
printf("#<senv %p>", pic_ptr(obj));
|
|
||||||
break;
|
|
||||||
case PIC_TT_SYNTAX:
|
|
||||||
printf("#<syntax %p>", pic_ptr(obj));
|
|
||||||
break;
|
|
||||||
case PIC_TT_SC:
|
|
||||||
printf("#<sc %p: ", pic_ptr(obj));
|
|
||||||
write(pic, pic_sc(obj)->expr);
|
|
||||||
printf(">");
|
|
||||||
break;
|
|
||||||
case PIC_TT_LIB:
|
|
||||||
printf("#<library %p>", pic_ptr(obj));
|
|
||||||
break;
|
|
||||||
case PIC_TT_VAR:
|
|
||||||
printf("#<var %p>", pic_ptr(obj));
|
|
||||||
break;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
static void
|
|
||||||
write_pair(pic_state *pic, struct pic_pair *pair)
|
|
||||||
{
|
|
||||||
write(pic, pair->car);
|
|
||||||
|
|
||||||
if (pic_nil_p(pair->cdr)) {
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
if (pic_pair_p(pair->cdr)) {
|
|
||||||
printf(" ");
|
|
||||||
write_pair(pic, pic_pair_ptr(pair->cdr));
|
|
||||||
return;
|
|
||||||
}
|
|
||||||
printf(" . ");
|
|
||||||
write(pic, pair->cdr);
|
|
||||||
}
|
|
||||||
|
|
||||||
static void
|
|
||||||
write_str(pic_state *pic, struct pic_string *str)
|
|
||||||
{
|
|
||||||
int i;
|
|
||||||
const char *cstr = str->str;
|
|
||||||
|
|
||||||
for (i = 0; i < str->len; ++i) {
|
|
||||||
if (cstr[i] == '"' || cstr[i] == '\\') {
|
|
||||||
putchar('\\');
|
|
||||||
}
|
|
||||||
putchar(cstr[i]);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
void
|
|
||||||
pic_debug(pic_state *pic, pic_value obj)
|
|
||||||
{
|
|
||||||
write(pic, obj);
|
|
||||||
}
|
|
||||||
|
|
||||||
static pic_value
|
static pic_value
|
||||||
port_new_from_fp(pic_state *pic, FILE *fp, short flags)
|
port_new_from_fp(pic_state *pic, FILE *fp, short flags)
|
||||||
{
|
{
|
||||||
|
|
@ -644,16 +494,6 @@ pic_port_peek_char(pic_state *pic)
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
static pic_value
|
|
||||||
pic_port_write_simple(pic_state *pic)
|
|
||||||
{
|
|
||||||
pic_value v;
|
|
||||||
|
|
||||||
pic_get_args(pic, "o", &v);
|
|
||||||
write(pic, v);
|
|
||||||
return pic_none_value();
|
|
||||||
}
|
|
||||||
|
|
||||||
static pic_value
|
static pic_value
|
||||||
pic_port_newline(pic_state *pic)
|
pic_port_newline(pic_state *pic)
|
||||||
{
|
{
|
||||||
|
|
@ -722,10 +562,4 @@ pic_init_port(pic_state *pic)
|
||||||
pic_defun(pic, "newline", pic_port_newline);
|
pic_defun(pic, "newline", pic_port_newline);
|
||||||
pic_defun(pic, "write-char", pic_port_write_char);
|
pic_defun(pic, "write-char", pic_port_write_char);
|
||||||
pic_defun(pic, "flush-output-port", pic_port_flush);
|
pic_defun(pic, "flush-output-port", pic_port_flush);
|
||||||
|
|
||||||
DEFLIBRARY(pic, "(scheme write)")
|
|
||||||
{
|
|
||||||
pic_defun(pic, "write-simple", pic_port_write_simple);
|
|
||||||
}
|
|
||||||
ENDLIBRARY(pic);
|
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,173 @@
|
||||||
|
#include "picrin.h"
|
||||||
|
#include "picrin/port.h"
|
||||||
|
#include "picrin/pair.h"
|
||||||
|
#include "picrin/blob.h"
|
||||||
|
#include "picrin/macro.h"
|
||||||
|
|
||||||
|
static void write_pair(pic_state *pic, struct pic_pair *pair);
|
||||||
|
static void write_str(pic_state *pic, struct pic_string *str);
|
||||||
|
|
||||||
|
static void
|
||||||
|
write(pic_state *pic, pic_value obj)
|
||||||
|
{
|
||||||
|
int i;
|
||||||
|
|
||||||
|
switch (pic_type(obj)) {
|
||||||
|
case PIC_TT_NIL:
|
||||||
|
printf("()");
|
||||||
|
break;
|
||||||
|
case PIC_TT_BOOL:
|
||||||
|
if (pic_true_p(obj))
|
||||||
|
printf("#t");
|
||||||
|
else
|
||||||
|
printf("#f");
|
||||||
|
break;
|
||||||
|
case PIC_TT_PAIR:
|
||||||
|
printf("(");
|
||||||
|
write_pair(pic, pic_pair_ptr(obj));
|
||||||
|
printf(")");
|
||||||
|
break;
|
||||||
|
case PIC_TT_SYMBOL:
|
||||||
|
printf("%s", pic_symbol_name(pic, pic_sym(obj)));
|
||||||
|
break;
|
||||||
|
case PIC_TT_CHAR:
|
||||||
|
switch (pic_char(obj)) {
|
||||||
|
default: printf("#\\%c", pic_char(obj)); break;
|
||||||
|
case '\a': printf("#\\alarm"); break;
|
||||||
|
case '\b': printf("#\\backspace"); break;
|
||||||
|
case 0x7f: printf("#\\delete"); break;
|
||||||
|
case 0x1b: printf("#\\escape"); break;
|
||||||
|
case '\n': printf("#\\newline"); break;
|
||||||
|
case '\r': printf("#\\return"); break;
|
||||||
|
case ' ': printf("#\\space"); break;
|
||||||
|
case '\t': printf("#\\tab"); break;
|
||||||
|
}
|
||||||
|
break;
|
||||||
|
case PIC_TT_FLOAT:
|
||||||
|
printf("%f", pic_float(obj));
|
||||||
|
break;
|
||||||
|
case PIC_TT_INT:
|
||||||
|
printf("%d", pic_int(obj));
|
||||||
|
break;
|
||||||
|
case PIC_TT_EOF:
|
||||||
|
printf("#<eof-object>");
|
||||||
|
break;
|
||||||
|
case PIC_TT_UNDEF:
|
||||||
|
printf("#<undef>");
|
||||||
|
break;
|
||||||
|
case PIC_TT_PROC:
|
||||||
|
printf("#<proc %p>", pic_ptr(obj));
|
||||||
|
break;
|
||||||
|
case PIC_TT_PORT:
|
||||||
|
printf("#<port %p>", pic_ptr(obj));
|
||||||
|
break;
|
||||||
|
case PIC_TT_STRING:
|
||||||
|
printf("\"");
|
||||||
|
write_str(pic, pic_str_ptr(obj));
|
||||||
|
printf("\"");
|
||||||
|
break;
|
||||||
|
case PIC_TT_VECTOR:
|
||||||
|
printf("#(");
|
||||||
|
for (i = 0; i < pic_vec_ptr(obj)->len; ++i) {
|
||||||
|
write(pic, pic_vec_ptr(obj)->data[i]);
|
||||||
|
if (i + 1 < pic_vec_ptr(obj)->len) {
|
||||||
|
printf(" ");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
printf(")");
|
||||||
|
break;
|
||||||
|
case PIC_TT_BLOB:
|
||||||
|
printf("#u8(");
|
||||||
|
for (i = 0; i < pic_blob_ptr(obj)->len; ++i) {
|
||||||
|
printf("%d", pic_blob_ptr(obj)->data[i]);
|
||||||
|
if (i + 1 < pic_blob_ptr(obj)->len) {
|
||||||
|
printf(" ");
|
||||||
|
}
|
||||||
|
}
|
||||||
|
printf(")");
|
||||||
|
break;
|
||||||
|
case PIC_TT_ERROR:
|
||||||
|
printf("#<error %p>", pic_ptr(obj));
|
||||||
|
break;
|
||||||
|
case PIC_TT_ENV:
|
||||||
|
printf("#<env %p>", pic_ptr(obj));
|
||||||
|
break;
|
||||||
|
case PIC_TT_CONT:
|
||||||
|
printf("#<cont %p>", pic_ptr(obj));
|
||||||
|
break;
|
||||||
|
case PIC_TT_SENV:
|
||||||
|
printf("#<senv %p>", pic_ptr(obj));
|
||||||
|
break;
|
||||||
|
case PIC_TT_SYNTAX:
|
||||||
|
printf("#<syntax %p>", pic_ptr(obj));
|
||||||
|
break;
|
||||||
|
case PIC_TT_SC:
|
||||||
|
printf("#<sc %p: ", pic_ptr(obj));
|
||||||
|
write(pic, pic_sc(obj)->expr);
|
||||||
|
printf(">");
|
||||||
|
break;
|
||||||
|
case PIC_TT_LIB:
|
||||||
|
printf("#<library %p>", pic_ptr(obj));
|
||||||
|
break;
|
||||||
|
case PIC_TT_VAR:
|
||||||
|
printf("#<var %p>", pic_ptr(obj));
|
||||||
|
break;
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
static void
|
||||||
|
write_pair(pic_state *pic, struct pic_pair *pair)
|
||||||
|
{
|
||||||
|
write(pic, pair->car);
|
||||||
|
|
||||||
|
if (pic_nil_p(pair->cdr)) {
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
if (pic_pair_p(pair->cdr)) {
|
||||||
|
printf(" ");
|
||||||
|
write_pair(pic, pic_pair_ptr(pair->cdr));
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
printf(" . ");
|
||||||
|
write(pic, pair->cdr);
|
||||||
|
}
|
||||||
|
|
||||||
|
static void
|
||||||
|
write_str(pic_state *pic, struct pic_string *str)
|
||||||
|
{
|
||||||
|
int i;
|
||||||
|
const char *cstr = str->str;
|
||||||
|
|
||||||
|
for (i = 0; i < str->len; ++i) {
|
||||||
|
if (cstr[i] == '"' || cstr[i] == '\\') {
|
||||||
|
putchar('\\');
|
||||||
|
}
|
||||||
|
putchar(cstr[i]);
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
void
|
||||||
|
pic_debug(pic_state *pic, pic_value obj)
|
||||||
|
{
|
||||||
|
write(pic, obj);
|
||||||
|
}
|
||||||
|
|
||||||
|
static pic_value
|
||||||
|
pic_port_write_simple(pic_state *pic)
|
||||||
|
{
|
||||||
|
pic_value v;
|
||||||
|
|
||||||
|
pic_get_args(pic, "o", &v);
|
||||||
|
write(pic, v);
|
||||||
|
return pic_none_value();
|
||||||
|
}
|
||||||
|
|
||||||
|
void
|
||||||
|
pic_init_write(pic_state *pic)
|
||||||
|
{
|
||||||
|
DEFLIBRARY(pic, "(scheme write)")
|
||||||
|
{
|
||||||
|
pic_defun(pic, "write-simple", pic_port_write_simple);
|
||||||
|
}
|
||||||
|
ENDLIBRARY(pic);
|
||||||
|
}
|
||||||
Loading…
Reference in New Issue