moved entity management functions to a separate file
This commit is contained in:
parent
31ae7440a5
commit
1d478104b3
@ -164,7 +164,7 @@ 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));
|
||||||
|
|
||||||
#if 0
|
#if 0
|
||||||
while (1)
|
while (1)
|
||||||
|
|||||||
@ -129,6 +129,24 @@ typedef qse_scm_ent_t* (*qse_scm_prim_t) (
|
|||||||
qse_scm_ent_t* obj
|
qse_scm_ent_t* obj
|
||||||
);
|
);
|
||||||
|
|
||||||
|
#define QSE_SCM_ENT_ISNIL(scm,ent) ((ent) == (scm)->nil)
|
||||||
|
|
||||||
|
#define QSE_SCM_ENT_ISSMALLINT(scm,ent) ((qse_uintptr_t)(ent) & 1)
|
||||||
|
|
||||||
|
/* TODO: need more typecasting to something like int? how to i determine
|
||||||
|
* the best type for the range in CAN_BE_SMALLINT()?
|
||||||
|
#define QSE_SCM_ENT_FROMSMALLINT(x) ((int)((qse_uintptr_t)(x) >> 1))
|
||||||
|
*/
|
||||||
|
#define QSE_SCM_ENT_FROMSMALLINT(scm,ent) \
|
||||||
|
((qse_uintptr_t)(ent) >> 1)
|
||||||
|
|
||||||
|
/* TODO: change the smallint range... */
|
||||||
|
#define QSE_SCM_ENT_TOSMALLINT(scm,num) \
|
||||||
|
((qse_scm_ent_t*)(qse_uintptr_t)(((num) << 1) | 1))
|
||||||
|
|
||||||
|
#define QSE_SCM_ENT_CANBESMALLINT(scm,num) \
|
||||||
|
(((num) >= -16384) && ((num) <= 16383))
|
||||||
|
|
||||||
#ifdef __cplusplus
|
#ifdef __cplusplus
|
||||||
extern "C" {
|
extern "C" {
|
||||||
#endif
|
#endif
|
||||||
@ -250,6 +268,51 @@ int qse_scm_removeprim (
|
|||||||
const qse_char_t* name
|
const qse_char_t* name
|
||||||
);
|
);
|
||||||
|
|
||||||
|
|
||||||
|
qse_scm_ent_t* qse_scm_makepairent (
|
||||||
|
qse_scm_t* scm,
|
||||||
|
qse_scm_ent_t* car,
|
||||||
|
qse_scm_ent_t* cdr
|
||||||
|
);
|
||||||
|
|
||||||
|
qse_scm_ent_t* qse_scm_makenument (
|
||||||
|
qse_scm_t* scm,
|
||||||
|
qse_long_t val
|
||||||
|
);
|
||||||
|
|
||||||
|
qse_scm_ent_t* qse_scm_makerealent (
|
||||||
|
qse_scm_t* scm,
|
||||||
|
qse_long_t val
|
||||||
|
);
|
||||||
|
|
||||||
|
qse_scm_ent_t* qse_scm_makestrent (
|
||||||
|
qse_scm_t* scm,
|
||||||
|
const qse_char_t* str,
|
||||||
|
qse_size_t len
|
||||||
|
);
|
||||||
|
|
||||||
|
qse_scm_ent_t* qse_scm_makenamentity (
|
||||||
|
qse_scm_t* scm,
|
||||||
|
const qse_char_t* str
|
||||||
|
);
|
||||||
|
|
||||||
|
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_ent_t* qse_scm_makeprocent (
|
||||||
|
qse_scm_t* scm,
|
||||||
|
const qse_char_t* name,
|
||||||
|
int code
|
||||||
|
);
|
||||||
|
|
||||||
#ifdef __cplusplus
|
#ifdef __cplusplus
|
||||||
}
|
}
|
||||||
#endif
|
#endif
|
||||||
|
|||||||
@ -8,6 +8,6 @@ AM_CPPFLAGS = \
|
|||||||
|
|
||||||
lib_LTLIBRARIES = libqsescm.la
|
lib_LTLIBRARIES = libqsescm.la
|
||||||
|
|
||||||
libqsescm_la_SOURCES = scm.h scm.c print.c err.c
|
libqsescm_la_SOURCES = scm.h scm.c mem.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
|
||||||
|
|||||||
@ -71,7 +71,7 @@ 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 print.lo err.lo
|
am_libqsescm_la_OBJECTS = scm.lo mem.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 +238,7 @@ AM_CPPFLAGS = \
|
|||||||
-I$(includedir)
|
-I$(includedir)
|
||||||
|
|
||||||
lib_LTLIBRARIES = libqsescm.la
|
lib_LTLIBRARIES = libqsescm.la
|
||||||
libqsescm_la_SOURCES = scm.h scm.c print.c err.c
|
libqsescm_la_SOURCES = scm.h scm.c mem.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 +316,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)/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)/scm.Plo@am__quote@
|
@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/scm.Plo@am__quote@
|
||||||
|
|
||||||
|
|||||||
1036
qse/lib/scm/mem.c
1036
qse/lib/scm/mem.c
File diff suppressed because it is too large
Load Diff
@ -1,100 +0,0 @@
|
|||||||
/*
|
|
||||||
* $Id$
|
|
||||||
*
|
|
||||||
Copyright 2006-2009 Chung, Hyung-Hwan.
|
|
||||||
This file is part of QSE.
|
|
||||||
|
|
||||||
QSE is free software: you can redistribute it and/or modify
|
|
||||||
it under the terms of the GNU Lesser General Public License as
|
|
||||||
published by the Free Software Foundation, either version 3 of
|
|
||||||
the License, or (at your option) any later version.
|
|
||||||
|
|
||||||
QSE is distributed in the hope that it will be useful,
|
|
||||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
||||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
||||||
GNU Lesser General Public License for more details.
|
|
||||||
|
|
||||||
You should have received a copy of the GNU Lesser General Public
|
|
||||||
License along with QSE. If not, see <http://www.gnu.org/licenses/>.
|
|
||||||
*/
|
|
||||||
|
|
||||||
#ifndef _QSE_LIB_SCM_MEM_H_
|
|
||||||
#define _QSE_LIB_SCM_MEM_H_
|
|
||||||
|
|
||||||
#ifndef _QSE_SCM_SCM_H_
|
|
||||||
#error Never include this file directly. Include <qse/scm/scm.h> instead
|
|
||||||
#endif
|
|
||||||
|
|
||||||
enum
|
|
||||||
{
|
|
||||||
QSE_SCM_OBJ_NIL = 0,
|
|
||||||
QSE_SCM_OBJ_TRUE,
|
|
||||||
QSE_SCM_OBJ_INT,
|
|
||||||
QSE_SCM_OBJ_REAL,
|
|
||||||
QSE_SCM_OBJ_SYM,
|
|
||||||
QSE_SCM_OBJ_STR,
|
|
||||||
QSE_SCM_OBJ_CONS,
|
|
||||||
QSE_SCM_OBJ_FUNC,
|
|
||||||
QSE_SCM_OBJ_MACRO,
|
|
||||||
QSE_SCM_OBJ_PRIM,
|
|
||||||
|
|
||||||
QSE_SCM_TYPE_COUNT /* the number of lsp object types */
|
|
||||||
};
|
|
||||||
|
|
||||||
|
|
||||||
typedef struct qse_scm_mem_t qse_scm_mem_t;
|
|
||||||
|
|
||||||
struct qse_scm_mem_t
|
|
||||||
{
|
|
||||||
qse_scm_t* scm;
|
|
||||||
|
|
||||||
/* object allocation list */
|
|
||||||
qse_size_t ubound; /* upper bounds of the maximum number of objects */
|
|
||||||
qse_size_t ubound_inc; /* increment of the upper bounds */
|
|
||||||
qse_size_t count; /* the number of objects currently allocated */
|
|
||||||
qse_scm_obj_t* used[QSE_SCM_TYPE_COUNT];
|
|
||||||
qse_scm_obj_t* free[QSE_SCM_TYPE_COUNT];
|
|
||||||
|
|
||||||
struct
|
|
||||||
{
|
|
||||||
qse_scm_obj_t* obj;
|
|
||||||
qse_scm_obj_t* tmp; /* temporary datum to protect from gc in read() */
|
|
||||||
qse_scm_obj_t* stack;
|
|
||||||
} r;
|
|
||||||
|
|
||||||
/* commonly accessed objects */
|
|
||||||
qse_scm_obj_t* nil; /* qse_scm_obj_nil_t */
|
|
||||||
qse_scm_obj_t* t; /* qse_scm_obj_true_t */
|
|
||||||
qse_scm_obj_t* quote; /* qse_scm_obj_sym_t */
|
|
||||||
qse_scm_obj_t* lambda; /* qse_scm_obj_sym_t */
|
|
||||||
qse_scm_obj_t* macro; /* qse_scm_obj_sym_t */
|
|
||||||
qse_scm_obj_t* num[10]; /* qse_scm_obj_int_t */
|
|
||||||
|
|
||||||
#if 0
|
|
||||||
/* run-time environment frame */
|
|
||||||
qse_scm_frame_t* frame;
|
|
||||||
/* pointer to a global-level frame */
|
|
||||||
qse_scm_frame_t* root_frame;
|
|
||||||
/* pointer to an interim frame not yet added to "frame" */
|
|
||||||
qse_scm_frame_t* brooding_frame;
|
|
||||||
|
|
||||||
/* links for temporary objects */
|
|
||||||
qse_scm_tlink_t* tlink;
|
|
||||||
qse_size_t tlink_count;
|
|
||||||
#endif
|
|
||||||
};
|
|
||||||
|
|
||||||
#ifdef __cplusplus
|
|
||||||
extern "C" {
|
|
||||||
#endif
|
|
||||||
|
|
||||||
qse_scm_mem_t* qse_scm_initmem (
|
|
||||||
qse_scm_mem_t* mem, qse_scm_t* scm,
|
|
||||||
qse_size_t ubound, qse_size_t ubound_inc);
|
|
||||||
void qse_scm_finimem (qse_scm_mem_t* mem);
|
|
||||||
|
|
||||||
#ifdef __cplusplus
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#endif
|
|
||||||
@ -36,13 +36,94 @@
|
|||||||
} \
|
} \
|
||||||
)
|
)
|
||||||
|
|
||||||
|
static qse_size_t long_to_str (
|
||||||
|
qse_long_t value, int radix,
|
||||||
|
const qse_char_t* prefix, qse_char_t* buf, qse_size_t size)
|
||||||
|
{
|
||||||
|
qse_long_t t, rem;
|
||||||
|
qse_size_t len, ret, i;
|
||||||
|
qse_size_t prefix_len;
|
||||||
|
|
||||||
|
prefix_len = (prefix != QSE_NULL)? qse_strlen(prefix): 0;
|
||||||
|
|
||||||
|
t = value;
|
||||||
|
if (t == 0)
|
||||||
|
{
|
||||||
|
/* zero */
|
||||||
|
if (buf == QSE_NULL)
|
||||||
|
{
|
||||||
|
/* if buf is not given,
|
||||||
|
* return the number of bytes required */
|
||||||
|
return prefix_len + 1;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (size < prefix_len+1)
|
||||||
|
{
|
||||||
|
/* buffer too small */
|
||||||
|
return (qse_size_t)-1;
|
||||||
|
}
|
||||||
|
|
||||||
|
for (i = 0; i < prefix_len; i++) buf[i] = prefix[i];
|
||||||
|
buf[prefix_len] = QSE_T('0');
|
||||||
|
if (size > prefix_len+1) buf[prefix_len+1] = QSE_T('\0');
|
||||||
|
return prefix_len+1;
|
||||||
|
}
|
||||||
|
|
||||||
|
/* non-zero values */
|
||||||
|
len = prefix_len;
|
||||||
|
if (t < 0) { t = -t; len++; }
|
||||||
|
while (t > 0) { len++; t /= radix; }
|
||||||
|
|
||||||
|
if (buf == QSE_NULL)
|
||||||
|
{
|
||||||
|
/* if buf is not given, return the number of bytes required */
|
||||||
|
return len;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (size < len) return (qse_size_t)-1; /* buffer too small */
|
||||||
|
if (size > len) buf[len] = QSE_T('\0');
|
||||||
|
ret = len;
|
||||||
|
|
||||||
|
t = value;
|
||||||
|
if (t < 0) t = -t;
|
||||||
|
|
||||||
|
while (t > 0)
|
||||||
|
{
|
||||||
|
rem = t % radix;
|
||||||
|
if (rem >= 10)
|
||||||
|
buf[--len] = (qse_char_t)rem + QSE_T('a') - 10;
|
||||||
|
else
|
||||||
|
buf[--len] = (qse_char_t)rem + QSE_T('0');
|
||||||
|
t /= radix;
|
||||||
|
}
|
||||||
|
|
||||||
|
if (value < 0)
|
||||||
|
{
|
||||||
|
for (i = 1; i <= prefix_len; i++)
|
||||||
|
{
|
||||||
|
buf[i] = prefix[i-1];
|
||||||
|
len--;
|
||||||
|
}
|
||||||
|
buf[--len] = QSE_T('-');
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
for (i = 0; i < prefix_len; i++) buf[i] = prefix[i];
|
||||||
|
}
|
||||||
|
|
||||||
|
return ret;
|
||||||
|
}
|
||||||
|
|
||||||
static int print_entity (
|
static int print_entity (
|
||||||
qse_scm_t* scm, const qse_scm_ent_t* obj, int prt_cons_par)
|
qse_scm_t* scm, const qse_scm_ent_t* obj, int prt_cons_par)
|
||||||
{
|
{
|
||||||
qse_char_t buf[256];
|
qse_char_t buf[256];
|
||||||
|
qse_long_t nval;
|
||||||
|
|
||||||
if (IS_SMALLINT(obj))
|
if (IS_SMALLINT(scm,obj))
|
||||||
{
|
{
|
||||||
|
nval = FROM_SMALLINT(scm,obj);
|
||||||
|
goto printnum;
|
||||||
}
|
}
|
||||||
|
|
||||||
switch (TYPE(obj))
|
switch (TYPE(obj))
|
||||||
@ -60,31 +141,17 @@ static int print_entity (
|
|||||||
break;
|
break;
|
||||||
|
|
||||||
case QSE_SCM_ENT_NUM:
|
case QSE_SCM_ENT_NUM:
|
||||||
#if QSE_SIZEOF_LONG_LONG > 0
|
{
|
||||||
scm->prm.sprintf (
|
qse_char_t tmp[QSE_SIZEOF(qse_long_t)*8+2];
|
||||||
scm->prm.udd,
|
qse_size_t len;
|
||||||
buf, QSE_COUNTOF(buf),
|
|
||||||
QSE_T("%lld"), (long long)NUM_VALUE(obj));
|
nval = NUM_VALUE(obj);
|
||||||
#elif QSE_SIZEOF___INT64 > 0
|
|
||||||
scm->prm.sprintf (
|
printnum:
|
||||||
scm->prm.udd,
|
len = long_to_str (nval, 10, QSE_NULL, tmp, QSE_COUNTOF(tmp));
|
||||||
buf, QSE_COUNTOF(buf),
|
OUTPUT_STRX (scm, tmp, len);
|
||||||
QSE_T("%I64d"), (__int64)NUM_VALUE(obj));
|
|
||||||
#elif QSE_SIZEOF_LONG > 0
|
|
||||||
scm->prm.sprintf (
|
|
||||||
scm->prm.udd,
|
|
||||||
buf, QSE_COUNTOF(buf),
|
|
||||||
QSE_T("%ld"), (long)NUM_VALUE(obj));
|
|
||||||
#elif QSE_SIZEOF_INT > 0
|
|
||||||
scm->prm.sprintf (
|
|
||||||
scm->prm.udd,
|
|
||||||
buf, QSE_COUNTOF(buf),
|
|
||||||
QSE_T("%d"), (int)NUM_VALUE(obj));
|
|
||||||
#else
|
|
||||||
#error unsupported size
|
|
||||||
#endif
|
|
||||||
OUTPUT_STR (scm, buf);
|
|
||||||
break;
|
break;
|
||||||
|
}
|
||||||
|
|
||||||
#if 0
|
#if 0
|
||||||
case QSE_SCM_ENT_REAL:
|
case QSE_SCM_ENT_REAL:
|
||||||
@ -122,7 +189,7 @@ static int print_entity (
|
|||||||
{
|
{
|
||||||
qse_scm_print (scm, PAIR_CAR(p));
|
qse_scm_print (scm, PAIR_CAR(p));
|
||||||
p = PAIR_CDR(p);
|
p = PAIR_CDR(p);
|
||||||
if (!IS_NIL(p))
|
if (!IS_NIL(scm,p))
|
||||||
{
|
{
|
||||||
OUTPUT_STR (scm, QSE_T(" "));
|
OUTPUT_STR (scm, QSE_T(" "));
|
||||||
if (TYPE(p) != QSE_SCM_ENT_PAIR)
|
if (TYPE(p) != QSE_SCM_ENT_PAIR)
|
||||||
|
|||||||
@ -22,18 +22,6 @@
|
|||||||
|
|
||||||
QSE_IMPLEMENT_COMMON_FUNCTIONS (scm)
|
QSE_IMPLEMENT_COMMON_FUNCTIONS (scm)
|
||||||
|
|
||||||
#define IS_NIL(x) ((x) == scm->nil)
|
|
||||||
|
|
||||||
#define IS_SMALLINT(x) ((qse_uintptr_t)(x) & 1)
|
|
||||||
#define TO_SMALLINT(x) ((qse_scm_ent_t*)(qse_uintptr_t)(((x) << 1) | 1))
|
|
||||||
/* TODO: need more typecasting to something like int? how to i determine
|
|
||||||
* the best type for the range in CAN_BE_SMALLINT()?
|
|
||||||
#define FROM_SMALLINT(x) ((int)((qse_uintptr_t)(x) >> 1))
|
|
||||||
*/
|
|
||||||
#define FROM_SMALLINT(x) ((qse_uintptr_t)(x) >> 1)
|
|
||||||
/* TODO: change the smallint range... */
|
|
||||||
#define CAN_BE_SMALLINT(x) (((x) >= -16384) && ((x) <= 16383))
|
|
||||||
|
|
||||||
static qse_scm_t* qse_scm_init (
|
static qse_scm_t* qse_scm_init (
|
||||||
qse_scm_t* scm,
|
qse_scm_t* scm,
|
||||||
qse_mmgr_t* mmgr,
|
qse_mmgr_t* mmgr,
|
||||||
@ -45,12 +33,6 @@ static void qse_scm_fini (
|
|||||||
qse_scm_t* scm
|
qse_scm_t* scm
|
||||||
);
|
);
|
||||||
|
|
||||||
static qse_scm_ent_t* make_pair_entity (
|
|
||||||
qse_scm_t* scm,
|
|
||||||
qse_scm_ent_t* car,
|
|
||||||
qse_scm_ent_t* cdr
|
|
||||||
);
|
|
||||||
|
|
||||||
qse_scm_t* qse_scm_open (
|
qse_scm_t* qse_scm_open (
|
||||||
qse_mmgr_t* mmgr, qse_size_t xtnsize,
|
qse_mmgr_t* mmgr, qse_size_t xtnsize,
|
||||||
qse_size_t mem_ubound, qse_size_t mem_ubound_inc)
|
qse_size_t mem_ubound, qse_size_t mem_ubound_inc)
|
||||||
@ -146,530 +128,19 @@ int qse_scm_attachio (qse_scm_t* scm, qse_scm_io_t* io)
|
|||||||
return 0;
|
return 0;
|
||||||
}
|
}
|
||||||
|
|
||||||
static qse_scm_enb_t* new_entity_block (qse_scm_t* scm, qse_size_t len)
|
|
||||||
{
|
|
||||||
/*
|
|
||||||
* Create a new value block containing as 'len' slots.
|
|
||||||
*/
|
|
||||||
|
|
||||||
void* raw;
|
|
||||||
qse_scm_enb_t* blk;
|
|
||||||
qse_scm_ent_t* v;
|
|
||||||
qse_size_t i;
|
|
||||||
|
|
||||||
/* Let me assume that an aligned memory pointer is an even address.
|
|
||||||
* malloc() returns an aligned memory pointer on most systems.
|
|
||||||
* However, I can't simply ignore oddball systems that returns
|
|
||||||
* an unaligned memory pointer. (Is there any?) A user may provide
|
|
||||||
* a custom memory allocator that does not return unaligned memory
|
|
||||||
* pointer. I make the pointer to an entity block 2-byte aligned
|
|
||||||
* hoping that the entity pointer alloc_entity() returns is also an
|
|
||||||
* even number. This, of couurse, requires that the size of
|
|
||||||
* qse_scm_enb_t and qse_scm_ent_t is the multiple of 2.
|
|
||||||
* I do this for SMALLINT, not for memory alignemnt.The test for
|
|
||||||
* SMALLINT can simply check the lowest bit. Am i doing too much?
|
|
||||||
*/
|
|
||||||
QSE_ASSERTX (
|
|
||||||
QSE_SIZEOF(qse_scm_enb_t) % 2 == 0,
|
|
||||||
"This function is written assuming the size of qse_scm_enb_t is even"
|
|
||||||
);
|
|
||||||
QSE_ASSERTX (
|
|
||||||
QSE_SIZEOF(qse_scm_ent_t) % 2 == 0,
|
|
||||||
"This function is written assuming the size of qse_scm_ent_t is even"
|
|
||||||
);
|
|
||||||
|
|
||||||
/* The actual memory block size is calculated as shown here:
|
|
||||||
* QSE_SIZEOF(void*) to store the actual memory block pointer
|
|
||||||
* 1 to secure extra 1 byte required for 2-byte alignement.
|
|
||||||
* QSE_SIZEOF(qse_scm_enb_t) to store the block header.
|
|
||||||
* QSE_SIZEOF(qse_Scm_ent_t) * len to store the actual entities.
|
|
||||||
*/
|
|
||||||
raw = (qse_scm_enb_t*) QSE_MMGR_ALLOC (
|
|
||||||
scm->mmgr,
|
|
||||||
QSE_SIZEOF(void*) + 1 +
|
|
||||||
QSE_SIZEOF(qse_scm_enb_t) +
|
|
||||||
QSE_SIZEOF(qse_scm_ent_t) * len
|
|
||||||
);
|
|
||||||
if (raw == QSE_NULL)
|
|
||||||
{
|
|
||||||
qse_scm_seterror (scm, QSE_SCM_ENOMEM, QSE_NULL, QSE_NULL);
|
|
||||||
return QSE_NULL;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* The entity block begins after the memory block pointer. */
|
|
||||||
blk = (qse_scm_enb_t*)((qse_byte_t*)raw + QSE_SIZEOF(void*) + 1);
|
|
||||||
|
|
||||||
/* Adjust the block pointer to an even number.
|
|
||||||
* the resulting address is:
|
|
||||||
* either the old address
|
|
||||||
* or the old address - 1
|
|
||||||
*/
|
|
||||||
blk = (qse_scm_enb_t*)((qse_uintptr_t)blk & ~(qse_uintptr_t)1);
|
|
||||||
|
|
||||||
/* Remember the raw block pointer.
|
|
||||||
* ((void**)blk)[-1] gets naturally aligned as blk is aligned.
|
|
||||||
* It can be raw + 1 or the same as raw. */
|
|
||||||
((void**)blk)[-1] = raw;
|
|
||||||
|
|
||||||
/* Initialize the block fields */
|
|
||||||
blk->ptr = (qse_scm_ent_t*)(blk + 1);
|
|
||||||
blk->len = len;
|
|
||||||
|
|
||||||
/* Chain the value block to the block list */
|
|
||||||
blk->next = scm->mem.ebl;
|
|
||||||
scm->mem.ebl = blk;
|
|
||||||
|
|
||||||
/* Chain each slot to the free slot list using
|
|
||||||
* the CDR field of an entity */
|
|
||||||
v = &blk->ptr[0];
|
|
||||||
for (i = 0; i < len -1; i++)
|
|
||||||
{
|
|
||||||
qse_scm_ent_t* tmp = v++;
|
|
||||||
PAIR_CDR(tmp) = v;
|
|
||||||
}
|
|
||||||
PAIR_CDR(v) = scm->mem.free;
|
|
||||||
scm->mem.free = &blk->ptr[0];
|
|
||||||
|
|
||||||
return blk;
|
|
||||||
};
|
|
||||||
|
|
||||||
static void mark (qse_scm_t* scm, qse_scm_ent_t* v)
|
|
||||||
{
|
|
||||||
/*
|
|
||||||
* Mark values non-recursively with Deutsch-Schorr-Waite(DSW) algorithm.
|
|
||||||
* This algorithm builds backtraces directly into the value chain
|
|
||||||
* with the help of additional variables.
|
|
||||||
*/
|
|
||||||
|
|
||||||
qse_scm_ent_t* parent, * me;
|
|
||||||
|
|
||||||
if (IS_SMALLINT(v)) return;
|
|
||||||
|
|
||||||
/* Initialization */
|
|
||||||
parent = QSE_NULL;
|
|
||||||
me = v;
|
|
||||||
|
|
||||||
MARK(me) = 1;
|
|
||||||
/*if (!ATOM(me))*/ DSWCOUNT(me) = 0;
|
|
||||||
|
|
||||||
while (1)
|
|
||||||
{
|
|
||||||
if (ATOM(me) || DSWCOUNT(me) >= QSE_COUNTOF(me->u.ref.ent))
|
|
||||||
{
|
|
||||||
/*
|
|
||||||
* Backtrack to the parent node
|
|
||||||
*/
|
|
||||||
qse_scm_ent_t* child;
|
|
||||||
|
|
||||||
/* Nothing more to backtrack? end of marking */
|
|
||||||
if (parent == QSE_NULL) return;
|
|
||||||
|
|
||||||
/* Remember me temporarily for restoration below */
|
|
||||||
child = me;
|
|
||||||
|
|
||||||
/* The current parent becomes me */
|
|
||||||
me = parent;
|
|
||||||
|
|
||||||
/* Change the parent to the parent of parent */
|
|
||||||
parent = me->u.ref.ent[DSWCOUNT(me)];
|
|
||||||
|
|
||||||
/* Restore the cell contents */
|
|
||||||
me->u.ref.ent[DSWCOUNT(me)] = child;
|
|
||||||
|
|
||||||
/* Increment the counter to indicate that the
|
|
||||||
* 'count'th field has been processed. */
|
|
||||||
DSWCOUNT(me)++;
|
|
||||||
}
|
|
||||||
else
|
|
||||||
{
|
|
||||||
/*
|
|
||||||
* Move on to an unprocessed child
|
|
||||||
*/
|
|
||||||
qse_scm_ent_t* child;
|
|
||||||
|
|
||||||
child = me->u.ref.ent[DSWCOUNT(me)];
|
|
||||||
|
|
||||||
/* Process the field */
|
|
||||||
QSE_ASSERT (child != QSE_NULL);
|
|
||||||
|
|
||||||
if (IS_SMALLINT(child) || MARK(child))
|
|
||||||
{
|
|
||||||
/* Already marked. Increment the count */
|
|
||||||
DSWCOUNT(me)++;
|
|
||||||
}
|
|
||||||
else
|
|
||||||
{
|
|
||||||
/* Change the contents of the child chosen
|
|
||||||
* to point to the current parent */
|
|
||||||
me->u.ref.ent[DSWCOUNT(me)] = parent;
|
|
||||||
|
|
||||||
/* Link me to the head of parent list */
|
|
||||||
parent = me;
|
|
||||||
|
|
||||||
/* Let me point to the child chosen */
|
|
||||||
me = child;
|
|
||||||
|
|
||||||
MARK(me) = 1;
|
|
||||||
/*if (!ATOM(me))*/ DSWCOUNT(me) = 0;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
static void gc (qse_scm_t* scm, qse_scm_ent_t* x, qse_scm_ent_t* y)
|
|
||||||
{
|
|
||||||
/* TODO: How can i GC away those symbols not actually meaningful?
|
|
||||||
* marking objects referenced in symbol table prevent me from
|
|
||||||
* finding unused symbols... you keep on evaluating expressions
|
|
||||||
* with different symbols. you'll get out of memory. */
|
|
||||||
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 the temporaries */
|
|
||||||
if (x) mark (scm, x);
|
|
||||||
if (y) mark (scm, y);
|
|
||||||
|
|
||||||
|
|
||||||
/* scan the allocated values */
|
|
||||||
}
|
|
||||||
|
|
||||||
/*
|
|
||||||
|
|
||||||
rsr4
|
|
||||||
|
|
||||||
the following identifiers are syntactic keywors and should not be
|
|
||||||
used as variables.
|
|
||||||
|
|
||||||
=> do or
|
|
||||||
and else quasiquote
|
|
||||||
begin if quote
|
|
||||||
case lambda set!
|
|
||||||
cond let unquote
|
|
||||||
define let* unquote-splicing
|
|
||||||
delay letrec
|
|
||||||
|
|
||||||
however, you can allow for these keywords to be used as variables...
|
|
||||||
|
|
||||||
biniding, unbound...
|
|
||||||
environment.. a set of visible bindings at some point in a program.
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
type atom cons
|
|
||||||
number NUMBER Y
|
|
||||||
string STRING Y
|
|
||||||
symbol SYMBOL name,NIL
|
|
||||||
syntax SYNTAX|SYMBOL name,NIL
|
|
||||||
proc PROC Y
|
|
||||||
pair PAIR Y
|
|
||||||
closure
|
|
||||||
continuation
|
|
||||||
|
|
||||||
an atom does not reference any other values.
|
|
||||||
a symbol can be assoicated with property list
|
|
||||||
(put 'a 'name "brian")
|
|
||||||
(put 'a 'city "daegu")
|
|
||||||
-------------------------
|
|
||||||
(define a1 'a)
|
|
||||||
(put a1 'name "brian")
|
|
||||||
(put a1 'city "daegu")
|
|
||||||
-------------------------
|
|
||||||
(get a1 'name)
|
|
||||||
(get a1 'city)
|
|
||||||
|
|
||||||
a procedure is a privimitive routine built-in to scheme.
|
|
||||||
a closure is an anonymous routine defined with lambda.
|
|
||||||
both can be bound to a variable in the environment.
|
|
||||||
|
|
||||||
a syntax is more primitive than a procedure.
|
|
||||||
a syntax is created as if it is a symbol but not registerd
|
|
||||||
into an environment
|
|
||||||
|
|
||||||
car cdr
|
|
||||||
| STR | PTR CHR ARR | -1 |
|
|
||||||
| PROC | PROCNUM | |
|
|
||||||
| SYM | REF STR | REF PROP LIST |
|
|
||||||
| SYN | REF STR | REF PROP LIST |
|
|
||||||
|
|
||||||
*/
|
|
||||||
|
|
||||||
static qse_scm_ent_t* alloc_entity (
|
|
||||||
qse_scm_t* scm, qse_scm_ent_t* x, qse_scm_ent_t* y)
|
|
||||||
{
|
|
||||||
/* find a free value slot and return it.
|
|
||||||
* two parameters x and y are saved from garbage collection */
|
|
||||||
|
|
||||||
qse_scm_ent_t* v;
|
|
||||||
|
|
||||||
if (IS_NIL(scm->mem.free))
|
|
||||||
{
|
|
||||||
/* if no free slot is available */
|
|
||||||
gc (scm, x, y); /* perform garbage collection */
|
|
||||||
if (IS_NIL(scm->mem.free))
|
|
||||||
{
|
|
||||||
/* if no free slot is available after garbage collection,
|
|
||||||
* make new value blocks containing more free slots */
|
|
||||||
|
|
||||||
/* TODO: make the value block size configurable */
|
|
||||||
if (new_entity_block (scm, 1000) == QSE_NULL) return QSE_NULL;
|
|
||||||
QSE_ASSERT (scm->mem.free != scm->nil);
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
v = scm->mem.free;
|
|
||||||
scm->mem.free = PAIR_CDR(v);
|
|
||||||
|
|
||||||
return v;
|
|
||||||
}
|
|
||||||
|
|
||||||
static qse_scm_ent_t* make_pair_entity (
|
|
||||||
qse_scm_t* scm, qse_scm_ent_t* car, qse_scm_ent_t* cdr)
|
|
||||||
{
|
|
||||||
qse_scm_ent_t* v;
|
|
||||||
|
|
||||||
v = alloc_entity (scm, car, cdr);
|
|
||||||
if (v == QSE_NULL) return QSE_NULL;
|
|
||||||
|
|
||||||
TYPE(v) = QSE_SCM_ENT_PAIR;
|
|
||||||
ATOM(v) = 0; /* a pair is not an atom as it references other entities */
|
|
||||||
PAIR_CAR(v) = car;
|
|
||||||
PAIR_CDR(v) = cdr;
|
|
||||||
|
|
||||||
return v;
|
|
||||||
}
|
|
||||||
|
|
||||||
static qse_scm_ent_t* make_number_entity (qse_scm_t* scm, qse_long_t val)
|
|
||||||
{
|
|
||||||
qse_scm_ent_t* v;
|
|
||||||
|
|
||||||
if (CAN_BE_SMALLINT(val)) return TO_SMALLINT(val);
|
|
||||||
|
|
||||||
v = alloc_entity (scm, QSE_NULL, QSE_NULL);
|
|
||||||
if (v == QSE_NULL) return QSE_NULL;
|
|
||||||
|
|
||||||
TYPE(v) = QSE_SCM_ENT_NUM;
|
|
||||||
ATOM(v) = 1;
|
|
||||||
NUM_VALUE(v) = val;
|
|
||||||
|
|
||||||
return v;
|
|
||||||
}
|
|
||||||
|
|
||||||
static qse_scm_ent_t* make_real_entity (qse_scm_t* scm, qse_long_t val)
|
|
||||||
{
|
|
||||||
qse_scm_ent_t* v;
|
|
||||||
|
|
||||||
v = alloc_entity (scm, QSE_NULL, QSE_NULL);
|
|
||||||
if (v == QSE_NULL) return QSE_NULL;
|
|
||||||
|
|
||||||
TYPE(v) = QSE_SCM_ENT_REAL;
|
|
||||||
ATOM(v) = 1;
|
|
||||||
REAL_VALUE(v) = val;
|
|
||||||
|
|
||||||
return v;
|
|
||||||
}
|
|
||||||
|
|
||||||
static qse_scm_ent_t* make_string_entity (
|
|
||||||
qse_scm_t* scm, const qse_char_t* str, qse_size_t len)
|
|
||||||
{
|
|
||||||
qse_scm_ent_t* v;
|
|
||||||
|
|
||||||
v = alloc_entity (scm, QSE_NULL, QSE_NULL);
|
|
||||||
if (v == QSE_NULL) return QSE_NULL;
|
|
||||||
|
|
||||||
TYPE(v) = QSE_SCM_ENT_STR;
|
|
||||||
ATOM(v) = 1;
|
|
||||||
/* TODO: allocate a string from internal managed region .
|
|
||||||
Calling strdup is not an option as it is not managed...
|
|
||||||
*/
|
|
||||||
STR_PTR(v) = qse_strxdup (str, len, QSE_MMGR(scm));
|
|
||||||
if (STR_PTR(v) == QSE_NULL)
|
|
||||||
{
|
|
||||||
qse_scm_seterror (scm, QSE_SCM_ENOMEM, QSE_NULL, QSE_NULL);
|
|
||||||
return QSE_NULL;
|
|
||||||
}
|
|
||||||
STR_LEN(v) = len;
|
|
||||||
|
|
||||||
return v;
|
|
||||||
}
|
|
||||||
|
|
||||||
static qse_scm_ent_t* make_name_entity (qse_scm_t* scm, const qse_char_t* str)
|
|
||||||
{
|
|
||||||
qse_scm_ent_t* v;
|
|
||||||
|
|
||||||
v = alloc_entity (scm, QSE_NULL, QSE_NULL);
|
|
||||||
if (v == QSE_NULL) return QSE_NULL;
|
|
||||||
|
|
||||||
TYPE(v) = QSE_SCM_ENT_NAM;
|
|
||||||
ATOM(v) = 1;
|
|
||||||
/* TODO: allocate a string from internal managed region .
|
|
||||||
Calling strdup is not an option as it is not managed...
|
|
||||||
*/
|
|
||||||
LAB_PTR(v) = qse_strdup (str, QSE_MMGR(scm));
|
|
||||||
if (LAB_PTR(v) == QSE_NULL)
|
|
||||||
{
|
|
||||||
qse_scm_seterror (scm, QSE_SCM_ENOMEM, QSE_NULL, QSE_NULL);
|
|
||||||
return QSE_NULL;
|
|
||||||
}
|
|
||||||
LAB_CODE(v) = 0;
|
|
||||||
|
|
||||||
return v;
|
|
||||||
}
|
|
||||||
|
|
||||||
static qse_scm_ent_t* make_symbol_entity (qse_scm_t* scm, const qse_char_t* name)
|
|
||||||
{
|
|
||||||
qse_scm_ent_t* pair, * sym, * nam;
|
|
||||||
|
|
||||||
/* TODO: use a hash table, red-black tree to maintain symbol table
|
|
||||||
* The current linear search algo is not performance friendly...
|
|
||||||
*/
|
|
||||||
|
|
||||||
/* find if the symbol already exists by traversing the pair list
|
|
||||||
* and inspecting the symbol name pointed to by CAR of each pair.
|
|
||||||
*
|
|
||||||
* the symbol table is a list of pairs whose CAR points to a symbol
|
|
||||||
* and CDR is used for chaining.
|
|
||||||
*
|
|
||||||
* +-----+-----+
|
|
||||||
* | | |
|
|
||||||
* +-----+-----+
|
|
||||||
* car | | cdr +-----+-----+
|
|
||||||
* | +----------> | | |
|
|
||||||
* V +-----+-----+
|
|
||||||
* +--------+ car |
|
|
||||||
* | symbol | V
|
|
||||||
* +--------+ +--------+
|
|
||||||
* | symbol |
|
|
||||||
* +--------+
|
|
||||||
*/
|
|
||||||
for (pair = scm->symtab; !IS_NIL(pair); pair = PAIR_CDR(pair))
|
|
||||||
{
|
|
||||||
sym = PAIR_CAR(pair);
|
|
||||||
if (qse_strcmp(name, LAB_PTR(SYM_NAME(sym))) == 0) return sym;
|
|
||||||
}
|
|
||||||
|
|
||||||
/* no existing symbol with such a name is found.
|
|
||||||
* let's create a new symbol. the first step is to create a
|
|
||||||
* string entity to contain the symbol name */
|
|
||||||
nam = make_name_entity (scm, name);
|
|
||||||
if (nam == QSE_NULL) return QSE_NULL;
|
|
||||||
|
|
||||||
/* let's allocate the actual symbol entity that references the
|
|
||||||
* the symbol name entity created above */
|
|
||||||
sym = alloc_entity (scm, nam, QSE_NULL);
|
|
||||||
if (sym == QSE_NULL) return QSE_NULL;
|
|
||||||
TYPE(sym) = QSE_SCM_ENT_SYM;
|
|
||||||
ATOM(sym) = 0;
|
|
||||||
SYM_NAME(sym) = nam;
|
|
||||||
SYM_PROP(sym) = scm->nil; /* no properties yet */
|
|
||||||
|
|
||||||
/* chain the symbol entity to the symbol table for lookups later */
|
|
||||||
pair = make_pair_entity (scm, sym, scm->symtab);
|
|
||||||
if (pair == QSE_NULL) return QSE_NULL;
|
|
||||||
scm->symtab = pair;
|
|
||||||
|
|
||||||
return sym;
|
|
||||||
}
|
|
||||||
|
|
||||||
static qse_scm_ent_t* make_syntax_entity (
|
|
||||||
qse_scm_t* scm, const qse_char_t* name, int code)
|
|
||||||
{
|
|
||||||
qse_scm_ent_t* v;
|
|
||||||
|
|
||||||
QSE_ASSERTX (code > 0, "Syntax code must be greater than 0");
|
|
||||||
|
|
||||||
v = make_symbol_entity (scm, name);
|
|
||||||
if (v == QSE_NULL) return QSE_NULL;
|
|
||||||
|
|
||||||
/* We piggy-back the syntax code to a symbol name.
|
|
||||||
* The syntax entity is basically a symbol except that the
|
|
||||||
* code field of its label entity is set to non-zero.
|
|
||||||
* Read the comment in make_procedure_entity() for difference between
|
|
||||||
* the syntax entity and the procedure entity.
|
|
||||||
*/
|
|
||||||
TYPE(v) |= QSE_SCM_ENT_SYNT;
|
|
||||||
SYNT_CODE(v) = code;
|
|
||||||
|
|
||||||
return v;
|
|
||||||
}
|
|
||||||
|
|
||||||
static qse_scm_ent_t* make_procedure_entity (
|
|
||||||
qse_scm_t* scm, const qse_char_t* name, int code)
|
|
||||||
{
|
|
||||||
qse_scm_ent_t* sym, * proc, * pair;
|
|
||||||
|
|
||||||
/* A procedure entity is a built-in function that can be
|
|
||||||
* overridden by a user while a syntax entity represents a
|
|
||||||
* lower-level syntactic function that can't be overridden.
|
|
||||||
*
|
|
||||||
* (define lambda 10) is legal but does not change the
|
|
||||||
* meaning of lambda when used as a function name.
|
|
||||||
*
|
|
||||||
* (define tail 10) changes the meaning of eval totally.
|
|
||||||
* (tail '(1 2 3)) is not legal from now on.
|
|
||||||
*
|
|
||||||
* (define x lambda) is illegal as the lambda symbol
|
|
||||||
*
|
|
||||||
* (define lambda 10) followed by (define x lambda) lets the x symbol
|
|
||||||
* to be associated with 10 but you still can use lambda to create
|
|
||||||
* a closure as in ((lambda (x) (+ x 10)) 50)
|
|
||||||
*
|
|
||||||
* (define x tail) lets the 'x' symbol point to the eval procedure.
|
|
||||||
* (x '(1 2 3)) returns (2 3).
|
|
||||||
*
|
|
||||||
* We implement the syntax entity as a symbol itself by ORing
|
|
||||||
* the TYPE field with QSE_SCM_ENT_SYNT and setting the syntax
|
|
||||||
* code in the symbol label entity.
|
|
||||||
*
|
|
||||||
* A procedure entity is an independent entity unlike the syntax
|
|
||||||
* entity. We explicitly create a symbol entity for the procedure name
|
|
||||||
* and associate it with the procedure entity in the global environment.
|
|
||||||
* If you redefine the symbol name to be something else, you won't be
|
|
||||||
* able to reference the procedure entity with the name. Worst case,
|
|
||||||
* it may be GCed out.
|
|
||||||
*/
|
|
||||||
|
|
||||||
/* create a symbol containing the name */
|
|
||||||
sym = make_symbol_entity (scm, name);
|
|
||||||
if (sym == QSE_NULL) return QSE_NULL;
|
|
||||||
|
|
||||||
/* create an actual procedure value which is a number containing
|
|
||||||
* the opcode for the procedure */
|
|
||||||
proc = alloc_entity (scm, sym, QSE_NULL);
|
|
||||||
if (proc == QSE_NULL) return QSE_NULL;
|
|
||||||
TYPE(proc) = QSE_SCM_ENT_PROC;
|
|
||||||
ATOM(proc) = 1;
|
|
||||||
PROC_CODE(proc) = code;
|
|
||||||
|
|
||||||
/* create a pair containing the name symbol and the procedure value */
|
|
||||||
pair = make_pair_entity (scm, sym, proc);
|
|
||||||
if (pair == QSE_NULL) return QSE_NULL;
|
|
||||||
|
|
||||||
/* link it to the global environment */
|
|
||||||
pair = make_pair_entity (scm, pair, PAIR_CAR(scm->gloenv));
|
|
||||||
if (pair == QSE_NULL) return QSE_NULL;
|
|
||||||
PAIR_CAR(scm->gloenv) = pair;
|
|
||||||
|
|
||||||
return proc;
|
|
||||||
}
|
|
||||||
|
|
||||||
#define MAKE_SYNTAX_ENTITY(scm,name,code) QSE_BLOCK( \
|
#define MAKE_SYNTAX_ENTITY(scm,name,code) QSE_BLOCK( \
|
||||||
if (make_syntax_entity (scm, name, code) == QSE_NULL) return -1; \
|
if (qse_scm_makesyntent (scm, name, code) == 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 = make_syntax_entity (scm, QSE_T("lambda"), 1);
|
v = qse_scm_makesyntent (scm, QSE_T("lambda"), 1);
|
||||||
if (v == QSE_NULL) return -1;
|
if (v == QSE_NULL) return -1;
|
||||||
scm->lambda = v;
|
scm->lambda = v;
|
||||||
|
|
||||||
v = make_syntax_entity (scm, QSE_T("quote"), 2);
|
v = qse_scm_makesyntent (scm, QSE_T("quote"), 2);
|
||||||
if (v == QSE_NULL) return -1;
|
if (v == QSE_NULL) return -1;
|
||||||
scm->quote = v;
|
scm->quote = v;
|
||||||
|
|
||||||
@ -726,8 +197,8 @@ static qse_scm_t* qse_scm_init (
|
|||||||
scm->mem.ebl = QSE_NULL;
|
scm->mem.ebl = QSE_NULL;
|
||||||
scm->mem.free = scm->nil;
|
scm->mem.free = scm->nil;
|
||||||
|
|
||||||
/* initialize all the key data to nil before make_pair_entity()
|
/* initialize all the key data to nil before qse_scm_makepairent()
|
||||||
* below. make_pair_entity() 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.arg = scm->nil;
|
||||||
@ -741,7 +212,7 @@ static qse_scm_t* qse_scm_init (
|
|||||||
scm->r.e = scm->nil;
|
scm->r.e = scm->nil;
|
||||||
|
|
||||||
/* build the global environment entity as a pair */
|
/* build the global environment entity as a pair */
|
||||||
scm->gloenv = make_pair_entity (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 */
|
||||||
@ -1259,7 +730,7 @@ static QSE_INLINE qse_scm_ent_t* push (qse_scm_t* scm, qse_scm_ent_t* obj)
|
|||||||
{
|
{
|
||||||
qse_scm_ent_t* pair;
|
qse_scm_ent_t* pair;
|
||||||
|
|
||||||
pair = make_pair_entity (scm, obj, scm->r.s);
|
pair = qse_scm_makepairent (scm, obj, scm->r.s);
|
||||||
if (pair == QSE_NULL) return QSE_NULL;
|
if (pair == QSE_NULL) return QSE_NULL;
|
||||||
|
|
||||||
scm->r.s = pair;
|
scm->r.s = pair;
|
||||||
@ -1271,7 +742,7 @@ static QSE_INLINE qse_scm_ent_t* push (qse_scm_t* scm, qse_scm_ent_t* obj)
|
|||||||
static QSE_INLINE_ALWAYS void pop (qse_scm_t* scm)
|
static QSE_INLINE_ALWAYS void pop (qse_scm_t* scm)
|
||||||
{
|
{
|
||||||
QSE_ASSERTX (
|
QSE_ASSERTX (
|
||||||
!IS_NIL(scm->r.s),
|
!IS_NIL(scm,scm->r.s),
|
||||||
"You've called pop() more times than push()"
|
"You've called pop() more times than push()"
|
||||||
);
|
);
|
||||||
scm->r.s = PAIR_CDR(scm->r.s);
|
scm->r.s = PAIR_CDR(scm->r.s);
|
||||||
@ -1304,7 +775,7 @@ static QSE_INLINE qse_scm_ent_t* enter_list (qse_scm_t* scm, int flagv)
|
|||||||
* nil#2 to store the last element in the list.
|
* nil#2 to store the last element in the list.
|
||||||
* both to be updated in chain_to_list() as items are added.
|
* both to be updated in chain_to_list() as items are added.
|
||||||
*/
|
*/
|
||||||
return (push (scm, TO_SMALLINT(flagv)) == QSE_NULL ||
|
return (push (scm, TO_SMALLINT(scm,flagv)) == QSE_NULL ||
|
||||||
push (scm, scm->nil) == QSE_NULL ||
|
push (scm, scm->nil) == QSE_NULL ||
|
||||||
push (scm, scm->nil) == QSE_NULL)? QSE_NULL: scm->r.s;
|
push (scm, scm->nil) == QSE_NULL)? QSE_NULL: scm->r.s;
|
||||||
}
|
}
|
||||||
@ -1315,7 +786,7 @@ static QSE_INLINE_ALWAYS qse_scm_ent_t* leave_list (qse_scm_t* scm, int* flagv)
|
|||||||
|
|
||||||
/* the stack must not be empty */
|
/* the stack must not be empty */
|
||||||
QSE_ASSERTX (
|
QSE_ASSERTX (
|
||||||
!IS_NIL(scm->r.s),
|
!IS_NIL(scm,scm->r.s),
|
||||||
"You cannot leave a list without entering it"
|
"You cannot leave a list without entering it"
|
||||||
);
|
);
|
||||||
|
|
||||||
@ -1327,7 +798,7 @@ static QSE_INLINE_ALWAYS qse_scm_ent_t* leave_list (qse_scm_t* scm, int* flagv)
|
|||||||
pop (scm);
|
pop (scm);
|
||||||
pop (scm);
|
pop (scm);
|
||||||
|
|
||||||
if (IS_NIL(scm->r.s))
|
if (IS_NIL(scm,scm->r.s))
|
||||||
{
|
{
|
||||||
/* the stack is empty after popping.
|
/* the stack is empty after popping.
|
||||||
* it is back to the top level.
|
* it is back to the top level.
|
||||||
@ -1351,12 +822,12 @@ static QSE_INLINE_ALWAYS void dot_list (qse_scm_t* scm)
|
|||||||
qse_scm_ent_t* pair;
|
qse_scm_ent_t* pair;
|
||||||
int flagv;
|
int flagv;
|
||||||
|
|
||||||
QSE_ASSERT (!IS_NIL(scm->r.s));
|
QSE_ASSERT (!IS_NIL(scm,scm->r.s));
|
||||||
|
|
||||||
/* mark the state that a dot has appeared in the list */
|
/* mark the state that a dot has appeared in the list */
|
||||||
pair = PAIR_CDR(PAIR_CDR(scm->r.s));
|
pair = PAIR_CDR(PAIR_CDR(scm->r.s));
|
||||||
flagv = FROM_SMALLINT(PAIR_CAR(pair));
|
flagv = FROM_SMALLINT(scm,PAIR_CAR(pair));
|
||||||
PAIR_CAR(pair) = TO_SMALLINT(flagv | DOTTED);
|
PAIR_CAR(pair) = TO_SMALLINT(scm,flagv|DOTTED);
|
||||||
}
|
}
|
||||||
|
|
||||||
static qse_scm_ent_t* chain_to_list (qse_scm_t* scm, qse_scm_ent_t* obj)
|
static qse_scm_ent_t* chain_to_list (qse_scm_t* scm, qse_scm_ent_t* obj)
|
||||||
@ -1366,20 +837,20 @@ static qse_scm_ent_t* chain_to_list (qse_scm_t* scm, qse_scm_ent_t* obj)
|
|||||||
|
|
||||||
/* the stack top is the pair pointing to the list tail */
|
/* the stack top is the pair pointing to the list tail */
|
||||||
tail = scm->r.s;
|
tail = scm->r.s;
|
||||||
QSE_ASSERT (!IS_NIL(tail));
|
QSE_ASSERT (!IS_NIL(scm,tail));
|
||||||
|
|
||||||
/* the pair pointing to the list head is below the tail cell
|
/* the pair pointing to the list head is below the tail cell
|
||||||
* connected via cdr. */
|
* connected via cdr. */
|
||||||
head = PAIR_CDR(tail);
|
head = PAIR_CDR(tail);
|
||||||
QSE_ASSERT (!IS_NIL(head));
|
QSE_ASSERT (!IS_NIL(scm,head));
|
||||||
|
|
||||||
/* the pair pointing to the flag is below the head cell
|
/* the pair pointing to the flag is below the head cell
|
||||||
* connected via cdr */
|
* connected via cdr */
|
||||||
flag = PAIR_CDR(head);
|
flag = PAIR_CDR(head);
|
||||||
|
|
||||||
/* retrieve the numeric flag value */
|
/* retrieve the numeric flag value */
|
||||||
QSE_ASSERT(IS_SMALLINT(PAIR_CAR(flag)));
|
QSE_ASSERT(IS_SMALLINT(scm,PAIR_CAR(flag)));
|
||||||
flagv = (int)FROM_SMALLINT(PAIR_CAR(flag));
|
flagv = (int)FROM_SMALLINT(scm,PAIR_CAR(flag));
|
||||||
|
|
||||||
if (flagv & CLOSED)
|
if (flagv & CLOSED)
|
||||||
{
|
{
|
||||||
@ -1390,18 +861,18 @@ static qse_scm_ent_t* chain_to_list (qse_scm_t* scm, qse_scm_ent_t* obj)
|
|||||||
else if (flagv & DOTTED)
|
else if (flagv & DOTTED)
|
||||||
{
|
{
|
||||||
/* the list must not be empty to have reached the dotted state */
|
/* the list must not be empty to have reached the dotted state */
|
||||||
QSE_ASSERT (!IS_NIL(PAIR_CAR(tail)));
|
QSE_ASSERT (!IS_NIL(scm,PAIR_CAR(tail)));
|
||||||
|
|
||||||
/* chain the object via 'cdr' of the tail cell */
|
/* chain the object via 'cdr' of the tail cell */
|
||||||
PAIR_CDR(PAIR_CAR(tail)) = obj;
|
PAIR_CDR(PAIR_CAR(tail)) = obj;
|
||||||
|
|
||||||
/* update the flag to CLOSED so that you can have more than
|
/* update the flag to CLOSED so that you can have more than
|
||||||
* one item after the dot. */
|
* one item after the dot. */
|
||||||
PAIR_CAR(flag) = TO_SMALLINT(flagv | CLOSED);
|
PAIR_CAR(flag) = TO_SMALLINT(scm,flagv|CLOSED);
|
||||||
}
|
}
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
cell = make_pair_entity (scm, obj, scm->nil);
|
cell = qse_scm_makepairent (scm, obj, scm->nil);
|
||||||
if (cell == QSE_NULL) return QSE_NULL;
|
if (cell == QSE_NULL) return QSE_NULL;
|
||||||
|
|
||||||
if (PAIR_CAR(head) == scm->nil)
|
if (PAIR_CAR(head) == scm->nil)
|
||||||
@ -1429,12 +900,12 @@ static QSE_INLINE_ALWAYS int is_list_empty (qse_scm_t* scm)
|
|||||||
{
|
{
|
||||||
/* the stack must not be empty */
|
/* the stack must not be empty */
|
||||||
QSE_ASSERTX (
|
QSE_ASSERTX (
|
||||||
!IS_NIL(scm->r.s),
|
!IS_NIL(scm,scm->r.s),
|
||||||
"You can not call this function while the stack is empty"
|
"You can not call this function while the stack is empty"
|
||||||
);
|
);
|
||||||
|
|
||||||
/* if the tail pointer is pointing to nil, the list is empty */
|
/* if the tail pointer is pointing to nil, the list is empty */
|
||||||
return IS_NIL(PAIR_CAR(scm->r.s));
|
return IS_NIL(scm,PAIR_CAR(scm->r.s));
|
||||||
}
|
}
|
||||||
|
|
||||||
static int read_entity (qse_scm_t* scm)
|
static int read_entity (qse_scm_t* scm)
|
||||||
@ -1563,20 +1034,20 @@ static int read_entity (qse_scm_t* scm)
|
|||||||
break;
|
break;
|
||||||
|
|
||||||
case TOK_INT:
|
case TOK_INT:
|
||||||
obj = make_number_entity (scm, TOK_IVAL(scm));
|
obj = qse_scm_makenument (scm, TOK_IVAL(scm));
|
||||||
break;
|
break;
|
||||||
|
|
||||||
case TOK_REAL:
|
case TOK_REAL:
|
||||||
obj = make_real_entity (scm, TOK_RVAL(scm));
|
obj = qse_scm_makerealent (scm, TOK_RVAL(scm));
|
||||||
break;
|
break;
|
||||||
|
|
||||||
case TOK_STRING:
|
case TOK_STRING:
|
||||||
obj = make_string_entity (
|
obj = qse_scm_makestrent (
|
||||||
scm, TOK_NAME_PTR(scm), TOK_NAME_LEN(scm));
|
scm, TOK_NAME_PTR(scm), TOK_NAME_LEN(scm));
|
||||||
break;
|
break;
|
||||||
|
|
||||||
case TOK_SYMBOL:
|
case TOK_SYMBOL:
|
||||||
obj = make_symbol_entity (scm, TOK_NAME_PTR(scm));
|
obj = qse_scm_makesyment (scm, TOK_NAME_PTR(scm));
|
||||||
break;
|
break;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|||||||
@ -208,6 +208,13 @@ struct qse_scm_t
|
|||||||
} mem;
|
} mem;
|
||||||
};
|
};
|
||||||
|
|
||||||
|
|
||||||
|
#define IS_NIL(scm,ent) QSE_SCM_ENT_ISNIL(scm,ent)
|
||||||
|
#define IS_SMALLINT(scm,ent) QSE_SCM_ENT_ISSMALLINT(scm,ent)
|
||||||
|
#define FROM_SMALLINT(scm,ent) QSE_SCM_ENT_FROMSMALLINT(scm,ent)
|
||||||
|
#define TO_SMALLINT(scm,num) QSE_SCM_ENT_TOSMALLINT(scm,num)
|
||||||
|
#define CAN_BE_SMALLINT(scm,num) QSE_SCM_ENT_CANBESMALLINT(scm,num)
|
||||||
|
|
||||||
#ifdef __cplusplus
|
#ifdef __cplusplus
|
||||||
extern "C" {
|
extern "C" {
|
||||||
#endif
|
#endif
|
||||||
@ -218,4 +225,5 @@ const qse_char_t* qse_scm_dflerrstr (qse_scm_t* scm, qse_scm_errnum_t errnum);
|
|||||||
#ifdef __cplusplus
|
#ifdef __cplusplus
|
||||||
}
|
}
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user