/*=gfunc stack
*
* what: make list of AutoGen values
*
* exparg: ag-name, AutoGen value name
*
* doc: Create a scheme list of all the strings that are associated
* with a name. They must all be text values or we choke.
=*/
SCM
ag_scm_stack(SCM obj)
{
SCM res;
SCM * pos = &res;
def_ent_t ** ppDE;
def_ent_t * pDE;
SCM str;
res = SCM_EOL;
ppDE = find_def_ent_list(ag_scm2zchars(obj, "AG Object"));
if (ppDE == NULL)
return SCM_EOL;
for (;;) {
pDE = *(ppDE++);
if (pDE == NULL)
break;
if (pDE->de_type != VALTYP_TEXT)
return SCM_UNDEFINED;
str = AG_SCM_STR02SCM(pDE->de_val.dvu_text);
*pos = scm_cons(str, SCM_EOL);
pos = SCM_CDRLOC(*pos);
}
return res;
}
/*=gfunc stack
*
* what: make list of AutoGen values
*
* exparg: ag-name, AutoGen value name
*
* doc: Create a scheme list of all the strings that are associated
* with a name. They must all be text values or we choke.
=*/
SCM
ag_scm_stack(SCM obj)
{
SCM res;
SCM * pos = &res;
tDefEntry** ppDE;
tDefEntry* pDE;
SCM str;
res = SCM_EOL;
ppDE = findEntryList(ag_scm2zchars(obj, "AG Object"));
if (ppDE == NULL)
return SCM_EOL;
for (;;) {
pDE = *(ppDE++);
if (pDE == NULL)
break;
if (pDE->valType != VALTYP_TEXT)
return SCM_UNDEFINED;
str = AG_SCM_STR02SCM(pDE->val.pzText);
*pos = scm_cons(str, SCM_EOL);
pos = SCM_CDRLOC(*pos);
}
return res;
}
SCM scm_ragnarok_select(SCM nfds ,SCM read_set ,SCM write_set,
SCM except_set ,SCM second ,SCM msecond)
#define FUNC_NAME "ragnarok-select"
{
int n = 0;
scm_rag_fd_set *rs = NULL;
scm_rag_fd_set *ws = NULL;
scm_rag_fd_set *es = NULL;
scm_rag_fd_set *ready_set = NULL;
long s = 0L;
long ms = 0L;
int i;
struct timeval tv;
SCM ret = SCM_EOL;
SCM *prev = &ret;
SCM_VALIDATE_NUMBER(1 ,nfds);
SCM_ASSERT_EVENT_SET(read_set);
SCM_ASSERT_EVENT_SET(write_set);
SCM_ASSERT_EVENT_SET(except_set);
if(!SCM_UNBNDP(ms))
{
SCM_VALIDATE_NUMBER(5 ,second);
s = (long)scm_from_long(second);
if(!SCM_UNBNDP(msecond))
{
SCM_VALIDATE_NUMBER(6 ,msecond);
ms = (long)scm_from_long(msecond);
}
}
n = scm_from_int(nfds);
rs = (scm_rag_event_set*)SMOB_DATA(read_set);
ws = (scm_rag_event_set*)SMOB_DATA(write_set);
es = (scm_rag_event_set*)SMOB_DATA(except_set);
tv.tv_sec = (long)s;
tv.tv_usec = (long)us;
ready_set = select(n ,rs->set ,ws->set ,es->set ,&tv);
for(i=0;i<n;i++)
{
if(FD_ISSET(i ,&ready_set))
{
*prev = scm_cons(scm_from_int(i) ,SCM_EOL);
prev = SCM_CDRLOC(*prev);
}
}
return ret;
}
/* This scandir is a shrink version of the glibc version.
* I believe we don't need versionsort or any other sort in the ragnarok.
*/
SCM scm_mmr_scandir(SCM dir, SCM filter)
#define FUNC_NAME "scandir"
{
struct dirent_or_dirent64 **rdent;
int has_filter = 0;
int n = 0 ,i = 0;
char *tmp_ptr = NULL;
SCM flag;
SCM ret = SCM_EOL;
SCM *prev;
SCM str;
SCM_VALIDATE_STRING(1, dir);
if(!SCM_UNBNDP(filter))
{
SCM_ASSERT(scm_is_true(scm_procedure_p(filter)),
filter ,SCM_ARG2 ,FUNC_NAME);
has_filter = 1;
}
scm_dynwind_begin(0);
errno = 0;
tmp_ptr = scm_to_locale_string(dir);
scm_dynwind_free(tmp_ptr);
n = scandir_or_scandir64(tmp_ptr,
&rdent, NULL,
alphasort_or_alphasort64);
if(has_filter)
{
for(prev = &ret;i<n;i++)
{
str = rdent[i]?
scm_from_locale_stringn(rdent[i]->d_name ,NAMLEN(rdent[i]))
:
SCM_EOF_VAL;
flag = scm_call_1(filter ,str);
free(rdent[i]);
if(scm_is_true(flag))
{
*prev = scm_cons(str ,SCM_EOL);
prev = SCM_CDRLOC(*prev);
}
}
}
else
{
for(prev = &ret;i<n;i++)
{
str = rdent[i]?
scm_from_locale_stringn(rdent[i]->d_name ,NAMLEN(rdent[i]))
:
SCM_EOF_VAL;
*prev = scm_cons(str ,SCM_EOL);
prev = SCM_CDRLOC(*prev);
free(rdent[i]);
}
}
if(errno != 0)
SCM_SYSERROR;
scm_dynwind_end();
free(rdent);
return ret;
}
int
scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
{
int (*cproc) () = cproc_ptr;
SCM z, va0, lva, *plva;
int k, kmax, kroll;
ssize_t *vi, inc;
size_t len;
/* Prepare reference argument. */
if (SCM_I_ARRAYP (ra0))
{
kmax = SCM_I_ARRAY_NDIM (ra0)-1;
inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra0)[kmax].inc;
va0 = make1array (SCM_I_ARRAY_V (ra0), inc);
/* Find unroll depth */
for (kroll = max(0, kmax); kroll > 0; --kroll)
{
inc *= (UBND (ra0, kroll) - LBND (ra0, kroll) + 1);
if (inc != SCM_I_ARRAY_DIMS (ra0)[kroll-1].inc)
break;
}
}
else
{
kroll = kmax = 0;
va0 = ra0 = make1array (ra0, 1);
}
/* Prepare rest arguments. */
lva = SCM_EOL;
plva = &lva;
for (z = lra; !scm_is_null (z); z = SCM_CDR (z))
{
SCM va1, ra1 = SCM_CAR (z);
if (SCM_I_ARRAYP (ra1))
{
if (kmax != SCM_I_ARRAY_NDIM (ra1) - 1)
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
inc = kmax < 0 ? 0 : SCM_I_ARRAY_DIMS (ra1)[kmax].inc;
va1 = make1array (SCM_I_ARRAY_V (ra1), inc);
/* Check unroll depth. */
for (k = kmax; k > kroll; --k)
{
ssize_t l0 = LBND (ra0, k), u0 = UBND (ra0, k);
if (l0 < LBND (ra1, k) || u0 > UBND (ra1, k))
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
inc *= (u0 - l0 + 1);
if (inc != SCM_I_ARRAY_DIMS (ra1)[k-1].inc)
{
kroll = k;
break;
}
}
/* Check matching of not-unrolled axes. */
for (; k>=0; --k)
if (LBND (ra0, k) < LBND (ra1, k) || UBND (ra0, k) > UBND (ra1, k))
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
}
else
{
if (kmax != 0)
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
va1 = make1array (ra1, 1);
if (LBND (ra0, 0) < LBND (va1, 0) || UBND (ra0, 0) > UBND (va1, 0))
scm_misc_error (what, "array shape mismatch: ~S", scm_list_1 (ra0));
}
*plva = scm_cons (va1, SCM_EOL);
plva = SCM_CDRLOC (*plva);
}
/* Check emptiness of not-unrolled axes. */
for (k = 0; k < kroll; ++k)
if (0 == (UBND (ra0, k) - LBND (ra0, k) + 1))
return 1;
/* Set unrolled size. */
for (len = 1; k <= kmax; ++k)
len *= (UBND (ra0, k) - LBND (ra0, k) + 1);
UBND (va0, 0) = len - 1;
for (z = lva; !scm_is_null (z); z = SCM_CDR (z))
UBND (SCM_CAR (z), 0) = len - 1;
/* Set starting indices and go. */
vi = scm_gc_malloc_pointerless (sizeof(ssize_t) * kroll, vi_gc_hint);
for (k = 0; k < kroll; ++k)
vi[k] = LBND (ra0, k);
do
{
if (k == kroll)
{
SCM y = lra;
SCM_I_ARRAY_SET_BASE (va0, cindk (ra0, vi, kroll));
for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
SCM_I_ARRAY_SET_BASE (SCM_CAR (z), cindk (SCM_CAR (y), vi, kroll));
if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data, lva)))
return 0;
--k;
}
else if (vi[k] < UBND (ra0, k))
{
++vi[k];
++k;
}
else
{
vi[k] = LBND (ra0, k) - 1;
--k;
}
}
while (k >= 0);
return 1;
}
