31 |
#include "include.h" |
#include "include.h" |
32 |
#define dcheck_type(a,b) check_type(a,b) |
#define dcheck_type(a,b) check_type(a,b) |
33 |
|
|
|
#if 0 |
|
|
#define CMPAUX_DEBUG |
|
|
#endif |
|
|
|
|
34 |
DEFUNO_NEW("SPECIALP",object,fSspecialp,SI |
DEFUNO_NEW("SPECIALP",object,fSspecialp,SI |
35 |
,1,1,NONE,OO,OO,OO,OO,void,siLspecialp,(object sym),"") |
,1,1,NONE,OO,OO,OO,OO,void,siLspecialp,(object sym),"") |
36 |
{ |
{ |
98 |
} |
} |
99 |
|
|
100 |
|
|
101 |
int |
/* Now inlined directly by optimizer */ |
102 |
ifloor(int x, int y) |
/* int */ |
103 |
{ |
/* ifloor(int x, int y) */ |
104 |
if (y == 0) { |
/* { */ |
105 |
FEerror("Zero divizor", 0); |
/* if (y == 0) { */ |
106 |
return 0; |
/* FEerror("Zero divizor", 0); */ |
107 |
} |
/* return 0; */ |
108 |
if (y > 0) { |
/* } */ |
109 |
if (x >= 0) |
/* if (y > 0) { */ |
110 |
return(x/y); |
/* if (x >= 0) */ |
111 |
else |
/* return(x/y); */ |
112 |
|
/* else */ |
113 |
/* FIXME, deal with possible overflow here*/ |
/* FIXME, deal with possible overflow here*/ |
114 |
return(-((-x-1))/y-1); |
/* return(-((-x-1))/y-1); */ |
115 |
} |
/* } */ |
116 |
if (x >= 0) |
/* if (x >= 0) */ |
117 |
/* FIXME, deal with possible overflow here*/ |
/* FIXME, deal with possible overflow here*/ |
118 |
return(-((x-1)/(-y))-1); |
/* return(-((x-1)/(-y))-1); */ |
119 |
else |
/* else */ |
120 |
return((-x)/(-y)); |
/* return((-x)/(-y)); */ |
121 |
} |
/* } */ |
122 |
|
|
123 |
int |
/* int */ |
124 |
imod(int x, int y) |
/* imod(int x, int y) */ |
125 |
{ |
/* { */ |
126 |
return(x - ifloor(x, y)*y); |
/* return(x - ifloor(x, y)*y); */ |
127 |
} |
/* } */ |
128 |
|
|
129 |
/* static void */ |
/* static void */ |
130 |
/* set_VV(object *, int, object); */ |
/* set_VV(object *, int, object); */ |
293 |
/* #endif */ |
/* #endif */ |
294 |
|
|
295 |
void |
void |
296 |
call_init ( int init_address, object memory, object fasl_vec, FUNC fptr ) |
call_init(int init_address, object memory, object fasl_vec, FUNC fptr) |
297 |
{ |
{object form; |
298 |
object form; |
FUNC at; |
299 |
FUNC at; |
/* #ifdef CLEAR_CACHE */ |
300 |
|
/* static int n; */ |
301 |
|
/* static sigset_t ss; */ |
302 |
|
|
303 |
check_type ( fasl_vec, t_vector ); |
/* if (!n) { */ |
304 |
form = ( fasl_vec->v.v_self [ fasl_vec->v.v_fillp - 1 ] ); |
/* struct sigaction sa={{(void *)sigh},{{0}},SA_RESTART|SA_SIGINFO,NULL}; */ |
305 |
|
|
306 |
if (fptr) { |
/* sigaction(SIGILL,&sa,NULL); */ |
307 |
at = fptr; |
/* sigemptyset(&ss); */ |
308 |
} else { |
/* sigaddset(&ss,SIGILL); */ |
309 |
at = (FUNC) ( memory->cfd.cfd_start + init_address ); |
/* sigprocmask(SIG_BLOCK,&ss,NULL); */ |
310 |
} |
/* n=1; */ |
311 |
|
/* } */ |
312 |
|
/* #endif */ |
313 |
|
|
314 |
|
|
315 |
|
check_type(fasl_vec,t_vector); |
316 |
|
form=(fasl_vec->v.v_self[fasl_vec->v.v_fillp -1]); |
317 |
|
|
318 |
|
if (fptr) at = fptr; |
319 |
|
else |
320 |
|
at=(FUNC)(memory->cfd.cfd_start+ init_address ); |
321 |
|
|
322 |
#ifdef VERIFY_INIT |
#ifdef VERIFY_INIT |
323 |
VERIFY_INIT; |
VERIFY_INIT |
324 |
#endif |
#endif |
325 |
|
|
326 |
if ( type_of ( form ) == t_cons && |
if (type_of(form)==t_cons && |
327 |
form->c.c_car == sSPinit ) { |
form->c.c_car == sSPinit) |
328 |
bds_bind(sSPinit,fasl_vec); |
{bds_bind(sSPinit,fasl_vec); |
329 |
bds_bind(sSPmemory,memory); |
bds_bind(sSPmemory,memory); |
330 |
(*at)(); |
/* #ifdef CLEAR_CACHE */ |
331 |
bds_unwind1; |
/* sigprocmask(SIG_UNBLOCK,&ss,NULL); */ |
332 |
bds_unwind1; |
/* #endif */ |
333 |
} else { |
(*at)(); |
334 |
/* old style three arg init, with all init being done by C code. */ |
/* #ifdef CLEAR_CACHE */ |
335 |
memory->cfd.cfd_self = fasl_vec->v.v_self; |
/* sigprocmask(SIG_BLOCK,&ss,NULL); */ |
336 |
memory->cfd.cfd_fillp = fasl_vec->v.v_fillp; |
/* #endif */ |
337 |
(*at)(memory->cfd.cfd_start, memory->cfd.cfd_size, memory); |
bds_unwind1; |
338 |
} |
bds_unwind1; |
339 |
} |
} |
340 |
|
else |
341 |
|
/* old style three arg init, with all init being done by C code. */ |
342 |
|
{memory->cfd.cfd_self = fasl_vec->v.v_self; |
343 |
|
memory->cfd.cfd_fillp = fasl_vec->v.v_fillp; |
344 |
|
/* #ifdef CLEAR_CACHE */ |
345 |
|
/* sigprocmask(SIG_UNBLOCK,&ss,NULL); */ |
346 |
|
/* #endif */ |
347 |
|
(*at)(memory->cfd.cfd_start, memory->cfd.cfd_size, memory); |
348 |
|
/* #ifdef CLEAR_CACHE */ |
349 |
|
/* sigprocmask(SIG_BLOCK,&ss,NULL); */ |
350 |
|
/* #endif */ |
351 |
|
}} |
352 |
|
|
353 |
/* statVV is the address of some static storage, which is used by the |
/* statVV is the address of some static storage, which is used by the |
354 |
cfunctions to refer to global variables,.. |
cfunctions to refer to global variables,.. |
369 |
int n=fasl_vec->v.v_fillp -1; |
int n=fasl_vec->v.v_fillp -1; |
370 |
int i; |
int i; |
371 |
object form; |
object form; |
|
#ifdef CMPAUX_DEBUG |
|
|
fprintf ( stderr, |
|
|
"do_init: START\n" ); |
|
|
fflush ( stderr ); |
|
|
#endif /* CMPAUX_DEBUG */ |
|
372 |
check_type(fasl_vec,t_vector); |
check_type(fasl_vec,t_vector); |
373 |
form = fasl_vec->v.v_self[n]; |
form = fasl_vec->v.v_self[n]; |
374 |
dcheck_type(form,t_cons); |
dcheck_type(form,t_cons); |
405 |
{object *top=vs_top; |
{object *top=vs_top; |
406 |
|
|
407 |
for(i=0 ; i< form->v.v_fillp; i++) |
for(i=0 ; i< form->v.v_fillp; i++) |
408 |
{ |
{ |
409 |
#ifdef CMPAUX_DEBUG |
eval(form->v.v_self[i]); |
|
fprintf ( stderr, |
|
|
"do_init: second for loop - i = %d, form->v.v_fillp = %d, form->v.v_self[%d] = %x....", |
|
|
i, form->v.v_fillp, i, form->v.v_self[i] ); |
|
|
fflush ( stderr ); |
|
|
#endif /* CMPAUX_DEBUG */ |
|
|
eval(form->v.v_self[i]); |
|
|
#ifdef CMPAUX_DEBUG |
|
|
fprintf ( stderr, |
|
|
" eval succeeded\n" ); |
|
|
fflush ( stderr ); |
|
|
#endif /* CMPAUX_DEBUG */ |
|
410 |
vs_top=top; |
vs_top=top; |
411 |
} |
} |
412 |
} |
} |