hyung-hwan/qse
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

writing qse_scm_eval()

Browse Source
This commit is contained in:
hyung-hwan 2011-03-08 08:34:27 +00:00
parent 2c48b27f9a
commit 52ca1f83e3
10 changed files with 302 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
qse/cmd/scm/scm.c
View File

@ -117,12 +117,12 @@ static int handle_args (int argc, qse_char_t* argv[])
break; break;
case QSE_T('?'): case QSE_T('?'):
qse_fprintf (QSE_STDERR, QSE_T("Error: illegal option - %c\n"), opt.opt); qse_fprintf (QSE_STDERR, QSE_T("ERROR: illegal option - %c\n"), opt.opt);
print_usage (argv[0]); print_usage (argv[0]);
return -1; return -1;
case QSE_T(':'): case QSE_T(':'):
qse_fprintf (QSE_STDERR, QSE_T("Error: missing argument for %c\n"), opt.opt); qse_fprintf (QSE_STDERR, QSE_T("ERROR: missing argument for %c\n"), opt.opt);
print_usage (argv[0]); print_usage (argv[0]);
return -1; return -1;
} }
@ -130,14 +130,14 @@ static int handle_args (int argc, qse_char_t* argv[])
if (opt.ind < argc) if (opt.ind < argc)
{ {
qse_printf (QSE_T("Error: redundant argument - %s\n"), argv[opt.ind]); qse_printf (QSE_T("ERROR: redundant argument - %s\n"), argv[opt.ind]);
print_usage (argv[0]); print_usage (argv[0]);
return -1; return -1;
} }
if (opt_memsize <= 0) if (opt_memsize <= 0)
{ {
qse_printf (QSE_T("Error: invalid memory size given\n")); qse_printf (QSE_T("ERROR: invalid memory size given\n"));
return -1; return -1;
} }
return 0; return 0;
@ -153,7 +153,7 @@ int scm_main (int argc, qse_char_t* argv[])
scm = qse_scm_open (QSE_NULL, 0, opt_memsize, opt_meminc); scm = qse_scm_open (QSE_NULL, 0, opt_memsize, opt_meminc);
if (scm == QSE_NULL) if (scm == QSE_NULL)
{ {
qse_printf (QSE_T("Error: cannot create a scm instance\n")); qse_printf (QSE_T("ERROR: cannot create a scm instance\n"));
return -1; return -1;
} }
@ -164,8 +164,36 @@ int scm_main (int argc, qse_char_t* argv[])
qse_scm_attachio (scm, &io); qse_scm_attachio (scm, &io);
} }
//qse_scm_read (scm); {
qse_scm_print (scm, qse_scm_read (scm)); qse_scm_ent_t* x1, * x2;
x1 = qse_scm_read (scm);
if (x1 == QSE_NULL)
{
qse_printf (QSE_T("ERROR: %s\n"), qse_scm_geterrmsg(scm));
}
else
{
x2 = qse_scm_eval (scm, x1);
if (x2 == QSE_NULL)
{
qse_printf (QSE_T("ERROR: %s ...\n "), qse_scm_geterrmsg(scm));
qse_scm_print (scm, x1);
qse_printf (QSE_T("\n"));
}
else
{
qse_printf (QSE_T("Evaluated...\n "));
qse_scm_print (scm, x1);
qse_printf (QSE_T("\nTo...\n "));
qse_scm_print (scm, x2);
qse_printf (QSE_T("\n"));
}
}
}
#if 0 #if 0
while (1) while (1)

19
qse/include/qse/scm/scm.h
View File

@ -92,6 +92,7 @@ enum qse_scm_errnum_t
{ {
QSE_SCM_ENOERR, QSE_SCM_ENOERR,
QSE_SCM_ENOMEM, QSE_SCM_ENOMEM,
QSE_SCM_EINTERN,
QSE_SCM_EEXIT, QSE_SCM_EEXIT,
QSE_SCM_EEND, QSE_SCM_EEND,
@ -100,11 +101,11 @@ enum qse_scm_errnum_t
QSE_SCM_EENDSTR, QSE_SCM_EENDSTR,
QSE_SCM_ESHARP, QSE_SCM_ESHARP,
QSE_SCM_EDOT, QSE_SCM_EDOT,
QSE_SCM_EINTERN,
QSE_SCM_ELSTDEEP,
QSE_SCM_ELPAREN, QSE_SCM_ELPAREN,
QSE_SCM_ERPAREN, QSE_SCM_ERPAREN,
QSE_SCM_ELSTDEEP,
QSE_SCM_EVARBAD,
QSE_SCM_EARGBAD, QSE_SCM_EARGBAD,
QSE_SCM_EARGFEW, QSE_SCM_EARGFEW,
QSE_SCM_EARGMANY, QSE_SCM_EARGMANY,
@ -251,8 +252,8 @@ qse_scm_ent_t* qse_scm_eval (
* The qse_scm_print() function prints an entity. * The qse_scm_print() function prints an entity.
*/ */
int qse_scm_print ( int qse_scm_print (
qse_scm_t* scm, /**< scheme */ qse_scm_t* scm, /**< scheme */
const qse_scm_ent_t* obj /**< entity */ qse_scm_ent_t* obj /**< entity */
); );
/** /**
@ -297,7 +298,7 @@ qse_scm_ent_t* qse_scm_makesyment (
qse_scm_ent_t* qse_scm_makesyntent ( qse_scm_ent_t* qse_scm_makesyntent (
qse_scm_t* scm, qse_scm_t* scm,
const qse_char_t* name, const qse_char_t* name,
int code void* uptr
); );
qse_scm_ent_t* qse_scm_makeprocent ( qse_scm_ent_t* qse_scm_makeprocent (
@ -306,6 +307,12 @@ qse_scm_ent_t* qse_scm_makeprocent (
int code int code
); );
qse_scm_ent_t* qse_scm_makeclosent (
qse_scm_t* scm,
qse_scm_ent_t* code,
qse_scm_ent_t* env
);
#ifdef __cplusplus #ifdef __cplusplus
} }
#endif #endif

2
qse/lib/scm/Makefile.am
View File

@ -8,6 +8,6 @@ AM_CPPFLAGS = \
lib_LTLIBRARIES = libqsescm.la lib_LTLIBRARIES = libqsescm.la
libqsescm_la_SOURCES = scm.h scm.c mem.c read.c print.c err.c libqsescm_la_SOURCES = scm.h scm.c mem.c read.c eval.c print.c err.c
libqsescm_la_LDFLAGS = -L../cmn -L$(libdir) -version-info 1:0:0 -no-undefined libqsescm_la_LDFLAGS = -L../cmn -L$(libdir) -version-info 1:0:0 -no-undefined
libqsescm_la_LIBADD = -lqsecmn libqsescm_la_LIBADD = -lqsecmn

6
qse/lib/scm/Makefile.in
View File

@ -71,7 +71,8 @@ am__base_list = \
am__installdirs = "$(DESTDIR)$(libdir)" am__installdirs = "$(DESTDIR)$(libdir)"
LTLIBRARIES = $(lib_LTLIBRARIES) LTLIBRARIES = $(lib_LTLIBRARIES)
libqsescm_la_DEPENDENCIES = libqsescm_la_DEPENDENCIES =
am_libqsescm_la_OBJECTS = scm.lo mem.lo read.lo print.lo err.lo am_libqsescm_la_OBJECTS = scm.lo mem.lo read.lo eval.lo print.lo \
err.lo
libqsescm_la_OBJECTS = $(am_libqsescm_la_OBJECTS) libqsescm_la_OBJECTS = $(am_libqsescm_la_OBJECTS)
libqsescm_la_LINK = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) \ libqsescm_la_LINK = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) \
$(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \
@ -238,7 +239,7 @@ AM_CPPFLAGS = \
-I$(includedir) -I$(includedir)
lib_LTLIBRARIES = libqsescm.la lib_LTLIBRARIES = libqsescm.la
libqsescm_la_SOURCES = scm.h scm.c mem.c read.c print.c err.c libqsescm_la_SOURCES = scm.h scm.c mem.c read.c eval.c print.c err.c
libqsescm_la_LDFLAGS = -L../cmn -L$(libdir) -version-info 1:0:0 -no-undefined libqsescm_la_LDFLAGS = -L../cmn -L$(libdir) -version-info 1:0:0 -no-undefined
libqsescm_la_LIBADD = -lqsecmn libqsescm_la_LIBADD = -lqsecmn
all: all-am all: all-am
@ -316,6 +317,7 @@ distclean-compile:
-rm -f *.tab.c -rm -f *.tab.c
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/err.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/err.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/eval.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mem.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/mem.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/print.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/print.Plo@am__quote@
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/read.Plo@am__quote@ @AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/read.Plo@am__quote@

8
qse/lib/scm/err.c
View File

@ -25,7 +25,9 @@ const qse_char_t* qse_scm_dflerrstr (qse_scm_t* scm, qse_scm_errnum_t errnum)
static const qse_char_t* errstr[] = static const qse_char_t* errstr[] =
{ {
QSE_T("no error"), QSE_T("no error"),
QSE_T("out of memory"), QSE_T("out of memory"),
QSE_T("internal error"),
QSE_T("exit"), QSE_T("exit"),
QSE_T("end of source"), QSE_T("end of source"),
@ -34,11 +36,11 @@ const qse_char_t* qse_scm_dflerrstr (qse_scm_t* scm, qse_scm_errnum_t errnum)
QSE_T("unexpected end of string"), QSE_T("unexpected end of string"),
QSE_T("bad sharp expression"), QSE_T("bad sharp expression"),
QSE_T("wrong use of dot"), QSE_T("wrong use of dot"),
QSE_T("internal error"),
QSE_T("list too deep"),
QSE_T("left parenthesis expected"), QSE_T("left parenthesis expected"),
QSE_T("right parenthesis expected"), QSE_T("right parenthesis expected"),
QSE_T("list too deep"),
QSE_T("bad variable"),
QSE_T("bad arguments"), QSE_T("bad arguments"),
QSE_T("too few arguments"), QSE_T("too few arguments"),
QSE_T("too many arguments"), QSE_T("too many arguments"),

195
qse/lib/scm/eval.c
View File

@ -20,70 +20,189 @@
#include "scm.h" #include "scm.h"
static qse_scm_ent_t* apply (qse_scm_t* scm) static int eval_entity (qse_scm_t* scm);
static int save (qse_scm_t* scm, qse_scm_ent_t* )
{ {
if (TYPE(scm->reg.cod) == QSE_SCM_ENT_PROC)
{
/* builtin-procedure */
}
#if 0
else if (TYPE(scm->reg.cod) == QSE_SCM_ENT_CLO)
{
/* closure */
}
else if (TYPE(scm->reg.cod) == QSE_SCM_ENT_CON)
{
/* continuation */
}
#endif
else
{
}
} }
static qse_scm_ent_t* eval_args (qse_scm_t* scm) static int leave (qse_scm_t* scm)
{ {
args = cons (value, args);
if (TYPE(scm->reg.cod))
{
}
else
{
}
} }
static qse_scm_ent_t* eval_entity (qse_scm_t* scm) int qse_scm_dolambda (qse_scm_t* scm)
{ {
qse_scm_ent_t* obj;
if (IS_SMALLINT(scm->reg.cod)) obj = qse_scm_makeclosent (scm, scm->e.cod, scm->e.env);
if (obj == QSE_NULL) return -1;
scm->e.out = obj;
return 0;
}
int qse_scm_doquote (qse_scm_t* scm)
{
/* For the expression (quote 10),
* scm.e.cod is (10).
* PAIR_CAR(scm.e.cod) is 10
*/
scm->e.out = PAIR_CAR(scm->e.cod);
return 0;
}
static int define_finish (qse_scm_t* scm)
{
qse_scm_ent_t* var = scm->e.cod;
//set var in the environemtn....
leave (scm);
return 0;
}
int qse_scm_dodefine (qse_scm_t* scm)
{
qse_scm_ent_t* car, * cdr;
car = PAIR_CAR(scm->e.cod);
cdr = PAIR_CDR(scm->e.cod);
/* TODO: support function defintion - (define (f x y) (+ x y) (* x y))
-> support it by converting it to lambda expression
-> (define f (lambda (x y) (+ x y) (* x y))
*/
if (IS_SMALLINT(scm,cdr) || TYPE(cdr) != QSE_SCM_ENT_PAIR)
{
/* (define x . 10) */
/* TODO: change error code ... */
qse_scm_seterror (scm, QSE_SCM_EARGBAD, QSE_NULL, QSE_NULL);
return -1;
}
if (!IS_NIL(scm,PAIR_CDR(cdr)))
{
/* (define x 10 . 20)
* (define x 10 20) */
qse_scm_seterror (scm, QSE_SCM_EARGMANY, QSE_NULL, QSE_NULL);
return -1;
}
if (IS_SMALLINT(scm,car) || TYPE(car) != QSE_SCM_ENT_SYM)
{
/* check if the variable is a symbol
* (define 20 10)
*/
qse_scm_seterror (scm, QSE_SCM_EVARBAD, QSE_NULL, QSE_NULL);
return -1;
}
save car...
// let it jump to EVAL and come back to DEFINE_FINISH...
scm->e.cod = PAIR_CAR(cdr);
scm->e.op = eval_entity;
return 0;
}
int qse_scm_dobegin (qse_scm_t* scm)
{
/*
(begin
(print "hello")
(print "world")
)
*/
qse_scm_ent_t* car, * cdr;
if (IS_SMALLINT(scm.e.cod) || TYPE(scm.e.cod) != QSE_SCM_ENT_PAIR)
{
/* (begin (+ x y) . 30) */
qse_scm_seterror (scm, QSE_SCM_EARGBAD, QSE_NULL, QSE_NULL);
return -1;
}
car = PAIR_CAR(scm.e.cod);
cdr = PAIR_CDR(scm.e.cod);
if (!IS_NIL(cdr))
{
save (BEGIN... cdr);
}
scm.e.cod = car;
scm.e.op = eval_entity;
return 0;
}
int qse_scm_doif (qse_scm_t* scm)
{
return 0;
}
static int eval_entity (qse_scm_t* scm)
{
if (IS_SMALLINT(scm,scm->e.cod))
{ {
} }
else if (TYPE(scm->reg.cod) == QSE_SCM_ENT_SYM) else if (TYPE(scm->e.cod) == QSE_SCM_ENT_PAIR)
{ {
} qse_scm_ent_t* car, * cdr;
else if (TYPE(scm->reg.cod) == QSE_SCM_ENT_PAIR)
{ /* the first item in the list */
car = PAIR_CAR(scm->reg.cod); car = PAIR_CAR(scm->e.cod);
if (SYNT(car)) if (SYNT(car))
{ {
qse_printf (QSE_T("xxxxx\n"));
/* the first item in the list is a syntax symbol */
cdr = PAIR_CDR(scm->e.cod);
if (IS_SMALLINT(scm,cdr) || TYPE(cdr) != QSE_SCM_ENT_PAIR)
{
/* check if the cdr part ends the list with a dot
* as in (quote . 10) */
qse_scm_seterror (scm, QSE_SCM_EARGBAD, 0, 0);
return -1;
}
/* go on to the syntax function */
scm->e.cod = cdr;
scm->e.op = SYNT_UPTR(car);
} }
else else
{ {
/*
push E1_ARG.... NIL, PAIR_CDR(code) push E1_ARG.... NIL, PAIR_CDR(code)
scm->reg.cod = car; scm->e.cod = car;
goback to eval... goback to eval...
*/
} }
} }
else if (TYPE(scm->e.cod) == QSE_SCM_ENT_SYM)
{
/* resolve the symbol from the environment */
}
else else
{ {
} }
return 0;
} }
qse_scm_ent_t* qse_scm_eval (qse_scm_t* scm, qse_scm_ent_t* obj) qse_scm_ent_t* qse_scm_eval (qse_scm_t* scm, qse_scm_ent_t* obj)
{ {
scm->reg.dmp = scm->nil; scm->e.dmp = scm->nil;
scm->reg.env = scm->gloenv; scm->e.env = scm->gloenv;
scm->reg.cod = obj; scm->e.cod = obj;
return eval_entity (scm); scm->e.in = obj;
scm->e.out = scm->nil;
scm->e.op = eval_entity;
do
{
if (scm->e.op (scm) <= -1) return QSE_NULL;
break;
}
while (scm->e.op);
return scm->e.out;
} }

34
qse/lib/scm/mem.c
View File

@ -199,10 +199,14 @@ static void gc (qse_scm_t* scm, qse_scm_ent_t* x, qse_scm_ent_t* y)
mark (scm, scm->symtab); mark (scm, scm->symtab);
mark (scm, scm->gloenv); mark (scm, scm->gloenv);
mark (scm, scm->reg.arg); mark (scm, scm->r.s);
mark (scm, scm->reg.env); mark (scm, scm->r.e);
mark (scm, scm->reg.cod); mark (scm, scm->p.s);
mark (scm, scm->reg.dmp); mark (scm, scm->p.e);
mark (scm, scm->e.arg);
mark (scm, scm->e.env);
mark (scm, scm->e.cod);
mark (scm, scm->e.dmp);
/* mark the temporaries */ /* mark the temporaries */
if (x) mark (scm, x); if (x) mark (scm, x);
@ -388,7 +392,7 @@ Calling strdup is not an option as it is not managed...
qse_scm_seterror (scm, QSE_SCM_ENOMEM, QSE_NULL, QSE_NULL); qse_scm_seterror (scm, QSE_SCM_ENOMEM, QSE_NULL, QSE_NULL);
return QSE_NULL; return QSE_NULL;
} }
LAB_CODE(v) = 0; LAB_UPTR(v) = QSE_NULL;
return v; return v;
} }
@ -449,17 +453,17 @@ qse_scm_ent_t* qse_scm_makesyment (qse_scm_t* scm, const qse_char_t* name)
} }
qse_scm_ent_t* qse_scm_makesyntent ( qse_scm_ent_t* qse_scm_makesyntent (
qse_scm_t* scm, const qse_char_t* name, int code) qse_scm_t* scm, const qse_char_t* name, void* uptr)
{ {
qse_scm_ent_t* v; qse_scm_ent_t* v;
QSE_ASSERTX (code > 0, "Syntax code must be greater than 0"); QSE_ASSERTX (uptr != QSE_NULL, "Syntax uptr must not be null");
v = qse_scm_makesyment (scm, name); v = qse_scm_makesyment (scm, name);
if (v == QSE_NULL) return QSE_NULL; if (v == QSE_NULL) return QSE_NULL;
SYNT(v) = 1; SYNT(v) = 1;
SYNT_CODE(v) = code; SYNT_UPTR(v) = uptr;
return v; return v;
} }
@ -524,3 +528,17 @@ qse_scm_ent_t* qse_scm_makeprocent (
return proc; return proc;
} }
qse_scm_ent_t* qse_scm_makeclosent (
qse_scm_t* scm, qse_scm_ent_t* code, qse_scm_ent_t* env)
{
qse_scm_ent_t* clos;
clos = alloc_entity (scm, code, env);
if (clos == QSE_NULL) return QSE_NULL;
TYPE(clos) = QSE_SCM_ENT_CLOS;
CLOS_CODE(clos) = code;
CLOS_ENV(clos) = env;
return clos;
}

20
qse/lib/scm/print.c
View File

@ -132,7 +132,7 @@ static QSE_INLINE qse_scm_ent_t* pop (qse_scm_t* scm)
return PAIR_CAR(top); return PAIR_CAR(top);
} }
static QSE_INLINE print_num (qse_scm_t* scm, qse_long_t nval) static QSE_INLINE int print_num (qse_scm_t* scm, qse_long_t nval)
{ {
qse_char_t tmp[QSE_SIZEOF(qse_long_t)*8+2]; qse_char_t tmp[QSE_SIZEOF(qse_long_t)*8+2];
qse_size_t len; qse_size_t len;
@ -258,10 +258,13 @@ next:
break; break;
} }
#if 0
case QSE_SCM_ENT_PROC: case QSE_SCM_ENT_PROC:
OUTPUT_STR (scm, QSE_T("#<PROC>"));
break;
case QSE_SCM_ENT_CLOS:
OUTPUT_STR (scm, QSE_T("#<CLOSURE>"));
break; break;
#endif
default: default:
QSE_ASSERTX ( QSE_ASSERTX (
@ -279,7 +282,7 @@ done:
return 0; return 0;
} }
int qse_scm_print (qse_scm_t* scm, const qse_scm_ent_t* obj) int qse_scm_print (qse_scm_t* scm, qse_scm_ent_t* obj)
{ {
int n; int n;
@ -288,7 +291,14 @@ int qse_scm_print (qse_scm_t* scm, const qse_scm_ent_t* obj)
"Specify output function before calling qse_scm_print()" "Specify output function before calling qse_scm_print()"
); );
n = print_entity (scm, obj); QSE_ASSERTX (
IS_NIL(scm,scm->p.s),
"The printing stack is not empty before printing - buggy!!"
);
scm->p.e = obj; /* remember the head of the entity to print */
n = print_entity (scm, obj); /* call the actual printing routine */
scm->p.e = scm->nil; /* reset what's remembered */
/* clear the printing stack if an error has occurred for GC not to keep /* clear the printing stack if an error has occurred for GC not to keep
* the entities in the stack */ * the entities in the stack */

27
qse/lib/scm/scm.c
View File

@ -128,25 +128,25 @@ int qse_scm_attachio (qse_scm_t* scm, qse_scm_io_t* io)
return 0; return 0;
} }
#define MAKE_SYNTAX_ENTITY(scm,name,code) QSE_BLOCK( \ #define MAKE_SYNTAX_ENTITY(scm,name,uptr) QSE_BLOCK( \
if (qse_scm_makesyntent (scm, name, code) == QSE_NULL) return -1; \ if (qse_scm_makesyntent (scm, name, uptr) == QSE_NULL) return -1; \
) )
static int build_syntax_entities (qse_scm_t* scm) static int build_syntax_entities (qse_scm_t* scm)
{ {
qse_scm_ent_t* v; qse_scm_ent_t* v;
v = qse_scm_makesyntent (scm, QSE_T("lambda"), 1); v = qse_scm_makesyntent (scm, QSE_T("lambda"), qse_scm_dolambda);
if (v == QSE_NULL) return -1; if (v == QSE_NULL) return -1;
scm->lambda = v; scm->lambda = v;
v = qse_scm_makesyntent (scm, QSE_T("quote"), 2); v = qse_scm_makesyntent (scm, QSE_T("quote"), qse_scm_doquote);
if (v == QSE_NULL) return -1; if (v == QSE_NULL) return -1;
scm->quote = v; scm->quote = v;
MAKE_SYNTAX_ENTITY (scm, QSE_T("define"), 3); MAKE_SYNTAX_ENTITY (scm, QSE_T("define"), qse_scm_dodefine);
MAKE_SYNTAX_ENTITY (scm, QSE_T("if"), 4); MAKE_SYNTAX_ENTITY (scm, QSE_T("begin"), qse_scm_dobegin);
MAKE_SYNTAX_ENTITY (scm, QSE_T("begin"), 5); MAKE_SYNTAX_ENTITY (scm, QSE_T("if"), qse_scm_doif);
return 0; return 0;
} }
@ -185,7 +185,6 @@ static qse_scm_t* qse_scm_init (
scm->r.curloc.colm = 0; scm->r.curloc.colm = 0;
if (qse_str_init(&scm->r.t.name, mmgr, 256) == QSE_NULL) return QSE_NULL; if (qse_str_init(&scm->r.t.name, mmgr, 256) == QSE_NULL) return QSE_NULL;
/* initialize common values */ /* initialize common values */
scm->nil = &static_values[0]; scm->nil = &static_values[0];
scm->t = &static_values[1]; scm->t = &static_values[1];
@ -201,24 +200,24 @@ static qse_scm_t* qse_scm_init (
* below. qse_scm_makepairent() calls alloc_entity() that invokes * below. qse_scm_makepairent() calls alloc_entity() that invokes
* gc() as this is the first time. As gc() marks all the key data, * gc() as this is the first time. As gc() marks all the key data,
* we need to initialize these to nil. */ * we need to initialize these to nil. */
scm->reg.arg = scm->nil;
scm->reg.dmp = scm->nil;
scm->reg.cod = scm->nil;
scm->reg.env = scm->nil;
scm->symtab = scm->nil; scm->symtab = scm->nil;
scm->gloenv = scm->nil; scm->gloenv = scm->nil;
scm->r.s = scm->nil; scm->r.s = scm->nil;
scm->r.e = scm->nil; scm->r.e = scm->nil;
scm->p.s = scm->nil; scm->p.s = scm->nil;
scm->p.e = scm->nil; scm->p.e = scm->nil;
scm->e.arg = scm->nil;
scm->e.dmp = scm->nil;
scm->e.cod = scm->nil;
scm->e.env = scm->nil;
/* build the global environment entity as a pair */ /* build the global environment entity as a pair */
scm->gloenv = qse_scm_makepairent (scm, scm->nil, scm->nil); scm->gloenv = qse_scm_makepairent (scm, scm->nil, scm->nil);
if (scm->gloenv == QSE_NULL) goto oops; if (scm->gloenv == QSE_NULL) goto oops;
/* update the current environment to the global environment */ /* update the current environment to the global environment */
scm->reg.env = scm->gloenv; scm->e.env = scm->gloenv;
if (build_syntax_entities (scm) <= -1) goto oops; if (build_syntax_entities (scm) <= -1) goto oops;
return scm; return scm;

57
qse/lib/scm/scm.h
View File

@ -44,17 +44,11 @@ enum qse_scm_ent_type_t
QSE_SCM_ENT_NAM = (1 << 6), QSE_SCM_ENT_NAM = (1 << 6),
QSE_SCM_ENT_SYM = (1 << 7), QSE_SCM_ENT_SYM = (1 << 7),
QSE_SCM_ENT_PAIR = (1 << 8), QSE_SCM_ENT_PAIR = (1 << 8),
QSE_SCM_ENT_PROC = (1 << 9) QSE_SCM_ENT_PROC = (1 << 9),
QSE_SCM_ENT_CLOS = (1 << 10)
}; };
#if 0
#define QSE_SCM_ENT_CLOSURE 64 /* 0000000001000000 */
#define QSE_SCM_ENT_CONTINUATION 128 /* 0000000010000000 */
#define QSE_SCM_ENT_MACRO 256 /* 0000000100000000 */
#define QSE_SCM_ENT_PROMISE 512 /* 0000001000000000 */
#endif
/** /**
* The qse_scm_ent_t type defines an entity that represents an individual * The qse_scm_ent_t type defines an entity that represents an individual
* value in scheme. * value in scheme.
@ -64,7 +58,7 @@ struct qse_scm_ent_t
qse_uint32_t dswcount: 2; qse_uint32_t dswcount: 2;
qse_uint32_t mark: 1; qse_uint32_t mark: 1;
qse_uint32_t atom: 1; qse_uint32_t atom: 1;
qse_uint32_t synt: 1; qse_uint32_t synt: 1; /* can be set to 1 if type is QSE_SCM_ENT_SYM */
qse_uint32_t type: 27; qse_uint32_t type: 27;
union union
@ -90,7 +84,7 @@ struct qse_scm_ent_t
struct struct
{ {
qse_char_t* ptr; /* null-terminated string */ qse_char_t* ptr; /* null-terminated string */
int code; /* used for syntax entities only */ void* uptr; /* used for syntax entities only */
} lab; /* label */ } lab; /* label */
struct struct
@ -116,13 +110,15 @@ struct qse_scm_ent_t
#define STR_PTR(v) ((v)->u.str.ptr) #define STR_PTR(v) ((v)->u.str.ptr)
#define STR_LEN(v) ((v)->u.str.len) #define STR_LEN(v) ((v)->u.str.len)
#define LAB_PTR(v) ((v)->u.lab.ptr) #define LAB_PTR(v) ((v)->u.lab.ptr)
#define LAB_CODE(v) ((v)->u.lab.code) #define LAB_UPTR(v) ((v)->u.lab.uptr)
#define SYM_NAME(v) ((v)->u.ref.ent[0]) #define SYM_NAME(v) ((v)->u.ref.ent[0])
#define SYM_PROP(v) ((v)->u.ref.ent[1]) #define SYM_PROP(v) ((v)->u.ref.ent[1])
#define SYNT_CODE(v) LAB_CODE(SYM_NAME(v)) #define SYNT_UPTR(v) LAB_UPTR(SYM_NAME(v))
#define PAIR_CAR(v) ((v)->u.ref.ent[0]) #define PAIR_CAR(v) ((v)->u.ref.ent[0])
#define PAIR_CDR(v) ((v)->u.ref.ent[1]) #define PAIR_CDR(v) ((v)->u.ref.ent[1])
#define PROC_CODE(v) ((v)->u.proc.code) #define PROC_CODE(v) ((v)->u.proc.code)
#define CLOS_CODE(v) ((v)->u.ref.ent[0])
#define CLOS_ENV(v) ((v)->u.ref.ent[1])
/** /**
* The qse_scm_enb_t type defines a value block. A value block is allocated * The qse_scm_enb_t type defines a value block. A value block is allocated
@ -179,13 +175,28 @@ struct qse_scm_t
qse_scm_ent_t* s; /* stack for reading */ qse_scm_ent_t* s; /* stack for reading */
qse_scm_ent_t* e; /* last entity read */ qse_scm_ent_t* e; /* last entity read */
} r; } r;
/** data for printing */
struct struct
{ {
qse_scm_ent_t* s; /* stack for printing */ qse_scm_ent_t* s; /* stack for printing */
qse_scm_ent_t* e; /* top entity being printed */ qse_scm_ent_t* e; /* top entity being printed */
} p; } p;
/* data for evaluation */
struct
{
int (*op) (qse_scm_t*);
qse_scm_ent_t* in;
qse_scm_ent_t* out;
qse_scm_ent_t* arg; /* function arguments */
qse_scm_ent_t* env; /* current environment */
qse_scm_ent_t* cod; /* current code */
qse_scm_ent_t* dmp; /* stack register for next evaluation */
} e;
/* common values */ /* common values */
qse_scm_ent_t* nil; qse_scm_ent_t* nil;
@ -197,16 +208,6 @@ struct qse_scm_t
qse_scm_ent_t* gloenv; /* global environment */ qse_scm_ent_t* gloenv; /* global environment */
qse_scm_ent_t* symtab; /* symbol table */ qse_scm_ent_t* symtab; /* symbol table */
/* registers */
struct
{
qse_scm_ent_t* arg; /* function arguments */
qse_scm_ent_t* env; /* current environment */
qse_scm_ent_t* cod; /* current code */
qse_scm_ent_t* dmp; /* stack register for next evaluation */
} reg;
/* fields for entity allocation */ /* fields for entity allocation */
struct struct
{ {
@ -226,6 +227,14 @@ struct qse_scm_t
extern "C" { extern "C" {
#endif #endif
/* eval.c */
int qse_scm_dolambda (qse_scm_t* scm);
int qse_scm_doquote (qse_scm_t* scm);
int qse_scm_dodefine (qse_scm_t* scm);
int qse_scm_dobegin (qse_scm_t* scm);
int qse_scm_doif (qse_scm_t* scm);
/* err.c */ /* err.c */
const qse_char_t* qse_scm_dflerrstr (qse_scm_t* scm, qse_scm_errnum_t errnum); const qse_char_t* qse_scm_dflerrstr (qse_scm_t* scm, qse_scm_errnum_t errnum);