/* R5RS library procedure read
* (read)
* (read [port])
*/
SCM scm_proc_read(FILE *file)
{
int c = skip_comment_and_space(file);
switch (c) {
case '(':
return read_list(file);
case ')': /* List end */
scheme_error("symtax error");
case '[':
case ']':
scheme_error("unsupport bracket");
case '{':
case '}':
scheme_error("unsupport brace");
case '|':
scheme_error("unsupport bar");
case '#':
c = fgetc(file);
if ('(' == c) {
return read_vector(file);
} else {
ungetc(c, file);
return read_simple_datum(file, '#');
}
case '\'': /* Quotation */
return new_cons(SCM_SYMBOL_QUOTE, new_cons(scm_proc_read(file), SCM_NULL));
case '`': /* Quasiquotation */
scheme_error("unsupport quasiquotation");
case ',': /* (Splicing) Uuquotation */
scheme_error("unsupport (splicing) unquotation");
default:
return read_simple_datum(file, c);
}
}
void putmethod(class_t *cl, at *name, at *value)
{
ifn (SYMBOLP(name))
RAISEF("not a symbol", name);
if (value && !FUNCTIONP(value))
RAISEF("not a function", value);
clear_hashok(cl);
at **last = &(cl->methods);
at *list = *last;
while (CONSP(list)) {
at *q = Car(list);
ifn (CONSP(q))
RAISEF("not a pair", q);
if (Car(q) == name) {
if (value) {
/* replace */
Cdr(q) = value;
return;
} else {
/* remove */
*last = Cdr(list);
Cdr(list) = NIL;
return;
}
}
last = &Cdr(list);
list = *last;
}
/* not an existing method, append */
if (value)
*last = new_cons(new_cons(name, value), NIL);
}
static at *call_method(at *obj, struct hashelem *hx, at *args)
{
at *fun = hx->function;
assert(FUNCTIONP(fun));
if (Class(fun) == de_class) {
// DE
at *p = eval_arglist(args);
return with_object(obj, fun, p, hx->sofar);
} else if (Class(fun) == df_class) {
// DF
return with_object(obj, fun, args, hx->sofar);
} else if (Class(fun) == dm_class) {
// DM
at *p = new_cons(new_cons(fun, args), NIL);
at *q = with_object(obj, at_mexpand, p, hx->sofar);
return eval(q);
} else {
// DX, DY, DH
at *p = new_cons(fun, new_cons(obj, args));
return Class(fun)->listeval(fun, p);
}
}
at *send_message(at *classname, at *obj, at *method, at *args)
{
class_t *cl = classof(obj);
/* find superclass */
if (classname) {
ifn (SYMBOLP(classname))
error(NIL, "not a class name", classname);
while (cl && cl->classname != classname)
cl = cl->super;
ifn (cl)
error(NIL, "cannot find class", classname);
}
/* send */
ifn (SYMBOLP(method))
error(NIL, "not a method name", method);
struct hashelem *hx = _getmethod(cl, method);
if (hx)
return call_method(obj, hx, args);
else if (method == at_pname) // special method?
return NEW_STRING(cl->name(obj));
/* send -unknown */
hx = _getmethod(cl, at_unknown);
if (hx) {
at *arg = new_cons(method, new_cons(args, NIL));
return call_method(obj, hx, arg);
}
/* fail */
error(NIL, "method not found", method);
}
/* timer_fire --
* Sends all current timer events.
* Returns number of milliseconds until
* next timer event (or a large number)
*/
int timer_fire(void)
{
evtime_t now;
evtime_now(&now);
while (timers && evtime_cmp(&now,&timers->date)>=0) {
event_timer_t *ti = timers;
at *p = new_cons(named("timer"),
new_cons(NEW_GPTR(ti), NIL));
timers = ti->next;
event_add(ti->handler, p);
if (ti->period.sec>0 || ti->period.msec>0) {
/* Periodic timer shoot only once per call */
while (evtime_cmp(&now,&ti->date) >= 0)
evtime_add(&ti->date,&ti->period,&ti->date);
ti_insert(ti);
}
}
if (timers) {
evtime_t diff;
evtime_sub(&timers->date, &now, &diff);
if (diff.sec < 24*3600)
return diff.sec * 1000 + diff.msec;
}
return 24*3600*1000;
}
cell_t *secd_mem_info(secd_t *secd) {
cell_t *arrptr
= new_cons(secd, new_number(secd, secd->arrayptr - secd->begin), SECD_NIL);
cell_t *fxdptr
= new_cons(secd, new_number(secd, secd->fixedptr - secd->begin), arrptr);
cell_t *freec =
new_cons(secd, new_number(secd, secd->stat.free_cells), fxdptr);
return new_cons(secd, new_number(secd, secd->end - secd->begin), freec);
}
/* interface calling into the fortran routine */
static int lbfgs(index_t *x0, at *f, at *g, double gtol, htable_t *p, at *vargs)
{
/* argument checking and setup */
extern void lbfgs_(int *n, int *m, double *x, double *fval, double *gval, \
int *diagco, double *diag, int iprint[2], double *gtol, \
double *xtol, double *w, int *iflag);
ifn (IND_STTYPE(x0) == ST_DOUBLE)
error(NIL, "not an array of doubles", x0->backptr);
ifn (Class(f)->listeval)
error(NIL, "not a function", f);
ifn (Class(f)->listeval)
error(NIL, "not a function", g);
ifn (gtol > 0)
error(NIL, "threshold value not positive", NEW_NUMBER(gtol));
at *gx = copy_array(x0)->backptr;
at *(*listeval_f)(at *, at *) = Class(f)->listeval;
at *(*listeval_g)(at *, at *) = Class(g)->listeval;
at *callf = new_cons(f, new_cons(x0->backptr, vargs));
at *callg = new_cons(g, new_cons(gx, new_cons(x0->backptr, vargs)));
htable_t *params = lbfgs_params();
if (p) htable_update(params, p);
int iprint[2];
iprint[0] = (int)Number(htable_get(params, NEW_SYMBOL("iprint-1")));
iprint[1] = (int)Number(htable_get(params, NEW_SYMBOL("iprint-2")));
lb3_.gtol = Number(htable_get(params, NEW_SYMBOL("ls-gtol")));
lb3_.stpmin = Number(htable_get(params, NEW_SYMBOL("ls-stpmin")));
lb3_.stpmax = Number(htable_get(params, NEW_SYMBOL("ls-stpmax")));
int m = (int)Number(htable_get(params, NEW_SYMBOL("lbfgs-m")));
int n = index_nelems(x0);
double *x = IND_ST(x0)->data;
double fval;
double *gval = IND_ST(Mptr(gx))->data;
int diagco = false;
double *diag = mm_blob(n*sizeof(double));
double *w = mm_blob((n*(m+m+1)+m+m)*sizeof(double));
double xtol = eps(1); /* machine precision */
int iflag = 0;
ifn (n>0)
error(NIL, "empty array", x0->backptr);
ifn (m>0)
error(NIL, "m-parameter must be positive", NEW_NUMBER(m));
/* reverse communication loop */
do {
fval = Number(listeval_f(Car(callf), callf));
listeval_g(Car(callg), callg);
lbfgs_(&n, &m, x, &fval, gval, &diagco, diag, iprint, >ol, &xtol, w, &iflag);
assert(iflag<2);
} while (iflag > 0);
return iflag;
}
at *files(const char *s)
{
at *ans = NIL;
at **where = &ans;
#ifdef UNIX
DIR *dirp = opendir(s);
if (dirp) {
struct dirent *d;
while ((d = readdir(dirp))) {
int n = NAMLEN(d);
at *ats = make_string_of_length(n);
char *s = (char *)String(ats);
strncpy(s, d->d_name, n); s[n] = 0;
*where = new_cons(ats,NIL);
where = &Cdr(*where);
}
closedir(dirp);
}
#endif
#ifdef WIN32
struct _finddata_t info;
if ((s[0]=='/' || s[0]=='\\') &&
(s[1]=='/' || s[1]=='\\') && !s[2]) {
long hfind = GetLogicalDrives();
strcpy(info.name,"A:\\");
for (info.name[0]='A'; info.name[0]<='Z'; info.name[0]++)
if (hfind & (1<<(info.name[0]-'A'))) {
*where = new_cons(new_string(info.name),NIL);
where = &Cdr(*where);
}
} else if (dirp(s)) {
*where = new_cons(new_string(".."),NIL);
where = &Cdr(*where);
}
strcpy(string_buffer,s);
char *last = string_buffer + strlen(string_buffer);
if (last>string_buffer && last[-1]!='/' && last[-1]!='\\')
strcpy(last,"\\*.*");
else
strcpy(last,"*.*");
long hfind = _findfirst(string_buffer, &info);
if (hfind != -1) {
do {
if (strcmp(".",info.name) && strcmp("..",info.name)) {
*where = new_cons(new_string(info.name),NIL);
where = &Cdr(*where);
}
} while ( _findnext(hfind, &info) != -1 );
_findclose(hfind);
}
#endif
return ans;
}
cell_t *secd_insert_in_frame(secd_t *secd, cell_t *frame, cell_t *sym, cell_t *val) {
cell_t *old_syms = get_car(frame);
cell_t *old_vals = get_cdr(frame);
// an interesting side effect: since there's no check for
// re-binding an existing symbol, we can create multiple
// copies of it on the frame, the last added is found
// during value lookup, but the old ones are persistent
frame->as.cons.car = share_cell(secd, new_cons(secd, sym, old_syms));
frame->as.cons.cdr = share_cell(secd, new_cons(secd, val, old_vals));
drop_cell(secd, old_syms); drop_cell(secd, old_vals);
return frame;
}
SE *get_se()
{
switch(token.type)
{
case TEOF: return new_sym(strdup("#eof"));
case TNUM: return new_num(atoi(token.buf));
case TSYM: return new_sym(strdup(token.buf));
case TQUOTE: get_token(); /* ! */
return new_cons(new_sym(strdup("quote")),
new_cons(get_se(),NIL));
case TLPAR: return get_cdr();
default: break; /* err! */
}
return NIL; /* notreached */
}
static cell_t *read_bytevector(secd_parser_t *p) {
secd_t *secd = p->secd;
assert(p->token == '(', "read_bytevector: '(' expected");
cell_t *tmplist = SECD_NIL;
cell_t *cur;
size_t len = 0;
while (lexnext(p) == TOK_NUM) {
assert((0 <= p->numtok) && (p->numtok < 256),
"read_bytevector: out of range");
cell_t *newc = new_cons(secd, new_number(secd, p->numtok), SECD_NIL);
if (not_nil(tmplist)) {
cur->as.cons.cdr = share_cell(secd, newc);
cur = newc;
} else {
tmplist = cur = newc;
}
++len;
}
cell_t *bvect = new_bytevector_of_size(secd, len);
assert_cell(bvect, "read_bytevector: failed to allocate");
unsigned char *mem = (unsigned char *)strmem(bvect);
cur = tmplist;
size_t i;
for (i = 0; i < len; ++i) {
mem[i] = (unsigned char)numval(list_head(cur));
cur = list_next(secd, cur);
}
free_cell(secd, tmplist);
return bvect;
}
at *copy_tree(at *p)
{
MM_ENTER;
if (CONSP(p)) {
/* detect circular lists */
at *p0 = p;
bool move_p0 = false;
at *q = NIL;
at **qp = &q;
while (CONSP(p)) {
*qp = new_cons(Car(p), NIL);
qp = &Cdr(*qp);
p = Cdr(p);
if (p == p0)
RAISEF("can't do circular structures", NIL);
move_p0 = !move_p0;
if (move_p0)
p0 = Cdr(p0);
}
*qp = copy_tree(p);
/* descend */
p = q;
while (CONSP(p)) {
AssignCar(p, copy_tree(Car(p)));
p = Cdr(p);
}
MM_RETURN(q);
} else
MM_RETURN(p);
}
/* process_pending_events --
* Process currently pending events
* by calling event-hook and event-idle
* until no events are left.
*/
void process_pending_events(void)
{
MM_ENTER;
int timer_fired = 0;
call_spoll();
at *hndl = ev_peek();
for(;;) {
while (hndl) {
/* Call the handler method <handle> */
at *event = event_get(hndl, true);
if (CONSP(event)) {
class_t *cl = classof(hndl);
at *m = getmethod(cl, at_handle);
if (m) {
at *args = new_cons(quote(event), NIL);
send_message(NIL, hndl, at_handle, args);
}
}
/* Check for more events */
call_spoll();
hndl = ev_peek();
}
/* Check for timer events */
if (timer_fired)
break;
timer_fire();
timer_fired = 1;
hndl = ev_peek();
}
MM_EXIT;
}
void init_event(void)
{
mt_event_timer =
MM_REGTYPE("event_timer", sizeof(event_timer_t),
clear_event_timer, mark_event_timer, 0);
MM_ROOT(timers);
/* set up event queue */
MM_ROOT(head);
head = tail = new_cons(NIL, NIL);
/* EVENTS FUNCTION */
at_handle = var_define("handle");
dx_define("set-event-handler", xseteventhandler);
dx_define("process-pending-events", xprocess_pending_events);
dx_define("sendevent", xsendevent);
dx_define("testevent", xtestevent);
dx_define("checkevent", xcheckevent);
dx_define("waitevent", xwaitevent);
dx_define("eventinfo", xeventinfo);
/* TIMER FUNCTIONS */
dx_define("create-timer", xcreate_timer);
dx_define("create-timer-absolute", xcreate_timer_absolute);
dx_define("kill-timer", xkill_timer);
dx_define("sleep", xsleep);
}
SE *get_cdr() {
SE *hd,*tl;
get_token();
if(token.type==TRPAR) return NIL;
hd=get_se();
tl=get_cdr();
return new_cons(hd,tl);
}
cell_t *make_native_frame(secd_t *secd,
const native_binding_t *binding)
{
int i;
cell_t *symlist = SECD_NIL;
cell_t *vallist = SECD_NIL;
for (i = 0; binding[i].name; ++i) {
cell_t *sym = new_symbol(secd, binding[i].name);
cell_t *val = new_const_clone(secd, binding[i].val);
if (not_nil(val))
sym->nref = val->nref = DONT_FREE_THIS;
symlist = new_cons(secd, sym, symlist);
vallist = new_cons(secd, val, vallist);
}
return new_frame(secd, symlist, vallist);
}
void secd_init_env(secd_t *secd) {
/* initialize global values */
stdinhash = secd_strhash(SECD_FAKEVAR_STDIN);
stdouthash = secd_strhash(SECD_FAKEVAR_STDOUT);
stddbghash = secd_strhash(SECD_FAKEVAR_STDDBG);
/* initialize the first frame */
cell_t *frame = make_native_frame(secd, native_functions);
cell_t *frame_io = new_cons(secd, secd->input_port, secd->output_port);
frame->as.frame.io = share_cell(secd, frame_io);
/* ready */
cell_t *env = new_cons(secd, frame, SECD_NIL);
secd->env = share_cell(secd, env);
secd->global_env = secd->env;
}
/* <list> -> (<datum>*) | (<datum>+ . <datum>) | <abbreviation>
*/
static SCM read_list(FILE *file)
{
int c;
SCM lst = SCM_NULL;
SCM last_pair = SCM_NULL;
SCM datum = SCM_NULL;
for (;;) {
c = skip_comment_and_space(file);
switch (c) {
case EOF:
goto syntax_error;
break;
case ')': /* end of list */
return lst;
case '.': /* dot pair */
if (NULL_P(last_pair)) /* ( . <datum>) is invalid */
goto syntax_error;
CDR(last_pair) = scm_proc_read(file);
c = skip_comment_and_space(file);
if (c != ')')
goto syntax_error;
return lst;
break;
default: /* read datum */
ungetc(c, file);
datum = scm_proc_read(file);
if (NULL_P(lst)) { /* initialize list */
lst = new_cons(datum, SCM_NULL);
last_pair= lst;
} else {
CDR(last_pair) = new_cons(datum, SCM_NULL);
last_pair = CDR(last_pair);
}
}
}
syntax_error:
scheme_error("syntax error");
return NULL;
}
void cg_grad_adaptor(double *g, double *x, int n)
{
static at *call = NIL;
static int nx = -1;
static storage_t *stx = NULL;
static storage_t *stg = NULL;
static at *(*listeval)(at *, at *) = NULL;
if (n == -1) {
/* initialize */
at *x0 = var_get(named("x0"));
at *vargs = var_get(named("vargs"));
at *g = var_get(named("g"));
ifn (x0)
error(NIL, "x0 not found", NIL);
ifn (INDEXP(x0) && IND_STTYPE((index_t *)Mptr(x0)))
error(NIL, "x0 not a double index", x0);
ifn (g)
error(NIL, "g not found", NIL);
listeval = Class(g)->listeval;
index_t *ind = Mptr(x0);
nx = storage_nelems(IND_ST(ind));
stx = new_storage(ST_DOUBLE);
stx->flags = STS_FOREIGN;
stx->size = nx;
stx->data = (char *)-1;
stg = new_storage(ST_DOUBLE);
stg->flags = STS_FOREIGN;
stg->size = nx;
stg->data = (char *)-1;
call = new_cons(g,
new_cons(NEW_INDEX(stg, IND_SHAPE(ind)),
new_cons(NEW_INDEX(stx, IND_SHAPE(ind)),
vargs)));
} else {
if (n != nx)
error(NIL, "vector of different size expected", NEW_NUMBER(n));
stx->data = x;
stg->data = g;
listeval(Car(call), call);
}
}
cell_t *sexp_lexeme(secd_t *secd, int line, int pos, int prevchar) {
cell_t *result;
secd_parser_t p;
init_parser(secd, &p);
p.line = line;
p.pos = pos;
p.lc = prevchar;
lexnext(&p);
switch (p.token) {
case TOK_EOF:
return new_symbol(secd, EOF_OBJ);
case TOK_SYM:
result = new_lexeme(secd, "sym", new_symbol(secd, p.symtok));
break;
case TOK_NUM:
result = new_lexeme(secd, "int", new_number(secd, p.numtok));
break;
case TOK_STR:
result = new_lexeme(secd, "str", new_string(secd, strmem(p.strtok)));
drop_cell(secd, p.strtok);
break;
case TOK_CHAR:
result = new_lexeme(secd, "char", new_char(secd, p.numtok));
break;
case TOK_QUOTE: case TOK_QQ:
case TOK_UQ: case TOK_UQSPL:
result = new_lexeme(secd, special_form_for(p.token), SECD_NIL);
break;
case TOK_ERR:
result = new_lexeme(secd, "syntax error", SECD_NIL);
break;
default:
result = new_lexeme(secd, "token", new_char(secd, p.token));
}
cell_t *pcharc = new_cons(secd, new_char(secd, p.lc), result);
cell_t *posc = new_cons(secd, new_number(secd, p.pos), pcharc);
cell_t *linec = new_cons(secd, new_number(secd, p.line), posc);
return linec;
}
/* make a list from a vector of objects */
at *vector2list(int n, at **vec)
{
MM_ENTER;
at *l = NIL;
at **where = &l;
for (int i=0; i<n;i++) {
*where = new_cons(vec[i], NIL);
where = &Cdr(*where);
}
MM_RETURN(l);
}
void ev_add(at *handler, at *event, const char *desc, int mods)
{
MM_ENTER;
if (handler && event) {
at *d = NIL;
if (mods == (unsigned char)mods)
d = NEW_NUMBER(mods);
if (desc && d) {
gptr p = (gptr)desc;
d = new_cons(NEW_GPTR(p), d);
} else if (desc) {
gptr p = (gptr)desc;
d = NEW_GPTR(p);
}
at *p = new_cons(NEW_GPTR(handler), new_cons(d, event));
add_notifier(handler, (wr_notify_func_t *)ev_notify, 0);
Cdr(tail) = new_cons(p,NIL);
tail = Cdr(tail);
}
MM_EXIT;
}
void init_storage()
{
assert(ST_FIRST==0);
assert(sizeof(char)==sizeof(uchar));
#ifdef HAVE_MMAP
size_t storage_size = offsetof(storage_t, mmap_addr);
#else
size_t storage_size = sizeof(storage_t);
#endif
mt_storage = MM_REGTYPE("storage", storage_size,
clear_storage, mark_storage, 0);
/* set up storage_classes */
abstract_storage_class = new_builtin_class(NIL);
class_define("storage", abstract_storage_class);
Generic_storage_class_init(ST_BOOL, Bool);
Generic_storage_class_init(ST_AT, Atom);
Generic_storage_class_init(ST_FLOAT, Float);
Generic_storage_class_init(ST_DOUBLE, Double);
Generic_storage_class_init(ST_INT, Int);
Generic_storage_class_init(ST_SHORT, Short);
Generic_storage_class_init(ST_CHAR, Char);
Generic_storage_class_init(ST_UCHAR, UChar);
Generic_storage_class_init(ST_GPTR, Gptr);
Generic_storage_class_init(ST_MPTR, Mptr);
at *p = var_define("storage-classes");
at *l = NIL;
for (storage_type_t st=ST_FIRST; st<ST_LAST; st++)
l = new_cons(storage_class[st]->backptr, l);
var_set(p, reverse(l));
var_lock(p);
dx_define("new-storage", xnew_storage);
dx_define("new-storage/managed", xnew_storage_managed);
dx_define("new-storage/foreign", xnew_storage_foreign);
#ifdef HAVE_MMAP
dx_define("new-storage/mmap",xnew_storage_mmap);
#endif
dx_define("storage-alloc",xstorage_alloc);
dx_define("storage-realloc",xstorage_realloc);
dx_define("storage-clear",xstorage_clear);
dx_define("storagep",xstoragep);
dx_define("storage-readonlyp",xstorage_readonlyp);
dx_define("storage-set-readonly", xstorage_set_readonly);
dx_define("storage-load",xstorage_load);
dx_define("storage-save",xstorage_save);
dx_define("storage-nelems",xstorage_nelems);
dx_define("storage-nbytes",xstorage_nbytes);
}
global Cell *
read_stream(Cell *cell)
{
long c;
c = cell->c_file == stdin ? get_one_char() : GetChar(cell->c_file);
if (c == EOF) {
end_stream(cell->c_file);
return new_cnst(nil);
}
return new_cons(cons,
new_pair(new_char((Char)c), new_stream(cell->c_file)));
}
struct lisp_object new_pair_object(struct lisp_object a,struct lisp_object *b){
struct lisp_object r;
r.objectType = T_pair;
r.boolD = 0;
r.charD = ' ';
r.numD = 0;
r.proc = NULL;
r.stringD = NULL;
//printf("unconsed");
r.pairD = new_cons(a,b);
//printf("Consed");
return r;
}
at *make_list(int n, at *v)
{
at *ans = NIL;
if (n < 0)
RAISEF("value must be non-negative", NEW_NUMBER(n));
if (n > 32767)
RAISEF("value too large", NEW_NUMBER(n));
MM_ENTER;
while (n--)
ans = new_cons(v, ans);
MM_RETURN(ans);
}
double cg_value_adaptor(double *x, int n)
{
static at *call = NIL;
static int nx = -1;
static storage_t *st = NULL;
static at *(*listeval)(at *, at *) = NULL;
if (n == -1) {
/* initialize */
at *x0 = var_get(named("x0"));
at *vargs = var_get(named("vargs"));
at *f = var_get(named("f"));
ifn (x0)
error(NIL, "x0 not found", NIL);
ifn (INDEXP(x0) && IND_STTYPE((index_t *)Mptr(x0)))
error(NIL, "x0 not a double index", x0);
ifn (f)
error(NIL, "f not found", NIL);
listeval = Class(f)->listeval;
index_t *ind = Mptr(x0);
nx = storage_nelems(IND_ST(ind));
st = new_storage(ST_DOUBLE);
st->flags = STS_FOREIGN;
st->size = nx;
st->data = (char *)-1;
call = new_cons(f, new_cons(NEW_INDEX(st, IND_SHAPE(ind)), vargs));
return NAN;
} else {
if (n != nx)
error(NIL, "vector of different size expected", NEW_NUMBER(n));
st->data = x;
return Number(listeval(Car(call), call));
}
}
static cell_t *
check_io_args(secd_t *secd, cell_t *sym, cell_t *val, cell_t **args_io) {
/* check for overriden *stdin* or *stdout* */
hash_t symh = symhash(sym);
if ((symh == stdinhash)
&& str_eq(symname(sym), SECD_FAKEVAR_STDIN))
{
assert(cell_type(val) == CELL_PORT, "*stdin* must bind a port");
if (is_nil(*args_io))
*args_io = new_cons(secd, val, SECD_NIL);
else
(*args_io)->as.cons.car = share_cell(secd, val);
} else
if ((symh == stdouthash)
&& str_eq(symname(sym), SECD_FAKEVAR_STDOUT))
{
assert(cell_type(val) == CELL_PORT, "*stdout* must bind a port");
if (is_nil(*args_io))
*args_io = new_cons(secd, SECD_NIL, val);
else
(*args_io)->as.cons.cdr = share_cell(secd, val);
}
return SECD_NIL;
}
/* process_pending_events --
Process currently pending events
by calling event-hook and event-idle
until no events are left. */
void
process_pending_events(void)
{
at *hndl;
at *event;
int timer_fired = 0;
call_spoll();
hndl = ev_peek();
for(;;)
{
while (hndl)
{
/* Call the handler method <handle> */
LOCK(hndl);
event = event_get(hndl, TRUE);
if (CONSP(event))
{
at *cl = classof(hndl);
if (EXTERNP(cl, &class_class))
{
at *m = checksend(cl->Object, at_handle);
if (m)
{
at *args = new_cons(event,NIL);
UNLOCK(m);
argeval_ptr = eval_nothing;
m = send_message(NIL,hndl,at_handle,args);
argeval_ptr = eval_std;
UNLOCK(args);
}
UNLOCK(m);
}
UNLOCK(cl);
}
UNLOCK(event);
UNLOCK(hndl);
/* Check for more events */
call_spoll();
hndl = ev_peek();
}
/* Check for timer events */
if (timer_fired)
break;
timer_fire();
timer_fired = 1;
hndl = ev_peek();
}
}
/* return size of dump file */
static off_t dump(const char *s)
{
/* Build the big list */
at *ans = NIL, **where = &ans;
/* 1 - the modules */
at *p = module_list();
at *q = p;
while (CONSP(q)) {
*where = new_cons(Car(q), NIL);
where = &Cdr(*where);
q = Cdr(q);
}
/* 2- the globals */
*where = global_defs();
/* Header */
at *atf = OPEN_WRITE(s,"dump");
FILE *f = Gptr(atf);
write32(f, DUMPMAGIC);
write32(f, DUMPVERSION);
/* The macro character map */
errno = 0;
fwrite(char_map,1,256,f);
test_file_error(f, errno);
/* Write the big list */
bool oldready = error_doc.ready_to_an_error;
error_doc.ready_to_an_error = false;
bwrite(ans, f, true);
error_doc.ready_to_an_error = oldready;
lush_delete(atf); /* close file */
/* get file size */
struct stat buf;
if (stat(s, &buf)>=0)
if (S_ISREG(buf.st_mode))
return buf.st_size;
return (off_t)0;
}