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
Download Patch File Download Diff File Expand all files Collapse all files

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

@ -8,6 +8,6 @@ AM_CPPFLAGS = \
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_LIBADD = -lqsecmn

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

@ -71,7 +71,8 @@ am__base_list = \
am__installdirs = "$(DESTDIR)$(libdir)"
LTLIBRARIES = $(lib_LTLIBRARIES)
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_LINK = $(LIBTOOL) --tag=CC $(AM_LIBTOOLFLAGS) \
$(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \
@ -238,7 +239,7 @@ AM_CPPFLAGS = \
-I$(includedir)
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_LIBADD = -lqsecmn
all: all-am
@ -316,6 +317,7 @@ distclean-compile:
-rm -f *.tab.c
@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)/print.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[] =
{
QSE_T("no error"),
QSE_T("out of memory"),
QSE_T("internal error"),
QSE_T("exit"),
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("bad sharp expression"),
QSE_T("wrong use of dot"),
QSE_T("internal error"),
QSE_T("list too deep"),
QSE_T("left parenthesis expected"),
QSE_T("right parenthesis expected"),
QSE_T("list too deep"),
QSE_T("bad variable"),
QSE_T("bad arguments"),
QSE_T("too few arguments"),
QSE_T("too many arguments"),

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

@ -20,70 +20,189 @@
#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)
{
}
else if (TYPE(scm->reg.cod) == QSE_SCM_ENT_PAIR)
{
car = PAIR_CAR(scm->reg.cod);
qse_scm_ent_t* car, * cdr;
/* the first item in the list */
car = PAIR_CAR(scm->e.cod);
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
{
/*
push E1_ARG.... NIL, PAIR_CDR(code)
scm->reg.cod = car;
scm->e.cod = car;
goback to eval...
*/
}
}
else if (TYPE(scm->e.cod) == QSE_SCM_ENT_SYM)
{
/* resolve the symbol from the environment */
}
else
{
}
return 0;
}
qse_scm_ent_t* qse_scm_eval (qse_scm_t* scm, qse_scm_ent_t* obj)
{
scm->reg.dmp = scm->nil;
scm->reg.env = scm->gloenv;
scm->reg.cod = obj;
scm->e.dmp = scm->nil;
scm->e.env = scm->gloenv;
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->gloenv);
mark (scm, scm->reg.arg);
mark (scm, scm->reg.env);
mark (scm, scm->reg.cod);
mark (scm, scm->reg.dmp);
mark (scm, scm->r.s);
mark (scm, scm->r.e);
mark (scm, scm->p.s);
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 */
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);
return QSE_NULL;
}
LAB_CODE(v) = 0;
LAB_UPTR(v) = QSE_NULL;
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_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_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);
if (v == QSE_NULL) return QSE_NULL;
SYNT(v) = 1;
SYNT_CODE(v) = code;
SYNT_UPTR(v) = uptr;
return v;
}
@ -524,3 +528,17 @@ qse_scm_ent_t* qse_scm_makeprocent (
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);
}
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_size_t len;
@ -258,10 +258,13 @@ next:
break;
}
#if 0
case QSE_SCM_ENT_PROC:
OUTPUT_STR (scm, QSE_T("#<PROC>"));
break;
case QSE_SCM_ENT_CLOS:
OUTPUT_STR (scm, QSE_T("#<CLOSURE>"));
break;
#endif
default:
QSE_ASSERTX (
@ -279,7 +282,7 @@ done:
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;
@ -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()"
);
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
* 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;
}
#define MAKE_SYNTAX_ENTITY(scm,name,code) QSE_BLOCK( \
if (qse_scm_makesyntent (scm, name, code) == QSE_NULL) return -1; \
#define MAKE_SYNTAX_ENTITY(scm,name,uptr) QSE_BLOCK( \
if (qse_scm_makesyntent (scm, name, uptr) == QSE_NULL) return -1; \
)
static int build_syntax_entities (qse_scm_t* scm)
{
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;
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;
scm->quote = v;
MAKE_SYNTAX_ENTITY (scm, QSE_T("define"), 3);
MAKE_SYNTAX_ENTITY (scm, QSE_T("if"), 4);
MAKE_SYNTAX_ENTITY (scm, QSE_T("begin"), 5);
MAKE_SYNTAX_ENTITY (scm, QSE_T("define"), qse_scm_dodefine);
MAKE_SYNTAX_ENTITY (scm, QSE_T("begin"), qse_scm_dobegin);
MAKE_SYNTAX_ENTITY (scm, QSE_T("if"), qse_scm_doif);
return 0;
}
@ -185,7 +185,6 @@ static qse_scm_t* qse_scm_init (
scm->r.curloc.colm = 0;
if (qse_str_init(&scm->r.t.name, mmgr, 256) == QSE_NULL) return QSE_NULL;
/* initialize common values */
scm->nil = &static_values[0];
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
* gc() as this is the first time. As gc() marks all the key data,
* 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->gloenv = scm->nil;
scm->r.s = scm->nil;
scm->r.e = scm->nil;
scm->p.s = 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 */
scm->gloenv = qse_scm_makepairent (scm, scm->nil, scm->nil);
if (scm->gloenv == QSE_NULL) goto oops;
/* 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;
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_SYM = (1 << 7),
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
* value in scheme.
@ -64,7 +58,7 @@ struct qse_scm_ent_t
qse_uint32_t dswcount: 2;
qse_uint32_t mark: 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;
union
@ -90,7 +84,7 @@ struct qse_scm_ent_t
struct
{
qse_char_t* ptr; /* null-terminated string */
int code; /* used for syntax entities only */
void* uptr; /* used for syntax entities only */
} lab; /* label */
struct
@ -116,13 +110,15 @@ struct qse_scm_ent_t
#define STR_PTR(v) ((v)->u.str.ptr)
#define STR_LEN(v) ((v)->u.str.len)
#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_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_CDR(v) ((v)->u.ref.ent[1])
#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
@ -179,13 +175,28 @@ struct qse_scm_t
qse_scm_ent_t* s; /* stack for reading */
qse_scm_ent_t* e; /* last entity read */
} r;
} r;
/** data for printing */
struct
{
qse_scm_ent_t* s; /* stack for printing */
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 */
qse_scm_ent_t* nil;
@ -197,16 +208,6 @@ struct qse_scm_t
qse_scm_ent_t* gloenv; /* global environment */
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 */
struct
{
@ -226,6 +227,14 @@ struct qse_scm_t
extern "C" {
#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 */
const qse_char_t* qse_scm_dflerrstr (qse_scm_t* scm, qse_scm_errnum_t errnum);