ATerm SSL_setenv(ATerm name, ATerm value, ATerm overwrite)
{
if(!t_is_string(name)) _fail(name);
if(!t_is_string(value)) _fail(value);
if(!ATisInt(overwrite)) _fail(overwrite);
setenv(ATgetName(ATgetSymbol(name)), ATgetName(ATgetSymbol(value)), ATgetInt((ATermInt)overwrite));
return (ATerm)ATempty;
}
ATerm SSL_link(ATerm existingpath, ATerm newpath)
{
if(!t_is_string(existingpath) || !t_is_string(newpath))
_fail(existingpath);
if(link(ATgetName(ATgetSymbol(existingpath)), ATgetName(ATgetSymbol(newpath))) != 0)
_fail(existingpath);
return newpath;
}
ATerm SSL_rename(ATerm oldname, ATerm newname)
{
if(!t_is_string(oldname) || !t_is_string(newname))
_fail(oldname);
if(rename(ATgetName(ATgetSymbol(oldname)),ATgetName(ATgetSymbol(newname))) != 0)
_fail(oldname);
return newname;
}
ATbool ATunifySystem(ATermStack system,ATermSubst sigma) {
/* Solves {system[0]=system[1], ...,system[2n-2]=system[2n-1]}
- returns 0: t1=t2 is not unifiable; sigma is reset.
- returns 1: ATermSubst represents the mgu {X1->t1,..,Xn->tn}
This implements the Pascal version of Baader/Nipkow.
(Linear space, nearly linear time)
- ATermTable equivalence contains the Union/Find structure
- ATermStack assigned contains the domain of the solution
First, the system is solved without occur-check
Subsequently, a substitution is computed, with loop detection.
*/
static char first_call = 1;
char unifiable = 1;
if (first_call) {
first_call=0;
assigned = ATstackCreate(40);
equivalence = ATtableCreate(40,40);
}
assert((!sigma) || (ATstackDepth(sigma)==0));
assert(ATstackDepth(assigned)==0);
assert(ATisEmpty(ATtableKeys(equivalence)));
while (ATstackDepth(system)>0) {
ATerm t1=find(ATstackPop(system));
ATerm t2=find(ATstackPop(system));
int i,n;
if (t1==t2) continue;
if (ATisVariable(t2))
{ ATerm t3=t1; t1=t2; t2=t3; }
if (ATisVariable(t1)) {
ATstackPush(assigned,t1);
ATtablePut(equivalence,t1,t2);
/* ATprintf("%t->%t\n",t1,t2); */
}
else { /* both t1 and t2 start with function symbol. */
Symbol s1 = ATgetSymbol(t1);
Symbol s2 = ATgetSymbol(t2);
if (s1!=s2) {
unifiable=0;
break;
}
else {
n = ATgetArity(s1);
ATtablePut(equivalence,t1,t2); /* note: forget about cardinality */
for (i=0;i<n;i++) {
ATstackPush(system,ATgetArgument(t1,i));
ATstackPush(system,ATgetArgument(t2,i));
} } } }
if (unifiable) return unfold_solution(sigma);
else {
ATstackReset(system);
ATstackReset(assigned);
ATtableReset(equivalence);
return ATfalse;
} }
void CAESAR_PRINT_LABEL(CAESAR_TYPE_FILE f,CAESAR_TYPE_LABEL l) {
/* fprintf(stderr,"CAESAR_PRINT_LABEL\n"); */
if (l->label==MCRLterm_tau)
fprintf(f,"i");
else
fprintf(f,"\"%s\"",ATgetName(ATgetSymbol(l->label)));
}
void CAESAR_PRINT_STATE_HEADER(CAESAR_TYPE_FILE fp) {
ATerm l = (ATerm)MCRLgetListOfPars();
ATerm v,s;
while (ATmatch(l,"[v(<term>,<term>),<list>]",
&v,&s,&l))
ATfprintf(fp,"%t:%s \n",MCRLprint(v),ATgetName(ATgetSymbol(s)));
}
static ATerm unfold_rec(ATerm t) {
/* Completely unfolds t according to equivalence.
invariants:
- loop_detection contains "ancestors" of t
- t is end point of find
- solution contains correct results [t -> s]
returns NULL: loop detected
returns s: s is unfolding of t.
*/
ATerm s;
ATbool no_loop;
char unifiable=1;
if (ATisVariable(t)) return t;
if ((s=ATtableGet(solution,t))) return s;
ATindexedSetPut(loop_detection,t,&no_loop);
if (no_loop) {
Symbol sym = ATgetSymbol(t);
int i,n=ATgetArity(sym);
ATerm *args = (ATerm*)alloca(n*sizeof(ATerm));
for (i=0;i<n;i++)
if (!(args[i] = unfold_rec(find(ATgetArgument(t,i))))) {
unifiable=0;
break;
}
ATindexedSetRemove(loop_detection,t);
if (unifiable) {
s=(ATerm)ATmakeApplArray(sym,args);
ATtablePut(solution,t,s);
return s;
} }
/* here either !no_loop, or !unifiable holds */
return NULL;
}
ATerm SSL_modification_time(ATerm file)
{
struct stat buf;
if(!t_is_string(file)) _fail(file);
stat(ATgetName(ATgetSymbol(file)), &buf);
return (ATerm)ATmakeInt(buf.st_mtime);
}
/**
* Note: mandatory in C89 and C99, not in BSD
*/
ATerm SSL_remove(ATerm pathname)
{
if(!t_is_string(pathname))
_fail(pathname);
if(remove(ATgetName(ATgetSymbol(pathname))) != 0)
_fail(pathname);
return (ATerm) ATempty;
}
/**
* Note: mandatory in C89 and C99
*/
ATerm SSL_getenv(ATerm name)
{
char *value;
if(!t_is_string(name)) _fail(name);
value = getenv(ATgetName(ATgetSymbol(name)));
if(value == NULL) _fail(name);
return (ATerm)ATmakeString(value);
}
FILE *find_file(char *name)
{
char file[1024];
ATermList i;
yyin = NULL;
for(i = includes; !ATisEmpty(i); i = ATgetNext(i)) {
sprintf(file, "%s/%s", ATgetName(ATgetSymbol(ATgetFirst(i))), name);
yyin = fopen(file, "r");
if(yyin) {
sprintf(file_name, "%s", file);
break;
}
}
return yyin;
}
CAESAR_TYPE_STRING CAESAR_STRING_LABEL(CAESAR_TYPE_LABEL l) {
// fprintf(stderr,"CAESAR_STRING_LABEL\n");
char* L;
static char *a = NULL;
static int siz = 0;
if (l->label==MCRLterm_tau)
L="i";
else {
L=ATgetName(ATgetSymbol(l->label));
if (!a || strlen(L)>siz) {
siz = strlen(L);
a = realloc(a, siz+5);
}
sprintf(a,"\"%s\"",L);
return a;
}
return L;
}
static ATbool occurs_rec(ATerm var, ATerm t, ATbool *nonempty) {
/* invariants:
- var doesn't occur in terms in No_occurs
- nonempty iff No_occurs is not empty
*/
ATbool b;
if (var==t) return ATtrue;
else if (ATisVariable(t)) return ATfalse;
else if (*nonempty && ATindexedSetGetIndex(No_occurs,t)>=0) return ATfalse;
else {
int i;
for (i=ATgetArity(ATgetSymbol(t))-1;i>=0;i--)
if (occurs_rec(var, ATgetArgument(t,i),nonempty)) return ATtrue;
}
*nonempty = ATtrue;
ATindexedSetPut(No_occurs,t,&b);
return ATfalse;
}
static ATerm substVar_rec(ATerm t, ATerm var, ATerm s, ATbool *nonempty) {
/* invariants:
- Subst contains pairs (r , r[var := s])
- *nonempty iff Subst is not empty
*/
ATerm r;
if (var == t) return s;
else if (ATisVariable(t)) return t;
else if (*nonempty && (r=ATtableGet(Subst,t))) return r;
else {
Symbol sym = ATgetSymbol(t);
int i,n=ATgetArity(sym);
ATerm* args = (ATerm*)alloca(n*sizeof(ATerm));
for (i=0;i<n;i++)
args[i]=substVar_rec(ATgetArgument(t,i),var,s,nonempty);
r = (ATerm)ATmakeApplArray(sym,args);
*nonempty=ATtrue;
ATtablePut(Subst,t,r);
return r;
}
}
ATerm SSL_readdir(ATerm t)
{
DIR *dir = NULL;
ATermList entries = ATempty;
struct dirent *entry = NULL;
if(!t_is_string(t))
_fail(t);
dir = opendir(ATgetName(ATgetSymbol(t)));
if(dir == NULL)
_fail(t);
while((entry = readdir(dir)) != NULL)
{
entries = ATinsert(entries, ATmakeString(entry->d_name));
}
closedir(dir);
return (ATerm) entries;
}
static ATerm substitute_rec(ATerm t, ATermSubst sigma, ATbool *nonempty) {
/* invariants:
- Subst contains pairs (r , r^sigma)
- *nonempty iff Subst is not empty
*/
ATerm s;
if (ATisVariable(t)) {
s=ATstackGet(sigma,ATgetInt((ATermInt)t));
return (s ? s : t);
}
else if (*nonempty && (s=ATtableGet(Subst,t)))
return s;
else {
Symbol sym = ATgetSymbol(t);
int i,n=ATgetArity(sym);
ATerm* args = (ATerm*)alloca(n*sizeof(ATerm));
for (i=0;i<n;i++)
args[i]=substitute_rec(ATgetArgument(t,i),sigma,nonempty);
s = (ATerm)ATmakeApplArray(sym,args);
*nonempty=ATtrue;
ATtablePut(Subst,t,s);
return s;
} }
CAESAR_TYPE_NATURAL CAESAR_CARDINAL_LABEL(CAESAR_TYPE_LABEL l) {
return ATgetArity(ATgetSymbol(ATparse(CAESAR_STRING_LABEL(l))));
}
static void SubstituteInPars(ATermList pars, ATermList gs) {
for (;!ATisEmpty(gs);gs = ATgetNext(gs), pars = ATgetNext(pars)) {
RWassignVariable(ATgetSymbol(ATgetArgument(ATgetFirst(pars),0)) ,
ATgetFirst(gs), NULL, 0);
}
}
/**
* @TODO bug in glibc: functions not under control of features.h
*/
ATerm SSL_copy(ATerm oldname, ATerm newname)
// copy file oldname to file newname using read and write
{
#ifndef XT_STD_DISABLE_POSIX_XSI
int fdin, fdout;
int n;
char buf[SSL_COPY_BUFSIZE];
if(ATmatch(oldname, "stdin"))
fdin = STDIN_FILENO;
else if(!t_is_string(oldname))
_fail(oldname);
else if((fdin = open(ATgetName(ATgetSymbol(oldname)), O_RDONLY)) < 0 )
{
perror("SSL_copy");
ATfprintf(stderr, "SSL_copy: cannot open inputfile %t\n", oldname);
_fail(oldname);
}
if(ATmatch(newname, "stdout"))
{
fdout = STDOUT_FILENO;
}
else if(ATmatch(newname, "stderr"))
{
fdout = STDERR_FILENO;
}
else if(!t_is_string(newname))
{
_fail(newname);
}
else if((fdout = open(ATgetName(ATgetSymbol(newname)),
O_RDWR | O_CREAT | O_TRUNC,
S_IRUSR | S_IWUSR)) < 0 )
{
perror("SSL_copy");
ATfprintf(stderr, "SSL_copy: cannot create output file %t\n", newname);
_fail(newname);
}
while( (n = read(fdin, buf, SSL_COPY_BUFSIZE)) > 0 )
if(write(fdout, buf, n) != n)
{
perror("SSL_copy: write error");
close(fdin);
close(fdout);
_fail(newname);
}
if(n < 0)
{
perror("SSL_copy: read error");
close(fdin);
close(fdout);
_fail(oldname);
}
close(fdin);
close(fdout);
return newname;
#else
FILE *fin, *fout;
char ch;
if(ATmatch(oldname, "stdin")) {
fin = stdin;
}
else if(!t_is_string(oldname)) {
_fail(oldname);
}
else if((fin = fopen(ATgetName(ATgetSymbol(oldname)), "r")) == NULL) {
perror("SSL_copy");
ATfprintf(stderr, "SSL_copy: cannot open input file %t\n", oldname);
_fail(oldname);
}
if(ATmatch(newname, "stdout")) {
fout = stdout;
}
else if(ATmatch(newname, "stderr")) {
fout = stderr;
}
else if(!t_is_string(newname)) {
_fail(newname);
}
else if((fout = fopen(ATgetName(ATgetSymbol(newname)), "w")) == NULL) {
perror("SSL_copy");
ATfprintf(stderr, "SSL_copy: cannot create output file %t\n", newname);
_fail(newname);
}
while(!feof(fin)) {
ch = fgetc(fin);
if(ferror(fin)) {
ATfprintf(stderr, "SSL_copy: error reading input file %t\n", oldname);
_fail(newname);
}
if(ch != EOF)
fputc(ch, fout);
if(ferror(fout)) {
ATfprintf(stderr, "SSL_copy: error writing output file %t\n", newname);
_fail(newname);
}
}
if(fclose(fin) == EOF) {
ATfprintf(stderr, "SSL_copy: error closing input file %t\n", oldname);
_fail(newname);
}
if(fclose(fout) == EOF) {
ATfprintf(stderr, "SSL_copy: error closing output file %t\n", oldname);
_fail(newname);
}
return newname;
#endif
}
static void term2buf(ATerm t)
{
ATerm annos = AT_getAnnotations(t);
if(annos != NULL) {
char2buf('{');
}
switch(ATgetType(t)) {
case AT_INT:
wprintf("%d", ATgetInt((ATermInt)t));
break;
case AT_REAL:
wprintf("%f", ATgetReal((ATermReal)t));
break;
case AT_APPL:
{
int cur_arg, arity;
ATermAppl appl = (ATermAppl)t;
AFun sym = ATgetSymbol(appl);
if(ATisQuoted(sym))
qstr2buf(ATgetName(sym));
else
str2buf(ATgetName(sym));
arity = ATgetArity(sym);
if(arity > 0) {
char2buf('(');
for(cur_arg=0; cur_arg<arity; cur_arg++) {
term2buf(ATgetArgument(appl, cur_arg));
if(cur_arg < (arity-1))
char2buf(',');
}
char2buf(')');
}
}
break;
case AT_LIST:
{
ATermList l = (ATermList)t;
char2buf('{');
while(!ATisEmpty(l)) {
ATerm el = ATgetFirst(l);
l = ATgetNext(l);
term2buf(el);
if(!ATisEmpty(l))
char2buf(' ');
}
char2buf('}');
}
break;
case AT_PLACEHOLDER:
{
char2buf('<');
term2buf(ATgetPlaceholder((ATermPlaceholder)t));
char2buf('>');
}
break;
case AT_BLOB:
ATerror("blobs are not supported by tcltk-adapter!\n");
default:
ATabort("illegal term type!\n");
}
if(annos != NULL) {
char2buf(' ');
term2buf(annos);
char2buf('}');
}
}
