void
Y_gy_setlocale(int argc)
{
if (argc > 2) y_error("gy_setlocale, [[CATEGORY, ], LOCALE]");
char * scat="LC_ALL";
char * sloc =NULL;
int cat=0;
if (argc == 2) scat = ygets_q(1);
if (yarg_string(0)) sloc = ygets_q(0);
if (!strcmp(scat, "LC_ALL")) cat = LC_ALL;
else if (!strcmp(scat, "LC_COLLATE")) cat = LC_COLLATE;
else if (!strcmp(scat, "LC_CTYPE")) cat = LC_CTYPE;
else if (!strcmp(scat, "LC_MONETARY")) cat = LC_MONETARY;
else if (!strcmp(scat, "LC_NUMERIC")) cat = LC_NUMERIC;
else if (!strcmp(scat, "LC_TIME")) cat = LC_TIME;
else y_error("unsupported locale category");
if (sloc && cat==LC_NUMERIC && strcmp(sloc, "C"))
y_error("Yorick does not support LC_NUMERIC != \"C\"");
*ypush_q(0) = p_strcpy(setlocale(cat, sloc));
setlocale(LC_NUMERIC, "C");
}
psckt_t *
psckt_accept(psckt_t *listener, char **ppeer, void *ctx, psckt_cb_t *callback)
{
struct sockaddr_storage sad;
socklen_t lsad = sizeof(struct sockaddr_storage);
struct sockaddr *psad = (struct sockaddr *)&sad;
char host[NI_MAXHOST];
psckt_t *sock = p_malloc(sizeof(psckt_t));
int sfd, lfd = sock->fd;
*ppeer = 0;
if (listener->peer || !sock) { /* listeners have no peer */
if (sock) p_free(sock);
return 0;
}
sfd = accept(listener->fd, psad, &lsad);
if (sfd==-1 || getnameinfo(psad, lsad, host, NI_MAXHOST, 0, 0, 0)) {
close(sfd);
p_free(sock);
return 0;
}
sock->fd = sfd;
sock->peer = *ppeer = p_strcpy(host);
return psckt_setup(sock, ctx, callback);
}
char *
p_strtolower(const char * in)
{
char * cur, * out = p_strcpy(in);
for (cur=out; *cur; ++cur) *cur=tolower(*cur);
return out;
}
psckt_t *
psckt_connect(const char *addr, int port, void *ctx, psckt_cb_t *callback)
{
int sfd;
psckt_t *sock = p_malloc(sizeof(psckt_t));
struct addrinfo *ai, *ailist = sock? psckt_get_ailist(addr, port, 0) : 0;
if (!ailist) {
if (sock) p_free(sock);
return 0;
}
for (ai=ailist ; ai ; ai=ai->ai_next) {
sfd = socket(ai->ai_family, ai->ai_socktype, ai->ai_protocol);
if (sfd == -1) continue;
if (connect(sfd, ai->ai_addr, ai->ai_addrlen) != -1) break;
close(sfd);
}
if (!ai) {
p_free(sock);
sock = 0;
}
freeaddrinfo(ailist);
if (!sock) return 0;
sock->fd = sfd;
sock->peer = p_strcpy(addr);
return psckt_setup(sock, ctx, callback);
}
void YpPush(const char *input)
{
if (nYpInputs>=maxYpInputs) {
int newSize= maxYpInputs+4;
ypInputs= p_realloc(ypInputs, sizeof(char *)*newSize);
maxYpInputs= newSize;
}
ypInputs[nYpInputs++]= p_strcpy(input);
}
void Y_get_vars(int nArgs)
{
IOStream *file, *child;
Array *array;
char **pNames= 0, **cNames= 0;
long i, nParent, nChild;
Dimension *dims;
if (nArgs!=1) YError("get_vars takes exactly one argument");
file= yarg_file(0);
child= file->history? file->history->child : 0;
/* create result array */
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(2L, 1L, (Dimension *)0);
array= PushDataBlock(NewArray(&pointerStruct, tmpDims));
nParent= file->dataTable.nItems;
nChild= child? child->dataTable.nItems : 0;
if (nParent) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nParent, 1L, (Dimension *)0);
array->value.p[0]= pNames= NewArray(&stringStruct, tmpDims)->value.q;
}
if (nChild) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nChild, 1L, (Dimension *)0);
array->value.p[1]= cNames= NewArray(&stringStruct, tmpDims)->value.q;
}
/* and fill it */
for (i=0 ; i<nParent ; i++) pNames[i]= p_strcpy(file->dataTable.names[i]);
for (i=0 ; i<nChild ; i++) cNames[i]= p_strcpy(child->dataTable.names[i]);
}
void YpSetPaths(const char *pathlist)
{
char *paths= p_strcpy(pathlist);
char *token= yp_strtok(paths, PATH_SEP_DELIMIT);
char *prefix;
ClearPrefixes();
/* crack colon-or-space-delimited list of directory pathnames */
while (token) {
if (YIsDotRelative(token)) prefix= p_strcpy(token);
else prefix= YExpandName(token);
AddPrefix(prefix);
token= yp_strtok((char *)0, PATH_SEP_DELIMIT);
}
p_free(paths);
/* Set yCWD and yHOME if they haven't been initialized. */
if (!yCWD) YSetCWD((char *)0);
if (!yHOME) YGetHOME();
}
char *
config_read_value(FILE *in)
{
int i = 0;
value[i] = fgetc(in);
while(i<BSIZE-1 && value[i]!='\n') {
i++;
value[i] = fgetc(in);
}
value[i] = '\0';
return p_strcpy(value);
}
static p_file *PushInclude(const char *filename, int fullparse)
{
p_file *file= 0;
char *name= 0;
long i;
if (YIsAbsolute(filename)) {
/* absolute pathname doesn't need any prefix */
file= open_include(filename, fullparse);
if (!file) return 0;
name= p_strcpy(filename);
} else {
char *tmp;
for (i=0 ; i<=nYpPrefixes ; i++) {
if (i<nYpPrefixes) {
tmp= p_strncat(ypPrefixes[i], filename, 0);
name= YExpandName(tmp);
p_free(tmp);
} else {
/* this branch is probably a bug --
* if . is not on path probably should not find file...
* maybe protects against empty path?
*/
name= YExpandName(filename);
if (!YIsAbsolute(name)) break;
}
file= open_include(name, fullparse);
if (file) break;
p_free(name);
}
if (!file) return 0;
}
if (nYpIncludes>=maxYpIncludes) {
int newSize= maxYpIncludes+4;
ypIncludes= p_realloc(ypIncludes, sizeof(IncludeFile)*newSize);
maxYpIncludes= newSize;
}
if (fullparse) ClearSourceList(name);
ypIncludes[nYpIncludes].file= file;
ypIncludes[nYpIncludes].filename= name;
ypIncludes[nYpIncludes].lastLineRead= 0;
ypIncludes[nYpIncludes++].index = -1;
prevErrLine= -1;
return file;
}
static void
y_add_line(char *line)
{
y_line_t *yline = p_malloc(sizeof(y_line_t));
if (yline) {
yline->next = 0;
yline->line = p_strcpy(line);
if (y_ltail) {
y_ltail->next = yline;
y_ltail = yline;
} else {
y_lhead = y_ltail = yline;
}
}
}
void
y_push_include(p_file *file, const char *filename)
{
if (nYpIncludes >= maxYpIncludes) {
int newSize = maxYpIncludes + 4;
ypIncludes = p_realloc(ypIncludes, sizeof(IncludeFile)*newSize);
maxYpIncludes = newSize;
}
ypIncludes[nYpIncludes].file = file;
ypIncludes[nYpIncludes].filename = p_strcpy(filename);
ypIncludes[nYpIncludes].lastLineRead = 0;
ypIncludes[nYpIncludes++].index = -1;
prevErrLine= -1;
}
void
Y_timestamp(int argc)
{
time_t n_time = time((void *)0);
char *time = ctime(&n_time);
long index = yget_ref(0);
if (argc != 1) y_error("timestamp takes exactly one argument");
if (index >= 0) {
ypush_long((long)n_time);
yput_global(index, 0);
}
if (!yarg_subroutine()) {
char **q = ypush_q(0);
q[0] = p_strcpy(strtok(time, "\n"));
}
}
struct list_t *
config_read_list(FILE *in)
{
struct list_t *list = list_init();
if(fgetc(in)!='{') {
fprintf(stderr,"Error parsing value for key: '%s'\n",key);
return NULL;
}
while(fgetc(in)!='\n');
fscanf(in,"%s",value);
while(strcmp(value,"}")) {
list_add(list,p_strcpy(value));
fscanf(in,"%s",value);
}
fgetc(in);
return list;
}
static long StringConstant(char *string)
{
Array *array;
long i;
for (i=0 ; i<nConstants ; i++) {
if (constantTable[i].ops==&dataBlockSym) {
array= (Array*)constantTable[i].value.db;
if (strcmp(array->value.q[0], string)==0) break;
}
}
if (i>=nConstants) {
if (CheckConstSpace()) return 0;
array= NewArray(&stringStruct, (Dimension *)0);
constantTable[nConstants].ops= &dataBlockSym;
constantTable[nConstants].index= 0;
constantTable[nConstants++].value.db= (DataBlock *)array;
array->value.q[0]= p_strcpy(string);
} else {
constantTable[i].index++;
}
return i;
}
psckt_t *
psckt_accept(psckt_t *listener, char **ppeer, void *ctx, psckt_cb_t *callback)
{
struct sockaddr_storage sad;
socklen_t lsad = sizeof(struct sockaddr_storage);
struct sockaddr *psad = (struct sockaddr *)&sad;
char host[NI_MAXHOST];
psckt_t *sock = p_malloc(sizeof(psckt_t));
SOCKET sfd, lfd = sock->fd;
*ppeer = 0;
if (listener->peer || !sock) { /* listeners have no peer */
if (sock) p_free(sock);
return 0;
}
if (listener->callback && listener->waiting) {
if (WaitForSingleObject(listener->ready, INFINITE) != WAIT_OBJECT_0)
psckt_stop_thread(listener);
listener->waiting = 0;
if (listener->ready != INVALID_HANDLE_VALUE)
ResetEvent(listener->ready);
}
sfd = accept(listener->fd, psad, &lsad);
if (sfd==INVALID_SOCKET ||
getnameinfo(psad, lsad, host, NI_MAXHOST, 0, 0, 0)) {
closesocket(sfd);
p_free(sock);
return 0;
}
sock->fd = sfd;
sock->peer = *ppeer = p_strcpy(host);
return psckt_setup(sock, ctx, callback);
}
static void
x_analyze(x_display *xdpy, int fam)
{
int i, j, n, face, pixsize, nsizes;
char *name;
if (tmp_fonts) tmp_free();
tmp_fonts = XListFonts(xdpy->dpy, pattern[((unsigned int)fam)>>2], 1024, &n);
for (i=0 ; i<n ; i++) {
name = x_face(tmp_fonts[i], &face);
if (!name) continue;
/* extract pixels field */
pixsize = 0;
if (name[0]!='*') while (name[0] && name[0]>='0' && name[0]<='9')
pixsize = 10*pixsize + *(name++) - '0';
else
name++;
if (name[0]!='-') continue;
/* protect against superlong font names */
if (!pixsize && strlen(tmp_fonts[i])>120) continue;
face += fam;
nsizes = xdpy->available[face].nsizes;
if (x_lookup(pixsize, xdpy->available[face].sizes, nsizes)) continue;
if (nsizes%12==0) {
int *sizes = xdpy->available[face].sizes;
char **names = xdpy->available[face].names;
xdpy->available[face].sizes = p_realloc(sizes, sizeof(int)*(nsizes+12));
if (!xdpy->available[face].sizes) {
xdpy->available[face].sizes = sizes;
return;
}
xdpy->available[face].names = p_realloc(names,sizeof(char*)*(nsizes+13));
if (!xdpy->available[face].names) {
xdpy->available[face].names = names;
return;
}
}
j = x_insert(pixsize, xdpy->available[face].sizes,
xdpy->available[face].names, nsizes);
xdpy->available[face].nsizes++;
if (pixsize) {
xdpy->available[face].names[j] = p_strcpy(tmp_fonts[i]);
} else {
/* scalable font needs wildcard name */
char nm[128], *pnm = nm;
int n = 7;
name = tmp_fonts[i];
while (n--) while ((*(pnm++)= *(name++))!='-');
/* skip over pixels, points fields */
*(pnm++)= '*'; *(pnm++)= '-'; *(pnm++)= '*'; *(pnm++)= '-';
for (n=2 ; n-- ;) while (name[0] && *(name++)!='-');
/* copy hres, vres, spacing fields */
for (n=3 ; n-- ;) while (name[0] && (*(pnm++)= *(name++))!='-');
/* skip over average width field */
*(pnm++)= '*'; *(pnm++)= '-';
while (name[0] && *(name++)!='-');
/* copy remainder (character set fields) */
while ((*(pnm++)= *(name++)));
xdpy->available[face].names[j] = p_strcpy(nm);
}
}
tmp_free();
}
void
Y_spawn(int nargs)
{
Dimension *dims = 0;
char **argv = yarg_q(nargs-1, &dims);
long argc = 1;
Operand op;
Operand *pop = yarg_op(nargs-2, &op);
long callout=-1, callerr=-1;
spawn_proc *proc;
if (nargs<2 || nargs>3)
YError("spawn: accepts precisely two or three arguments");
if (dims) {
if (dims->next)
YError("spawn: first argument must be string or 1D array of strings");
argc = dims->number;
}
if (!argv || !argv[0] || !argv[0][0])
YError("spawn: first element of first argument must be process name");
if (!pop || (op.ops!=&functionOps && op.ops!=&builtinOps))
YError("spawn: second argument must be callback function");
if (op.ops==&builtinOps) callout = ((BIFunction *)op.value)->index;
else callout = ((Function *)op.value)->code[0].index;
if (nargs == 3) {
pop = yarg_op(0, &op);
if (!pop || (op.ops!=&functionOps && op.ops!=&builtinOps))
YError("spawn: third argument must be callback function");
if (op.ops==&builtinOps) callerr = ((BIFunction *)op.value)->index;
else callerr = ((Function *)op.value)->code[0].index;
}
if (argv[argc-1]) {
/* must construct a 0-terminated argv list */
typedef struct tmpobj {
int references;
Operations *ops;
void (*zapper)(void *to);
char *argv[1];
} tmpobj;
tmpobj *tmp;
long i;
/* CheckStack(2); fnctn.c guarantees at least 2 free stack slots */
tmp = PushDataBlock(y_new_tmpobj(sizeof(tmpobj)+argc*sizeof(char*),
p_free));
for (i=0 ; i<argc ; i++) tmp->argv[i] = argv[i];
tmp->argv[i] = 0;
argv = tmp->argv;
/* tmp will be cleaned up when stack cleared */
}
/* push result object onto stack */
proc = p_malloc(sizeof(spawn_proc));
proc->references = 0;
proc->ops = &spawn_ops;
proc->proc = p_spawn(argv[0], argv, spawn_callback, proc, callerr>=0);
proc->argv0 = p_strcpy(argv[0]);
proc->callout = callout;
proc->callerr = callerr;
proc->next = spawn_list;
spawn_list = proc;
PushDataBlock(proc);
if (!proc->proc) {
Drop(1);
PushDataBlock(RefNC(&nilDB));
}
if (!spawn_setclean) {
spawn_setclean = 1;
spawn_prevclean = CleanUpForExit;
CleanUpForExit = spawn_cleanup;
}
}
void
gy_value_push(GValue * pval, GITypeInfo * info, gy_Object* o)
{
GITypeTag tag = g_type_info_get_tag(info);
GY_DEBUG("Pushing %s from GValue\n", g_type_tag_to_string(tag));
switch (tag) {
/* basic types */
case GI_TYPE_TAG_VOID:{
GITypeInfo * cellinfo = g_type_info_get_param_type(info, 0);
if (cellinfo) {
GITypeTag ctag = g_type_info_get_tag(cellinfo);
GY_DEBUG("void contains %s\n", g_type_tag_to_string(ctag));
g_base_info_unref(cellinfo);
}
ypush_nil();
break;}
case GI_TYPE_TAG_BOOLEAN:
*ypush_c(NULL) = g_value_get_boolean(pval);
break;
case GI_TYPE_TAG_INT8:
*ypush_gint8(NULL) = g_value_get_schar(pval);
break;
case GI_TYPE_TAG_UINT8:
*ypush_guint8(NULL)= g_value_get_uchar(pval);
break;
case GI_TYPE_TAG_INT16:
case GI_TYPE_TAG_INT32:
*ypush_gint32(NULL) = g_value_get_int(pval);
break;
case GI_TYPE_TAG_UINT16:
case GI_TYPE_TAG_UINT32:
*ypush_guint32(NULL) = g_value_get_uint(pval);
break;
case GI_TYPE_TAG_INT64:
ypush_long(g_value_get_int64(pval));
break;
case GI_TYPE_TAG_UINT64:
ypush_long(g_value_get_uint64(pval));
break;
case GI_TYPE_TAG_FLOAT:
*ypush_f(NULL)=g_value_get_float(pval);
break;
case GI_TYPE_TAG_DOUBLE:
ypush_double(g_value_get_double(pval));
break;
case GI_TYPE_TAG_GTYPE:
ypush_long(g_value_get_gtype(pval));
break;
case GI_TYPE_TAG_UTF8:
case GI_TYPE_TAG_FILENAME:
*ypush_q(NULL) = p_strcpy(g_value_get_string(pval));
break;
/* array types */
case GI_TYPE_TAG_ARRAY:
y_error("array");
break;
/* interface types */
case GI_TYPE_TAG_INTERFACE:
{
GIBaseInfo * itrf = g_type_info_get_interface (info);
switch(g_base_info_get_type (itrf)) {
case GI_INFO_TYPE_ENUM:
ypush_long(g_value_get_enum(pval));
g_base_info_unref(itrf);
break;
case GI_INFO_TYPE_OBJECT:
{
GObject * prop=g_value_get_object(pval);
g_object_ref_sink(prop);
if (!prop) {
g_base_info_unref(itrf);
y_error("get property failed");
}
GY_DEBUG("pushing result... ");
ypush_check(1);
gy_Object * out = ypush_gy_Object();
out->info=itrf;
out->object=prop;
out->repo=o->repo;
}
break;
default:
g_base_info_unref(itrf);
y_error ("fix me: only properties of type object supported yet");
}
break;
}
default:
y_error("Unimplemented");
}
}
static unsigned int
readhead(T_HD *hp, unsigned char *ptr, unsigned int slen)
{
struct headline hd;
unsigned int len
= (*ptr == '!') ? decline_7((unsigned char *)&hd, ptr, slen) :
decline_8((unsigned char *)&hd, ptr, slen);
/* 上のちょっと危ないぞ */
if(len > 60 && crc_check(0xffff, (unsigned char *)&hd, len) == 0x1d0f) {
unsigned int i;
unsigned char *s, *p;
/* memclr( sizeof(T_HD), hp );*/
timecpy(&hp->fsize, (unsigned int *)hd.fs); /* 危ないかも WDN */
if((int)(hp->vol = hd.volume)) {
timecpy(&hp->volsize, (unsigned int *)hd.vbyte); /* 危かも WDN */
hp->fsize= (hp->volsize*hd.volume > hp->fsize ?
hp->fsize-(hp->volsize*(hd.volume-1)) : hp->volsize);
}
hp->byte= hd.line[0]+(hd.line[1]<<8);
hp->tcrc= (hd.crc16[0]<<8)+hd.crc16[1];
hp->body= hp->byte-3;
hp->blockbyte= hp->body*hp->body;
hp->date= hp->perm= 0;
if( hd.flag & 1 )
timecpy(&hp->date, (unsigned int *)hd.date); /* 危かも WDN */
hp->initflag= TRUE;
hp->exec= ztype[hp->ztype= ishbit2z[hd.ishbit]].decexec;
hp->block= hp->fsize/hp->blockbyte +1;
hp->fsize+= 2;
hp->dline= hp->fsize/hp->body+1;
for( i= 0, s= hp->fname, p= hd.node ; *p != ' ' && i<8 ; i++ )
*s++= *p++;
if( *hd.ext != ' ' )
for( *s++= '.', i= 0, p= hd.ext ; *p!=' '&&i<3 ; i++ )
*s++= *p++;
*s= '\0';
if( !(hp->mode & mADJNAME) ) {
unsigned int ic;
for( ic= 0, s= hp->fname, p= hp->adjname ;
*s && *s == *p && ic<8 ; s++, p++, ic++ );
if( (!*s || *s == '.' || ic == 8) && *p )
p_strcpy( hp->fname, hp->adjname );
}
/* debug */
{
if( !(hp->mode & mLIST) ) {
Merr( (char *)hp->fname );
Merrch( '(' );
Numerr( hp->fsize-2 );
if( hd.volume ) {
Merrch( '/' );
Numerr( hd.volume );
}
Merrch( ')' );
} else {
char buf[28];
Mprint( (char *)hp->fname );
Mputchar( ' ' );
Mputchar( '(' );
Numput( hp->fsize-2 );
if( hd.volume ) {
Mputchar( '/' );
Numput( hd.volume );
}
Mputchar( ')' );
Mputchar( ' ' );
DATESTR(
((hp->date & 0xfe000000)>>9)+
((hp->date & 0x01e00000)>>13)+
((hp->date & 0x001f0000)>>16)+
0x27bc0000
, buf );
Mprint( buf );
Mputchar( ' ' );
TIMESTR(
((hp->date & 0x0000f800)<<5)+
((hp->date & 0x000007e0)<<3)+
((hp->date<<1) & 0x3e)
, buf );
Mprint( buf );
Mputchar( ' ' );
Mprint( (char *)ztype[hp->ztype].name );
Mprint( " os:" );
Numput( hd.os );
#if 0
if( hd.flag & 12 ) {
unsigned i,j;
i= (hd.crc16[0]<<8)+hd.crc16[1];
timecpy( &j, hd.crc32 );
if( filecrc( hp->fname, i, j ) ) {
Mprint( "<crcOK!>" );
}
}
#endif
Mprint( " line:" );
}
}
return TRUE;
}
static void push_string(const char* str)
{
ypush_q(NULL)[0] = p_strcpy(str);
}
void matscan(FILE *fs, int maxVarsToSearch, int returnString)
{
int info[5];
long i;
long fileptr,tfileptr,tfp;
long nbyt=0,nelem,skip;
int type;
int mrows,mcols;
int imagf;
int namelen;
long varNumber = 0;
char varname[80];
char *stype="";
int varnum=0;
Array *a= PushDataBlock(NewArray(&stringStruct, (Dimension *)0));
long extra=1;
fileptr = ftell(fs);
if (DEBUG) printf("Entering matscan\n");
while (1) {
tfileptr = ftell(fs);
if (DEBUG) printf("at address %ld \n",tfileptr);
if (fread(info,4,5,fs)==5) {
if (info[4] & 0xffff0000) { // convert header from little endian to big indian
// info[0] changed to info[4] 2006/3/15 as double type can be 0, hence
// no way to know big from little endian info[0] for doubles.
if (DEBUG) printf("swapping!\n");
for (i=0;i<5;i++) SWAP_INT(info[i]);
}
info[0] = info[0]%1000;
tfp = ftell(fs);
if (DEBUG) printf("at address %ld \n",tfp);
if (DEBUG) printf("info = %d %d %d %d %d\n",info[0],info[1],info[2],info[3],info[4]);
type = info[0]%1000;
if ((namelen = info[4])<80L) {
if (fread(varname,1,info[4],fs)==(int)info[4]) {
if (type==0) {
// 8-byte doubles
stype=p_strcpy("double*8"); nbyt=8;
} else if (type==10) {
// 4-byte reals
stype=p_strcpy("real*4 "); nbyt=4;
} else if ((type==120) || (type==20)) {
// 4-byte int
stype=p_strcpy("int*4 "); nbyt=4;
} else if (type==30) {
// 2-byte signed (30) shorts
stype=p_strcpy("short*2 "); nbyt=2;
} else if (type==40) {
// 2-byte unsigned (40) shorts
stype=p_strcpy("ushort*2"); nbyt=2;
} else if ((type==50) || (type==51)) {
// 1-byte signed or unsigned chars (50) or text (51)
stype=p_strcpy("char*1 "); nbyt=1;
} else {
sprintf(message,"Unknown data type %d",type);
YError(message);
}
if (returnString) {
if (varnum!=0) a= PushDataBlock((void *)GrowArray(a, extra));
a->value.q[varnum] = p_malloc(81);
sprintf(a->value.q[varnum],"%30s %s array [%d,%d]",varname, \
stype,info[1],info[2]);
varnum++;
} else {
printf("%30s %s array [%d,%d]\n",varname,stype,info[1],info[2]);
}
mrows=info[1];
mcols=info[2];
nelem=mrows*mcols;
imagf=info[3];
if (imagf) nbyt=2*nbyt;
skip = nbyt*nelem;
if (DEBUG) printf("skiping data part: %ld bytes\n",skip);
if (skip) fseek(fs,nbyt*nelem,SEEK_CUR);
}
}
} else {
break;
}
if (maxVarsToSearch) {
if (++varNumber >= maxVarsToSearch) {
break;
}
}
}
}
void Y_get_addrs(int nArgs)
{
IOStream *file, *child;
Array *array;
long *pAddrs= 0, *cAddrs= 0, *rAddrs= 0;
int *rFiles= 0;
char **rNames= 0;
long i, nParent, nChild, nFamily, nRecords;
HistoryInfo *history;
Dimension *dims;
if (nArgs!=1) YError("get_addrs takes exactly one argument");
file= yarg_file(0);
history= file->history;
child= history? history->child : 0;
/* create result array */
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(5L, 1L, (Dimension *)0);
array= PushDataBlock(NewArray(&pointerStruct, tmpDims));
nParent= file->dataTable.nItems;
nChild= child? child->dataTable.nItems : 0;
nRecords= child? history->nRecords : 0;
nFamily= child? history->nFamily : 0;
if (nParent) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nParent, 1L, (Dimension *)0);
array->value.p[0]= pAddrs= NewArray(&longStruct, tmpDims)->value.l;
}
if (nChild) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nChild, 1L, (Dimension *)0);
array->value.p[1]= cAddrs= NewArray(&longStruct, tmpDims)->value.l;
}
if (nRecords>0) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nRecords, 1L, (Dimension *)0);
array->value.p[2]= rAddrs= NewArray(&longStruct, tmpDims)->value.l;
array->value.p[3]= rFiles= NewArray(&intStruct, tmpDims)->value.i;
}
if (nFamily>0) {
dims= tmpDims;
tmpDims= 0;
FreeDimension(dims);
tmpDims= NewDimension(nFamily, 1L, (Dimension *)0);
array->value.p[4]= rNames= NewArray(&stringStruct, tmpDims)->value.q;
}
/* and fill it */
for (i=0 ; i<nParent ; i++) pAddrs[i]= file->addresses[i]+file->offset;
for (i=0 ; i<nChild ; i++) cAddrs[i]= child->addresses[i];
for (i=0 ; i<nRecords ; i++) rAddrs[i]= history->offset[i];
for (i=0 ; i<nRecords ; i++) rFiles[i]= history->ifile[i];
for (i=0 ; i<nFamily ; i++) rNames[i]= p_strcpy(history->famNames[i]);
}
void
Y_lsdir(int nArgs)
{
Symbol *stack = sp-nArgs+1;
Symbol *glob = 0;
Dimension *dims;
y_dirlist *dlist;
char *name, **list;
long i;
int is_dir = 0;
if (nArgs<1 || nArgs>2) YError("lsdir takes one or two arguments");
if (nArgs==2) {
if (!stack->ops || sp->ops!=&referenceSym)
YError("lsdir second argument not simple variable reference");
glob = &globTab[sp->index];
sp--;
}
dlist = y_new_tmpobj(sizeof(y_dirlist), y_zap_dirlist);
dlist->dir = 0;
dlist->fils = dlist->subs = 0;
dlist->nfils = dlist->nsubs = 0;
PushDataBlock(dlist);
name = YGetString(stack);
if (!name)
YError("first argument to lsdir must be a non-nil scalar string");
dlist->dir = p_dopen(name);
if (!dlist->dir) {
Drop(1);
PushLongValue(0);
return;
}
while ((name = p_dnext(dlist->dir, &is_dir))) {
if (is_dir && nArgs==2)
y_add_item(&dlist->subs, &dlist->nsubs, p_strcpy(name));
else
y_add_item(&dlist->fils, &dlist->nfils, p_strcpy(name));
}
if (stack->ops==&dataBlockSym) {
stack->ops = &intScalar;
Unref(stack->value.db);
}
if (dlist->nfils) {
char *nm;
dims = tmpDims;
tmpDims = 0;
FreeDimension(dims);
tmpDims = NewDimension(dlist->nfils, 1L, (Dimension *)0);
stack->value.db = (DataBlock *)NewArray(&stringStruct, tmpDims);
stack->ops = &dataBlockSym;
list = ((Array *)stack->value.db)->value.q;
for (i=0 ; i<dlist->nfils ; i++) {
nm = dlist->fils[i];
dlist->fils[i] = 0;
list[i] = nm;
}
list = dlist->fils;
dlist->fils = 0;
p_free(list);
} else {
stack->value.db = (DataBlock *)(RefNC(&nilDB));
stack->ops = &dataBlockSym;
}
if (glob) {
if (glob->ops==&dataBlockSym) {
glob->ops = &intScalar;
Unref(glob->value.db);
}
if (dlist->nsubs) {
char *nm;
dims = tmpDims;
tmpDims = 0;
FreeDimension(dims);
tmpDims = NewDimension(dlist->nsubs, 1L, (Dimension *)0);
glob->value.db = (DataBlock *)NewArray(&stringStruct, tmpDims);
glob->ops = &dataBlockSym;
list = ((Array *)glob->value.db)->value.q;
for (i=0 ; i<dlist->nsubs ; i++) {
nm = dlist->subs[i];
dlist->subs[i] = 0;
list[i] = nm;
}
list = dlist->subs;
dlist->subs = 0;
p_free(list);
} else {
glob->value.db = (DataBlock *)(RefNC(&nilDB));
glob->ops = &dataBlockSym;
}
}
Drop(1);
}
/* modified main calls mpy_on_launch instead of on_launch */
int
mpy_on_launch(int argc, char *argv[])
{
/* codger creates yinit.c:on_launch, which calls std0.c:y_launch */
char *txt;
int ret;
mpy_initialize(&argc, &argv);
if (!mpy_size) return on_launch(argc, argv);
/* on_launch is collective operation, because it queries filesystem
* to find path for .i files
*/
if (!mpy_rank) {
long i;
/* broadcast yLaunchDir, ySiteDir, yHomeDir, defaultPath */
long dims[2];
int batflag = (argc>1) && !strcmp(argv[1],"-batch");
/* lie about arguments for startup, will put back command line later */
ret = on_launch(batflag?2:(argc?1:0), argv);
if (batflag) {
if (argc > 2) {
/* mpy_initialize already saved -batch script name */
for (i=3 ; i<argc ; i++) argv[i-2] = argv[i];
argc -= 2;
} else {
argc = 1;
}
}
/* now that on_launch/y_launch done, put back true command line */
ym_argc = argc;
ym_argv = argv;
dims[0] = 1;
dims[1] = STRLEN_P_1(yLaunchDir) + STRLEN_P_1(ySiteDir)
+ STRLEN_P_1(yHomeDir) + STRLEN_P_1(y_user_dir) + STRLEN_P_1(y_gist_dir);
ypush_check(1); /* we are outside any interpreted function */
txt = ypush_c(dims);
STRCPY_TXT(yLaunchDir);
STRCPY_TXT(ySiteDir);
STRCPY_TXT(yHomeDir);
STRCPY_TXT(y_user_dir);
STRCPY_TXT(y_gist_dir);
mpy_bcast(1);
} else {
extern void Y_set_site(int);
/* need to call on_launch to initialize interpreter for mpy_bcast */
ret = on_launch(2, mpy_fake_argv);
mpy_bcast(1);
txt = ygeta_c(0, (long *)0, (long *)0);
if (!txt[0]) txt++, yLaunchDir = 0;
else yLaunchDir = p_strcpy(txt), txt += strlen(txt)+1;
if (!txt[0]) txt++, ySiteDir = 0;
else ySiteDir = p_strcpy(txt), txt += strlen(txt)+1;
if (!txt[0]) txt++, yHomeDir = 0;
else yHomeDir = p_strcpy(txt), txt += strlen(txt)+1;
if (!txt[0]) txt++, y_user_dir = 0;
else y_user_dir = p_strcpy(txt);
if (!txt[0]) txt++, y_gist_dir = 0;
else y_gist_dir = p_strcpy(txt);
Y_set_site(0);
}
yarg_drop(1);
/* after on_launch, virtual machine initialized, startup .i files
* (including mpy.i) are queued by name but not yet opened, and
* batch mode has been set if -batch argv
*/
/* replace on_include with parallel version, set parallel flag */
ycall_on_include(mpy_on_include);
mpy_parallel = 1;
/* disable autoload */
if (!mpy0_eval_auto) {
mpy0_eval_auto = auto_ops.Eval;
auto_ops.Eval = mpy_eval_auto;
}
return ret;
}