OP *
Perl_refkids(pTHX_ OP *o, I32 type)
{
if (o && o->op_flags & OPf_KIDS) {
OP *kid;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
doref(kid, type, TRUE);
}
return o;
}
OP *
Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
{
dVAR;
OP *kid;
PERL_ARGS_ASSERT_DOREF;
if (!o || (PL_parser && PL_parser->error_count))
return o;
switch (o->op_type) {
case OP_ENTERSUB:
break;
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
doref(kid, type, set_op_ref);
break;
case OP_RV2SV:
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
doref(cUNOPo->op_first, o->op_type, set_op_ref);
/* FALL THROUGH */
case OP_PADSV:
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
: type == OP_RV2HV ? OPpDEREF_HV
: OPpDEREF_SV);
o->op_flags |= OPf_MOD;
}
break;
case OP_RV2CV:
o->op_flags |= OPf_SPECIAL;
break;
case OP_RV2AV:
case OP_RV2HV:
if (set_op_ref)
o->op_flags |= OPf_REF;
/* FALL THROUGH */
case OP_RV2GV:
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
doref(cUNOPo->op_first, o->op_type, set_op_ref);
break;
case OP_ANONARRAY:
case OP_ANONHASH:
if (set_op_ref)
o->op_flags |= OPf_REF;
break;
case OP_SCALAR:
case OP_NULL:
if (!(o->op_flags & OPf_KIDS))
break;
doref(cBINOPo->op_first, type, set_op_ref);
break;
case OP_AELEM:
case OP_HELEM:
doref(cBINOPo->op_first, o->op_type, set_op_ref);
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
: type == OP_RV2HV ? OPpDEREF_HV
: OPpDEREF_SV);
o->op_flags |= OPf_MOD;
}
break;
case OP_SCOPE:
case OP_LEAVE:
set_op_ref = FALSE;
/* FALL THROUGH */
case OP_ENTER:
case OP_LIST:
case OP_LISTLAST:
if (!(o->op_flags & OPf_KIDS))
break;
doref(cLISTOPo->op_last, type, set_op_ref);
break;
case OP_LISTFIRST:
if (!(o->op_flags & OPf_KIDS))
break;
doref(cLISTOPo->op_first, type, set_op_ref);
break;
default:
break;
}
return scalar(o);
}
OP *
Perl_mod(pTHX_ OP *o, I32 type)
{
dVAR;
OP **tokid;
/* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
int localize = -1;
if (!o || (PL_parser && PL_parser->error_count))
return o;
if ((o->op_flags & OPf_TARGET_MY)
&& (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
{
return o;
}
switch (o->op_type) {
case OP_UNDEF:
localize = 0;
return o;
case OP_STUB:
if ((o->op_flags & OPf_PARENS) || PL_madskills)
break;
goto nomod;
default:
nomod:
/* grep, foreach, subcalls, refgen */
if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_SREFGEN)
break;
Perl_croak_at(aTHX_ o->op_location,
"Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
? "do block"
: OP_DESC(o)),
type ? PL_op_desc[type] : "local");
return o;
case OP_PREINC:
case OP_PREDEC:
case OP_POW:
case OP_MULTIPLY:
case OP_DIVIDE:
case OP_MODULO:
case OP_REPEAT:
case OP_ADD:
case OP_SUBTRACT:
case OP_CONCAT:
case OP_LEFT_SHIFT:
case OP_RIGHT_SHIFT:
case OP_BIT_AND:
case OP_BIT_XOR:
case OP_BIT_OR:
case OP_I_MULTIPLY:
case OP_I_DIVIDE:
case OP_I_MODULO:
case OP_I_ADD:
case OP_I_SUBTRACT:
if (!(o->op_flags & OPf_STACKED))
goto nomod;
break;
case OP_COND_EXPR:
localize = 1;
for (tokid = &(cUNOPo->op_first->op_sibling); *tokid; tokid = &((*tokid)->op_sibling))
*tokid = mod(*tokid, type);
break;
case OP_RV2GV:
/* if (scalar_mod_type(o, type)) */
/* goto nomod; */
doref(cUNOPo->op_first, o->op_type, TRUE);
localize = 1;
break;
case OP_ASLICE:
case OP_HSLICE:
localize = 1;
/* FALL THROUGH */
case OP_NEXTSTATE:
case OP_DBSTATE:
break;
case OP_RV2CV:
case OP_RV2AV:
case OP_RV2HV:
case OP_RV2SV:
doref(cUNOPo->op_first, o->op_type, TRUE);
localize = 1;
/* FALL THROUGH */
case OP_GV:
PL_hints |= HINT_BLOCK_SCOPE;
break;
case OP_SASSIGN:
case OP_ANDASSIGN:
case OP_ORASSIGN:
case OP_DORASSIGN:
break;
case OP_AELEMFAST:
localize = -1;
break;
case OP_EXPAND:
cUNOPo->op_first = mod(cUNOPo->op_first, type);
break;
case OP_DOTDOTDOT:
case OP_PLACEHOLDER:
localize = 0;
break;
case OP_PADSV:
if (!type) /* local() */
Perl_croak(aTHX_ "Can't localize lexical variable %s",
PAD_COMPNAME_PV(o->op_targ));
break;
case OP_MAGICSV:
localize = 1;
if ( type && type != OP_SASSIGN && type != OP_SUBST )
goto nomod;
break;
case OP_PUSHMARK:
localize = 0;
break;
case OP_KEYS:
goto nomod;
break;
case OP_AELEM:
case OP_HELEM:
o = op_mod_assign(
o,
&(cBINOPo->op_first),
type == OP_NULL ? o->op_type : type
);
localize = 1;
break;
case OP_ENTERSUB_SAVE:
o = op_mod_assign(
o,
&(cUNOPo->op_first),
type == OP_NULL ? o->op_type : type
);
localize = 1;
break;
case OP_ENTERSUB:
if ( ! type ) {
/* add localize opcode */
const PADOFFSET po = pad_alloc(OP_SASSIGN, SVs_PADTMP);
o->op_targ = po;
o->op_private |= OPpENTERSUB_SAVEARGS;
o = newUNOP(OP_ENTERSUB_SAVE, 0, scalar(o), o->op_location);
o->op_targ = po;
}
localize = 1;
break;
case OP_SCOPE:
case OP_LEAVE:
case OP_ENTER:
case OP_LINESEQ:
localize = 0;
if (o->op_flags & OPf_KIDS)
cLISTOPo->op_last = mod(cLISTOPo->op_last, type);
break;
case OP_NULL:
localize = 0;
if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
goto nomod;
else if (!(o->op_flags & OPf_KIDS))
break;
if (o->op_targ != OP_LIST) {
cBINOPo->op_first = mod(cBINOPo->op_first, type);
break;
}
/* FALL THROUGH */
case OP_HASHEXPAND:
case OP_ARRAYEXPAND:
case OP_LIST:
localize = 0;
for (tokid = &(cLISTOPo->op_first); *tokid; tokid = &((*tokid)->op_sibling))
*tokid = mod(*tokid, type);
break;
case OP_ANONARRAY:
case OP_ANONHASH:
case OP_ANONSCALAR:
if ( ! type ) {
/* propagate localize */
for (tokid = &(cLISTOPo->op_first); *tokid; tokid = &((*tokid)->op_sibling))
*tokid = mod(*tokid, type);
}
localize = 0;
break;
case OP_LISTLAST:
localize = 0;
if (o->op_flags & OPf_KIDS)
cLISTOPo->op_last = mod(cLISTOPo->op_last, type);
break;
case OP_LISTFIRST:
localize = 0;
if (o->op_flags & OPf_KIDS)
cLISTOPo->op_first->op_sibling = mod(cLISTOPo->op_first->op_sibling, type);
break;
case OP_RETURN:
goto nomod;
break; /* mod()ing was handled by ck_return() */
}
/* [20011101.069] File test operators interpret OPf_REF to mean that
their argument is a filehandle; thus \stat(".") should not set
it. AMS 20011102 */
if (type == OP_SREFGEN &&
PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
return o;
o->op_flags |= OPf_MOD;
if (type == OP_SASSIGN)
o->op_flags |= OPf_SPECIAL|OPf_REF;
else if (!type) { /* local() */
switch (localize) {
case 1:
o->op_private |= OPpLVAL_INTRO;
o->op_flags &= ~OPf_SPECIAL;
PL_hints |= HINT_BLOCK_SCOPE;
break;
case 0:
break;
case -1:
Perl_croak(aTHX_ "Can't localize %s", OP_DESC(o));
}
}
else if (type != OP_GREPSTART && type != OP_ENTERSUB)
o->op_flags |= OPf_REF;
return o;
}
EXTRADECLS
#endif
/*****************************************************************************
* *
* This is a program which illustrates the use of nauty. *
* Commands are read from stdin, and may be separated by white space, *
* commas or not separated. Output is written to stdout. *
* For a short description, see the nauty User's Guide. *
* *
*****************************************************************************/
main()
{
int m,n,newm,newn;
boolean gvalid,ovalid,cvalid,pvalid,minus,prompt,doquot;
int i,worksize,numcells,refcode,umask,qinvar;
int oldorg;
char *s1,*s2,*invarprocname;
int c,d;
register long li;
set *gp;
double timebefore,timeafter;
char filename[100];
graph *savedg;
nvector *savedlab;
int sgn,sgactn,sgorg;
int cgactn,gactn;
curfile = 0;
fileptr[curfile] = stdin;
prompt = DOPROMPT(INFILE);
outfile = stdout;
n = m = 1;
#ifdef INITSEED
INITSEED;
#endif
umask = 0;
pvalid = FALSE;
gvalid = FALSE;
ovalid = FALSE;
cvalid = FALSE;
minus = FALSE;
worksize = 2*MAXM*WORKSIZE;
labelorg = oldorg = 0;
cgactn = sgactn = gactn = 0;
#ifdef DYNALLOC
workspace = (setword*) ALLOCS(WORKSIZE,2*MAXM*sizeof(setword));
ptn = (nvector*) ALLOCS(MAXN,sizeof(nvector));
orbits = (nvector*) ALLOCS(MAXN,sizeof(nvector));
perm = (permutation*) ALLOCS(MAXN,sizeof(permutation));
if (workspace == NILSET || ptn == (nvector*)NULL ||
orbits == (nvector*)NULL || perm == (permutation*)NULL)
{
fprintf(ERRFILE,"ALLOCS failed; reduce MAXN.\n\n");
EXIT;
}
#endif
#ifdef INITIALIZE
INITIALIZE;
#endif
allocg(&g,&lab,&gactn,n);
if (gactn == 0)
{
fprintf(ERRFILE,"ALLOCS failed for g: this shouldn't happen.\n\n");
EXIT;
}
invarprocname = "none";
if (prompt)
{
fprintf(PROMPTFILE,"Dreadnaut version %s.\n",DREADVERSION);
fprintf(PROMPTFILE,"> ");
}
/* Calling dummy routines in nautinv.c, nauty.c and nautil.c causes
those segments to get loaded in various Macintosh variants. This
causes an apparent, but illusory, improvement in the time required
for the first call to nauty(). */
nautinv_null();
nautil_null();
nauty_null();
while (curfile >= 0)
if ((c = getc(INFILE)) == EOF || c == '\004')
{
fclose(INFILE);
--curfile;
if (curfile >= 0)
prompt = DOPROMPT(INFILE);
}
else switch (c)
{
case '\n': /* possibly issue prompt */
if (prompt)
fprintf(PROMPTFILE,"> ");
minus = FALSE;
break;
case ' ': /* do nothing */
case '\t':
#ifndef NLMAP
case '\r':
#endif
case '\f':
break;
case '-': /* remember this for next time */
minus = TRUE;
break;
case '+': /* forget - */
case ',':
case ';':
minus = FALSE;
break;
case '<': /* new input file */
minus = FALSE;
if (curfile == MAXIFILES - 1)
fprintf(ERRFILE,"exceeded maximum input nesting of %d\n\n",
MAXIFILES);
if (!readstring(INFILE,filename))
{
fprintf(ERRFILE,
"missing file name on '>' command : ignored\n\n");
break;
}
if ((fileptr[curfile+1] = fopen(filename,"r")) == NULL)
{
for (s1 = filename; *s1 != '\0'; ++s1) {}
for (s2 = def_ext; (*s1 = *s2) != '\0'; ++s1, ++s2) {}
fileptr[curfile+1] = fopen(filename,"r");
}
if (fileptr[curfile+1] != NULL)
{
++curfile;
prompt = DOPROMPT(INFILE);
if (prompt)
fprintf(PROMPTFILE,"> ");
}
else
fprintf(ERRFILE,"can't open input file\n\n");
break;
case '>': /* new output file */
if ((d = getc(INFILE)) != '>')
ungetc((char)d,INFILE);
if (minus)
{
minus = FALSE;
if (outfile != stdout)
{
fclose(outfile);
outfile = stdout;
}
}
else
{
if (!readstring(INFILE,filename))
{
fprintf(ERRFILE,
"improper file name, reverting to stdout\n\n");
outfile = stdout;
break;
}
OPENOUT(outfile,filename,d=='>');
if (outfile == NULL)
{
fprintf(ERRFILE,
"can't open output file, reverting to stdout\n\n");
outfile = stdout;
}
}
break;
case '!': /* ignore rest of line */
do
c = getc(INFILE);
while (c != '\n' && c != EOF);
if (c == '\n')
ungetc('\n',INFILE);
break;
case 'n': /* read n value */
minus = FALSE;
i = getint(INFILE);
if (i <= 0 || i > MAXN)
fprintf(ERRFILE,
" n can't be less than 1 or more than %d\n\n",MAXN);
else
{
gvalid = FALSE;
ovalid = FALSE;
cvalid = FALSE;
pvalid = FALSE;
n = i;
m = (n + WORDSIZE - 1) / WORDSIZE;
allocg(&g,&lab,&gactn,n);
if (gactn == 0)
{
fprintf(ERRFILE,"can't allocate space for graph\n");
n = m = 1;
break;
}
}
break;
case 'g': /* read graph */
minus = FALSE;
readgraph(INFILE,g,options.digraph,prompt,FALSE,
options.linelength,m,n);
gvalid = TRUE;
cvalid = FALSE;
ovalid = FALSE;
break;
case 'e': /* edit graph */
minus = FALSE;
readgraph(INFILE,g,options.digraph,prompt,gvalid,
options.linelength,m,n);
gvalid = TRUE;
cvalid = FALSE;
ovalid = FALSE;
break;
case 'r': /* relabel graph and current partition */
minus = FALSE;
if (gvalid)
{
allocg(&canong,(nvector**)NULL,&cgactn,n);
if (cgactn == 0)
{
fprintf(ERRFILE,
"can't allocate work space for 'r'\n\n");
break;
}
readperm(INFILE,perm,prompt,n);
relabel(g,(pvalid ? lab : (nvector*)NULL),perm,canong,m,n);
cvalid = FALSE;
ovalid = FALSE;
}
else
fprintf(ERRFILE,"g is not defined\n\n");
break;
case '_': /* complement graph */
minus = FALSE;
if (gvalid)
{
complement(g,m,n);
cvalid = FALSE;
ovalid = FALSE;
}
else
fprintf(ERRFILE,"g is not defined\n\n");
break;
case '@': /* copy canong into savedg */
minus = FALSE;
if (cvalid)
{
allocg(&savedg,&savedlab,&sgactn,n);
if (sgactn == 0)
{
fprintf(ERRFILE,"can`t allocate space for h'\n\n");
break;
}
sgn = n;
for (li = (long)n * (long)m; --li >= 0;)
savedg[li] = canong[li];
for (i = n; --i >= 0;)
savedlab[i] = lab[i];
sgorg = labelorg;
}
else
fprintf(ERRFILE,"h is not defined\n\n");
break;
case '#': /* compare canong to savedg */
if ((d = getc(INFILE)) != '#')
ungetc((char)d,INFILE);
if (cvalid)
{
if (sgactn > 0)
{
if (sgn != n)
fprintf(OUTFILE,
"h and h' have different sizes.\n");
else
{
for (li = (long)n * (long)m; --li >= 0;)
if (savedg[li] != canong[li])
break;
if (li >= 0)
fprintf(OUTFILE,
"h and h' are different.\n");
else
{
fprintf(OUTFILE,
"h and h' are identical.\n");
if (d == '#')
putmapping(OUTFILE,savedlab,sgorg,
lab,labelorg,options.linelength,n);
}
}
}
else
fprintf(ERRFILE,"h' is not defined\n\n");
}
else
fprintf(ERRFILE,"h is not defined\n\n");
break;
case 'j': /* relabel graph randomly */
minus = FALSE;
if (gvalid)
{
allocg(&canong,(nvector**)NULL,&cgactn,n);
if (cgactn == 0)
{
fprintf(ERRFILE,
"can't allocate work space for 'j'\n\n");
break;
}
ranperm(perm,n);
relabel(g,(pvalid ? lab : (nvector*)NULL),perm,canong,m,n);
cvalid = FALSE;
ovalid = FALSE;
}
else
fprintf(ERRFILE,"g is not defined\n\n");
break;
case 'v': /* write vertex degrees */
minus = FALSE;
if (gvalid)
putdegs(OUTFILE,g,options.linelength,m,n);
else
fprintf(ERRFILE,"g is not defined\n\n");
break;
case '%': /* do Mathon doubling operation */
minus = FALSE;
if (gvalid)
{
if (2L * ((long)n + 1L) > MAXN)
{
fprintf(ERRFILE,"n can't be more than %d\n\n",MAXN);
break;
}
newn = 2 * (n + 1);
newm = (newn + WORDSIZE - 1) / WORDSIZE;
allocg(&canong,(nvector**)NULL,&cgactn,n);
if (cgactn == 0)
{
fprintf(ERRFILE,
"can't allocate work space for '%'\n\n");
break;
}
for (li = (long)n * (long)m; --li >= 0;)
canong[li] = g[li];
allocg(&g,&lab,&gactn,newn);
if (gactn == 0)
{
fprintf(ERRFILE,"can't allocate space for graph \n\n");
break;
}
mathon(canong,m,n,g,newm,newn);
m = newm;
n = newn;
cvalid = FALSE;
ovalid = FALSE;
pvalid = FALSE;
}
else
fprintf(ERRFILE,"g is not defined\n\n");
break;
case 's': /* generate random graph */
minus = FALSE;
i = getint(INFILE);
if (i <= 0)
i = 2;
rangraph(g,options.digraph,i,m,n);
gvalid = TRUE;
cvalid = FALSE;
ovalid = FALSE;
break;
case 'q': /* quit */
EXIT;
break;
case '"': /* copy comment to output */
minus = FALSE;
copycomment(INFILE,OUTFILE,'"');
break;
case 'I': /* do refinement and invariants procedure */
if (!pvalid)
unitptn(lab,ptn,&numcells,n);
cellstarts(ptn,0,active,m,n);
#ifdef CPUTIME
timebefore = CPUTIME;
#endif
doref(g,lab,ptn,0,&numcells,&qinvar,perm,active,&refcode,
refine,options.invarproc,
0,0,options.invararg,options.digraph,m,n);
#ifdef CPUTIME
timeafter = CPUTIME;
#endif
fprintf(OUTFILE," %d cell%s; code = %x",
SS(numcells,"","s"),refcode);
if (options.invarproc != NILFUNCTION)
fprintf(OUTFILE," (%s %s)",invarprocname,
(qinvar == 2 ? "worked" : "failed"));
#ifdef CPUTIME
fprintf(OUTFILE,"; cpu time = %.2f seconds\n",
timeafter-timebefore);
#else
fprintf(OUTFILE,"\n");
#endif
if (numcells > 1)
pvalid = TRUE;
break;
case 'i': /* do refinement */
if (!pvalid)
unitptn(lab,ptn,&numcells,n);
cellstarts(ptn,0,active,m,n);
if (m == 1)
refine1(g,lab,ptn,0,&numcells,perm,active,&refcode,m,n);
else
refine(g,lab,ptn,0,&numcells,perm,active,&refcode,m,n);
fprintf(OUTFILE," %d cell%s; code = %x\n",
SS(numcells,"","s"),refcode);
if (numcells > 1)
pvalid = TRUE;
break;
case 'x': /* execute nauty */
minus = FALSE;
ovalid = FALSE;
cvalid = FALSE;
if (!gvalid)
{
fprintf(ERRFILE,"g is not defined\n\n");
break;
}
if (pvalid)
{
fprintf(OUTFILE,"[fixing partition]\n");
options.defaultptn = FALSE;
}
else
options.defaultptn = TRUE;
options.outfile = outfile;
if (options.getcanon)
{
allocg(&canong,(nvector**)NULL,&cgactn,n);
if (cgactn == 0)
{
fprintf(ERRFILE,"can't allocate space for h\n\n");
break;
}
}
firstpath = TRUE;
#ifdef CPUTIME
timebefore = CPUTIME;
#endif
nauty(g,lab,ptn,NILSET,orbits,&options,&stats,workspace,
worksize,m,n,canong);
#ifdef CPUTIME
timeafter = CPUTIME;
#endif
if (stats.errstatus != 0)
fprintf(ERRFILE,
"nauty returned error status %d [this can't happen]\n\n",
stats.errstatus);
else
{
if (options.getcanon)
cvalid = TRUE;
ovalid = TRUE;
fprintf(OUTFILE,"%d orbit%s",SS(stats.numorbits,"","s"));
if (stats.grpsize2 == 0)
fprintf(OUTFILE,"; grpsize=%.0f",stats.grpsize1+0.1);
else
{
while (stats.grpsize1 >= 10.0)
{
stats.grpsize1 /= 10.0;
++stats.grpsize2;
}
fprintf(OUTFILE,"; grpsize=%12.10fe%d",
stats.grpsize1,stats.grpsize2);
}
fprintf(OUTFILE,"; %d gen%s",
SS(stats.numgenerators,"","s"));
fprintf(OUTFILE,"; %ld node%s",SS(stats.numnodes,"","s"));
if (stats.numbadleaves)
fprintf(OUTFILE," (%ld bad lea%s)",
SS(stats.numbadleaves,"f","ves"));
fprintf(OUTFILE,"; maxlev=%d\n", stats.maxlevel);
fprintf(OUTFILE,"tctotal=%ld",stats.tctotal);
if (options.getcanon)
fprintf(OUTFILE,"; canupdates=%ld",stats.canupdates);
#ifdef CPUTIME
fprintf(OUTFILE,"; cpu time = %.2f seconds\n",
timeafter-timebefore);
#else
fprintf(OUTFILE,"\n");
#endif
if (options.invarproc != NILFUNCTION &&
options.maxinvarlevel != 0)
{
fprintf(OUTFILE,"invarproc \"%s\" succeeded %ld/%ld",
invarprocname,stats.invsuccesses,stats.invapplics);
if (stats.invarsuclevel > 0)
fprintf(OUTFILE," beginning at level %d.\n",
stats.invarsuclevel);
else
fprintf(OUTFILE,".\n");
}
}
break;
case 'f': /* read initial partition */
if (minus)
{
pvalid = FALSE;
minus = FALSE;
}
else
{
readptn(INFILE,lab,ptn,&numcells,prompt,n);
pvalid = TRUE;
}
break;
case 't': /* type graph */
minus = FALSE;
if (!gvalid)
fprintf(ERRFILE,"g is not defined\n\n");
else
putgraph(OUTFILE,g,options.linelength,m,n);
break;
case 'T': /* type graph preceded by n, $ and g commands */
minus = FALSE;
if (!gvalid)
fprintf(ERRFILE,"g is not defined\n\n");
else
{
fprintf(OUTFILE,"n=%d $=%d g\n",n,labelorg);
putgraph(OUTFILE,g,options.linelength,m,n);
fprintf(OUTFILE,"$$\n");
}
break;
case 'u': /* call user procs */
if (minus)
{
umask = 0;
minus = FALSE;
}
else
{
umask = getint(INFILE);
if (umask < 0)
umask = ~0;
}
if (umask & U_NODE)
options.usernodeproc = NODEPROC;
else
options.usernodeproc = NILFUNCTION;
if (umask & U_AUTOM)
options.userautomproc = AUTOMPROC;
else
options.userautomproc = NILFUNCTION;
if (umask & U_LEVEL)
options.userlevelproc = LEVELPROC;
else
options.userlevelproc = NILFUNCTION;
if (umask & U_TCELL)
options.usertcellproc = TCELLPROC;
else
options.usertcellproc = NILFUNCTION;
if (umask & U_REF)
options.userrefproc = REFPROC;
else
options.userrefproc = NILFUNCTION;
break;
case 'o': /* type orbits */
minus = FALSE;
if (ovalid)
putorbits(OUTFILE,orbits,options.linelength,n);
else
fprintf(ERRFILE,"orbits are not defined\n\n");
break;
case 'b': /* type canonlab and canong */
minus = FALSE;
if (cvalid)
putcanon(OUTFILE,lab,canong,options.linelength,m,n);
else
fprintf(ERRFILE,"h is not defined\n\n");
break;
case 'z': /* type hashcode for canong */
minus = FALSE;
if (cvalid)
fprintf(OUTFILE,"[%8lx %8lx]\n",
hash(canong,(long)m * (long)n,13),
hash(canong,(long)m * (long)n,7));
else
fprintf(ERRFILE,"h is not defined\n\n");
break;
case 'c': /* set getcanon option */
options.getcanon = !minus;
minus = FALSE;
break;
case 'w': /* read size of workspace */
minus = FALSE;
worksize = getint(INFILE);
if (worksize > 2*MAXM*WORKSIZE)
{
fprintf(ERRFILE,
"too big - setting worksize = %d\n\n", 2*MAXM*WORKSIZE);
worksize = 2*MAXM*WORKSIZE;
}
break;
case 'l': /* read linelength for output */
options.linelength = getint(INFILE);
minus = FALSE;
break;
case 'y': /* set tc_level field of options */
options.tc_level = getint(INFILE);
minus = FALSE;
break;
case 'k': /* set invarlev fields of options */
options.mininvarlevel = getint(INFILE);
options.maxinvarlevel = getint(INFILE);
minus = FALSE;
break;
case 'K': /* set invararg field of options */
options.invararg = getint(INFILE);
minus = FALSE;
break;
case '*': /* set invarproc field of options */
minus = FALSE;
d = getint(INFILE);
if (d >= -1 && d <= NUMINVARS-2)
{
options.invarproc = invarproc[d+1].entrypoint;
invarprocname = invarproc[d+1].name;
}
else
fprintf(ERRFILE,"no such vertex-invariant\n\n");
break;
case 'a': /* set writeautoms option */
options.writeautoms = !minus;
minus = FALSE;
break;
case 'm': /* set writemarkers option */
options.writemarkers = !minus;
minus = FALSE;
break;
case 'p': /* set cartesian option */
options.cartesian = !minus;
minus = FALSE;
break;
case 'd': /* set digraph option */
if (options.digraph && minus)
gvalid = FALSE;
options.digraph = !minus;
minus = FALSE;
break;
case '$': /* set label origin */
if ((d = getc(INFILE)) == '$')
labelorg = oldorg;
else
{
ungetc((char)d,INFILE);
oldorg = labelorg;
i = getint(INFILE);
if (i < 0)
fprintf(ERRFILE,"labelorg must be >= 0\n\n");
else
labelorg = i;
}
break;
case '?': /* type options, etc. */
minus = FALSE;
fprintf(OUTFILE,"m=%d n=%d labelorg=%d",m,n,labelorg);
if (!gvalid)
fprintf(OUTFILE," g=undef");
else
{
li = 0;
for (i = 0, gp = g; i < n; ++i, gp += m)
li += setsize(gp,m);
if (options.digraph)
fprintf(OUTFILE," arcs=%ld",li);
else
fprintf(OUTFILE," edges=%ld",li/2);
}
fprintf(OUTFILE," options=(%cc%ca%cm%cp%cd",
PM(options.getcanon),PM(options.writeautoms),
PM(options.writemarkers),PM(options.cartesian),
PM(options.digraph));
if (umask & 31)
fprintf(OUTFILE," u=%d",umask&31);
if (options.tc_level > 0)
fprintf(OUTFILE," y=%d",options.tc_level);
if (options.mininvarlevel != 0 || options.maxinvarlevel != 0)
fprintf(OUTFILE," k=(%d,%d)",
options.mininvarlevel,options.maxinvarlevel);
if (options.invararg > 0)
fprintf(OUTFILE," K=%d",options.invararg);
fprintf(OUTFILE,")\n");
fprintf(OUTFILE,"linelen=%d worksize=%d input_depth=%d",
options.linelength,worksize,curfile);
if (options.invarproc != NILFUNCTION)
fprintf(OUTFILE," invarproc=%s",invarprocname);
if (pvalid)
fprintf(OUTFILE,"; %d cell%s",SS(numcells,"","s"));
else
fprintf(OUTFILE,"; 1 cell");
fprintf(OUTFILE,"\n");
if (OUTFILE != PROMPTFILE)
fprintf(PROMPTFILE,"m=%d n=%d depth=%d labelorg=%d\n",
m,n,curfile,labelorg);
break;
case '&': /* list the partition and possibly the quotient */
if ((d = getc(INFILE)) == '&')
doquot = TRUE;
else
{
ungetc((char)d,INFILE);
doquot = FALSE;
}
minus = FALSE;
if (pvalid)
putptn(OUTFILE,lab,ptn,0,options.linelength,n);
else
fprintf(OUTFILE,"unit partition\n");
if (doquot)
{
if (!pvalid)
unitptn(lab,ptn,&numcells,n);
putquotient(OUTFILE,g,lab,ptn,0,options.linelength,m,n);
}
break;
case 'h': /* type help information */
minus = FALSE;
help(PROMPTFILE);
break;
default: /* illegal command */
fprintf(ERRFILE,"'%c' is illegal - type 'h' for help\n\n",c);
flushline(INFILE);
if (prompt)
fprintf(PROMPTFILE,"> ");
break;
} /* end of switch */
}
int
main(int argc,char **argv) /* process command-line arguments */
{
char line[BUFSIZ], *s;
int nodeflt = 0;
in = stdin;
fo = stdout;
ftemp = stdout;
signals();
while (argc > 1 && argv[1][0] == '-') {
switch(argv[1][1]) {
case 'e':
endpush++;
break;
case 's':
sort++;
endpush = 1;
if (argv[1][2])
keystr = argv[1]+2;
break;
case 'l':
labels++;
s = argv[1]+2;
nmlen = atoi(s);
while (*s)
if (*s++ == ',')
break;
dtlen = atoi(s);
break;
case 'k':
keywant = (argv[1][2] ? argv[1][2] : 'L');
labels++;
break;
case 'n':
nodeflt = 1;
break;
case 'p':
argc--;
argv++;
*search++ = argv[1];
if (search-rdata > NSERCH)
err("too many -p options (%d)", NSERCH);
break;
case 'a':
authrev = atoi(argv[1]+2);
if (authrev<=0)
authrev = 1000;
break;
case 'b':
bare = (argv[1][2] == '1') ? 1 : 2;
break;
case 'c':
smallcaps = argv[1]+2;
break;
case 'f':
refnum = atoi(argv[1]+2) - 1;
break;
case 'B':
biblio++;
bare = 2;
if (argv[1][2])
convert = argv[1]+2;
break;
case 'S':
science++;
labels = 1;
break;
case 'P':
postpunct++;
break;
}
argc--;
argv++;
}
if (getenv("REFER") != NULL)
*search++ = getenv("REFER");
else if (nodeflt == 0)
*search++ = REFDIR "/papers/Ind";
if (sort && !labels) {
sprintf(ofile, "/tmp/rj%db", (int)getpid());
ftemp = fopen(ofile, "w");
if (ftemp == NULL) {
fprintf(stderr, "Can't open scratch file\n");
exit(1);
}
}
if (endpush) {
sprintf(tfile, "/tmp/rj%da", (int)getpid());
fo = fopen(tfile, "w");
if (fo == NULL) {
fo = ftemp;
fprintf(stderr, "Can't open scratch file");
}
sep = 002; /* separate records without confusing sort..*/
} else
fo = ftemp;
do {
if (argc > 1) {
fclose(in);
Iline = 0;
in = fopen(Ifile = argv[1], "r");
argc--;
argv++;
if (in == NULL) {
err("Can't read %s", Ifile);
continue;
}
}
while (input(line)) {
Iline++;
if (biblio && *line == '\n')
doref(line);
else if (biblio && Iline == 1 && *line == '%')
doref(line);
else if (!prefix(".[", line))
output(line);
else
doref(line);
}
} while (argc > 1);
if (endpush && fo != NULL)
dumpold();
output("");
if (sort && !labels)
recopy1(ofile);
clfgrep();
cleanup();
return 0;
}
/* ref() is now a macro using Perl_doref;
* this version provided for binary compatibility only.
*/
OP *
Perl_ref(pTHX_ OP *o, I32 type)
{
return doref(o, type, TRUE);
}
