#include <unistd.h>
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <errno.h>
#include <sys/stat.h>
#include <signal.h>
#include <assert.h>
#include "art.h"
#include "artutils.h"
#include "pathutils.h"
#include "ntohl.h"
#define DEBUG 0
#if DEBUG
#define HIDE(x) x
#else
#define HIDE(x)
#endif
#define MAX_STRING 0xff
#define MAX_BIG_STRING 0xffff
/* We open the .hat file *twice* with different handles, for efficiency.
*
* For random access, use the global HatFileRandom handle. Most operations
* assume this mode of access.
*
* For sequential access, use the global HatFileSeq handle: the
* operation variants prefixed with q_ keep a global record (q_position)
* of the current file position, which is much cheaper than doing ftell().
*/
FileOffset errorRoot, errorMsg, remoteStartNode=0;
FileOffset q_position;
FILE *HatFileRandom, *HatFileSeq, *OutputFile, *BridgeFile;
unsigned filesize=0, outputsize=0;
char *progname; /* name of browser, not of the subject */
Bool interrupt=False; /* ^C interrupt at program runtime */
Bool hat_interrupted=False; /* ^C interrupt in browsing tool */
FileOffset
currentfilepos (void) { return q_position; }
void
finalise (void)
{
fclose(HatFileRandom);
fclose(HatFileSeq);
fclose(OutputFile);
fclose(BridgeFile);
}
/* Open a file for reading, given:
* the base name of the file
* the file extension
*/
FILE*
openFile (char* base, char* ext)
{
char filename[MAX_STRING];
FILE* file;
strcpy(filename,base);
strcat(filename,ext);
if (file = fopen(filename,"rb")) {
return file;
} else {
fprintf(stderr,"%s: cannot open %s\n",progname,filename);
exit(1);
}
}
/* Determine the size of a file, given:
* the base name of the file
* the file extension
*/
int
sizeFile (char* base, char* ext)
{
char filename[MAX_STRING];
struct stat buf;
strcpy(filename,base);
strcat(filename,ext);
stat(filename,&buf);
return buf.st_size;
}
/* freadAt() is just like fread(), except it seeks to a specific
* file location first. (Random Access)
*/
int
freadAt (FileOffset fo, void* ptr, int size, int nmemb, FILE* stream)
{
int err;
if (fo < 0x10) {
fprintf(stderr,"%s: attempt to read inside .hat header\n",progname);
fprintf(stderr,"%s: offset = 0x%x\n",progname,fo);
exit(1);
} else if (fo > filesize) {
fprintf(stderr,"%s: attempt to read beyond end of file\n",progname);
fprintf(stderr,"%s: offset = 0x%x, filesize = 0x%x\n",progname,fo,filesize);
fprintf(stderr,"%s: errno = %d (%s)\n",progname,errno,strerror(errno));
exit(1);
}
if (fseek(stream, fo, SEEK_SET)) {
fprintf(stderr,"%s: seek error on file\n",progname);
fprintf(stderr,"%s: errno = %d (%s)\n",progname,errno,strerror(errno));
exit(1);
}
err = fread(ptr,size,nmemb,stream);
return err;
}
/* q_fread() is just like fread() except it advances the global counter
* recording the file position. (Sequential Access)
*/
int
q_fread(void* buf, int siz, int num, FILE* file)
{
int err;
err = fread(buf,siz,num,file);
q_position += err*siz;
//if (err<num) {
// fprintf(stderr,"q_fread: warning, only read %d of %d values (size %d)\n"
// ,err,num,siz);
//}
return err;
}
/* readFO() reads a single FileOffset from the file and ensures it is
* in host-endian order. (Random Access)
*/
FileOffset
readFO (void)
{
FileOffset fo;
fread(&fo,sizeof(FileOffset),1,HatFileRandom);
HIDE(fprintf(stderr,"readFO -> 0x%x\n",ntohl(fo));)
return ntohl(fo);
}
/* (Sequential Access) */
FileOffset
q_readFO (void)
{
FileOffset fo;
q_fread(&fo,sizeof(FileOffset),1,HatFileSeq);
HIDE(fprintf(stderr,"q_readFO -> 0x%x\n",ntohl(fo));)
return ntohl(fo);
}
/* readString() reads a length-annotated string from the current position
* in the file. (Random Access)
*/
char*
readString (void)
{
char *buf;
int i, n;
n = (int)fgetc(HatFileRandom);
if (n==MAX_STRING) {
n = (int)fgetc(HatFileRandom);
n = (n<<8) + (int)fgetc(HatFileRandom);
}
buf = (char*)malloc((n+1)*sizeof(char));
i = fread(buf,sizeof(char),n,HatFileRandom);
buf[n] = '\0';
if (i<n) {
fprintf(stderr,"%s: warning, only read %d characters of %d in string"
,progname,i,n);
}
HIDE(fprintf(stderr,"readString -> %s\n",buf);)
return buf;
}
/* (Sequential Access) */
char*
q_readString (void)
{
char *buf;
int i, n;
n = (int)fgetc(HatFileSeq);
q_position += 1;
if (n==MAX_STRING) {
n = (int)fgetc(HatFileSeq);
n = (n<<8) + (int)fgetc(HatFileSeq);
q_position += 2;
}
buf = (char*)malloc((n+1)*sizeof(char));
i = q_fread(buf,sizeof(char),n,HatFileSeq);
buf[n] = '\0';
if (i<n) {
fprintf(stderr,"%s: warning, only read %d characters of %d in string"
,progname,i,n);
}
HIDE(fprintf(stderr,"q_readString -> %s\n",buf);)
return buf;
}
/* q_peek() takes a sneaky look at the next byte of the file, to
* determine whether we want to go ahead and read it now.
*/
char
q_peek (void)
{
char c;
c = (char)fgetc(HatFileSeq);
ungetc(c,HatFileSeq);
return c;
}
/* readModuleAt() fills in the name of the module and its source file,
* given the location of the module descriptor in the file.
*/
void
readModuleAt (FileOffset fo, char** modname, char** srcname, Bool* traced)
{
char c;
HIDE(fprintf(stderr,"readModuleAt 0x%x\n",fo);)
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
if (lower5(c)!=Module) {
fprintf(stderr,"%s: expected a Module descriptor at position 0x%x\n"
,progname,fo);
exit(1);
}
*traced = tracedModule(c);
*modname = readString();
*srcname = readString();
HIDE(fprintf(stderr,"readModuleAt 0x%x -> %s %s\n",fo,*modname,*srcname);)
}
/* readAtomAt() fills in the name of the variable or constructor,
* as well as its module, source file, fixity, and definition position,
* given the location of the Atom descriptor in the file.
*/
Ident*
readAtomAt (FileOffset fo)
{
char c;
FileOffset modpos;
Ident* id=0;
int defnpos;
int defnposend;
if (fo==Lambda) {
id = (Ident*)malloc(sizeof(Ident));
id->idname = "(\\..)";
id->modname = id->srcname = "";
id->fixity = noFixity;
id->defnline = id->defncolumn = 0;
id->defnlineend = id->defncolumnend = 0;
id->isTraced = False;
id->atomtype = Abstract;
} else if (fo==DoLambda) {
id = (Ident*)malloc(sizeof(Ident));
id->idname = "do";
id->modname = id->srcname = "";
id->fixity = noFixity;
id->defnline = id->defncolumn = 0;
id->defnlineend = id->defncolumnend = 0;
id->isTraced = False;
id->atomtype = Abstract;
} else {
HIDE(fprintf(stderr,"readAtomAt 0x%x\n",fo);)
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case AtomVariable:
case AtomConstructor:
id = (Ident*)malloc(sizeof(Ident));
modpos = readFO();
fread(&defnpos,sizeof(int),1,HatFileRandom);
fread(&defnposend,sizeof(int),1,HatFileRandom);
fread(&(id->fixity),sizeof(char),1,HatFileRandom);
fread(&(id->arity),sizeof(char),1,HatFileRandom);
id->idname = readString();
id->defnline = ntohl(defnpos)/10000;
id->defncolumn = ntohl(defnpos)%10000;
id->defnlineend = ntohl(defnposend)/10000;
id->defncolumnend= ntohl(defnposend)%10000;
if (lower5(c)==AtomVariable) {
id->atomtype = Variable;
} else if (hasFields(c)) {
id->atomtype = ConstrFields;
} else {
id->atomtype = Constructor;
}
readModuleAt(modpos,&(id->modname),&(id->srcname),&(id->isTraced));
break;
case AtomAbstract: {
char *tmp;
id = (Ident*)malloc(sizeof(Ident));
id->idname = readString();
id->modname = id->srcname = "";
id->fixity = noFixity;
id->defnline = id->defncolumn = id->defnlineend =
id->defncolumnend = 0;
id->isTraced = False;
id->atomtype = Abstract;
tmp = (char*)malloc(strlen(id->idname)+3);
strcpy(tmp,"{"); strcat(tmp,id->idname); strcat(tmp,"}");
free(id->idname); id->idname=tmp;
} break;
default:
fprintf(stderr,"%s: expected an Atom descriptor at position 0x%x\n"
,progname,fo);
exit(1);
break;
}
}
HIDE(fprintf(stderr,"readAtomAt 0x%x -> %s %s %s %d %d %d %d %d\n",fo,id->idname,id->modname,id->srcname,id->defnline,id->defncolumn,id->defnlineend,id->defncolumnend,id->fixity);)
return id;
}
/* readSRAt() fills in a struct containing the filename and usage
* position of a source reference, given the location of the
* SrcPos descriptor in the file.
*/
SrcRef *
readSRAt (FileOffset fo)
{
FileOffset modpos;
char *modname, *srcname;
int usepos;
int useposend;
char c;
Bool dummy;
SrcRef *sr;
HIDE(fprintf(stderr,"readSRAt 0x%x\n",fo);)
if (fo) {
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
if (lower5(c)!=SrcPos) {
fprintf(stderr,"%s: expected a SrcPos descriptor at position 0x%x\n"
,progname,fo);
fprintf(stderr,"%s: got a 0x%x\n",progname,c);
exit(1);
}
sr = (SrcRef*)malloc(sizeof(SrcRef));
modpos = readFO();
fread(&usepos,sizeof(int),1,HatFileRandom);
usepos = ntohl(usepos);
fread(&useposend,sizeof(int),1,HatFileRandom);
useposend = ntohl(useposend);
readModuleAt(modpos, &modname, &(sr->srcname), &dummy);
sr->line = usepos/10000;
sr->column = usepos%10000;
sr->lineend = useposend/10000;
sr->columnend = useposend%10000;
return sr;
} else {
return (SrcRef*)0;
}
}
char*
srFile (SrcRef* sr) { return sr->srcname; }
int
srLine (SrcRef* sr) { return sr->line; }
int
srColumn (SrcRef* sr) { return sr->column; }
int
srLineEnd (SrcRef* sr) { return sr->lineend; }
int
srColumnEnd (SrcRef* sr) { return sr->columnend; }
/* readValueAt() returns a struct containing a readable notation of the
* value-Exp stored at the given location in the file.
*/
Ident*
readValueAt (FileOffset fo)
{
char c, buf[MAX_STRING];
Ident *id = (Ident*)malloc(sizeof(Ident));
FileOffset parent, usepos = 0;
/* defaults */
id->idname = (char*)0;
id->modname = (char*)0;
id->srcname = (char*)0;
id->fixity = noFixity;
id->arity = 0;
id->defnline = 0;
id->defncolumn = 0;
id->defnlineend = 0;
id->defncolumnend = 0;
id->isTraced = False;
id->atomtype = Literal;
HIDE(fprintf(stderr,"readValueAt 0x%x\n",fo);)
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
if ((lower5(c)<ExpChar) || (lower5(c)>ExpConstDef)) {
fprintf(stderr,"%s: expected a value Exp descriptor at position 0x%x\n"
,progname,fo);
exit(1);
}
HIDE(fprintf(stderr,"readValueAt 0x%x -> tag 0x%x\n",fo,c);)
if (hasSrcPos(c)) { usepos = readFO(); }
parent = readFO();
switch (lower5(c)) {
case ExpChar:
{ fread(&c,sizeof(char),1,HatFileRandom);
if ((c>31) && (c!='\''))
sprintf(buf,"'%c'",c);
else switch(c) {
case '\n': sprintf(buf,"'\\n'"); break;
case '\t': sprintf(buf,"'\\t'"); break;
case '\255' : sprintf(buf,"'\\e'"); break;
default : sprintf(buf,"'\\0%X'",c); break;
}
id->idname = strdup(buf);
} break;
case ExpInt:
{ int i;
fread(&i,sizeof(int),1,HatFileRandom);
sprintf(buf,"%d",ntohl(i));
id->idname = strdup(buf);
} break;
case ExpInteger:
{ id->idname = readString();
} break;
case ExpRat:
{ int i,j;
fread(&i,sizeof(int),1,HatFileRandom);
fread(&j,sizeof(int),1,HatFileRandom);
sprintf(buf,"%d%%%d",ntohl(i),ntohl(j));
id->idname = strdup(buf);
} break;
case ExpRational:
{ sprintf(buf,"%s%%%s",readString(), readString());
id->idname = strdup(buf);
} break;
case ExpFloat:
{ float f;
fread(&f,sizeof(float),1,HatFileRandom);
sprintf(buf,"%.6f",f);
id->idname = strdup(buf);
} break;
case ExpDouble:
{ double d;
fread(&d,sizeof(double),1,HatFileRandom);
sprintf(buf,"%.15f",d);
id->idname = strdup(buf);
} break;
case ExpValueApp:
case ExpValueUse:
{ FileOffset atom;
free(id);
atom = readFO();
id = readAtomAt(atom);
} break;
case ExpConstUse:
{ FileOffset def;
free(id);
def = readFO();
id = readValueAt(def);
} break;
case ExpConstDef:
{ FileOffset atom;
free(id);
readFO(); /* skip result (? should we follow it ?) */
atom = readFO();
id = readAtomAt(atom);
} break;
default: break;
}
HIDE(fprintf(stderr,"readValueAt 0x%x -> %s %s %s %d %d %d\n",fo,id->idname,id->modname,id->srcname,id->defnline,id->defncolumn,id->fixity);)
if (!id->idname) id->idname = strdup("Problem");
return id;
}
/* Skip a complete node in the file, given that the tag byte has already
* been read. (Sequential Access) Returns the parent pointer of the node,
* if it has one, although in many cases this is ignored.
*/
FileOffset
q_skipNode (char tag)
{
FileOffset parent=0;
switch (lower5(tag)) {
case Module:
q_readString(); q_readString();
break;
case SrcPos:
q_readFO();
{ int x; q_fread(&x,sizeof(int),1,HatFileSeq); }
{ int x; q_fread(&x,sizeof(int),1,HatFileSeq); }
break;
case ExpApp:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO(); q_readFO(); q_readFO();
{ char arity; q_fread(&arity,sizeof(char),1,HatFileSeq);
while (arity--) { q_readFO(); } }
break;
case ExpValueApp:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO(); q_readFO();
{ char arity; q_fread(&arity,sizeof(char),1,HatFileSeq);
while (arity--) { q_readFO(); } }
break;
case ExpChar:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO();
{ char x; q_fread(&x,sizeof(char),1,HatFileSeq); }
break;
case ExpInt:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO();
{ int x; q_fread(&x,sizeof(int),1,HatFileSeq); }
break;
case ExpInteger:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO();
q_readString();
break;
case ExpRat:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO();
{ int x[2]; q_fread(&x[0],sizeof(int),2,HatFileSeq); }
break;
case ExpRational:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO();
q_readString(); q_readString();
break;
case ExpFloat:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO();
{ float x; q_fread(&x,sizeof(float),1,HatFileSeq); }
break;
case ExpDouble:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO();
{ double x; q_fread(&x,sizeof(double),1,HatFileSeq); }
break;
case ExpValueUse:
case ExpConstUse:
case ExpProjection:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO(); q_readFO();
break;
case ExpConstDef:
parent = q_readFO(); q_readFO(); q_readFO();
break;
case ExpGuard:
case ExpCase:
case ExpIf:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO(); q_readFO(); q_readFO();
break;
case ExpFieldUpdate:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO(); q_readFO(); q_readFO();
{ char arity; q_fread(&arity,sizeof(char),1,HatFileSeq);
arity = 2*arity;
while (arity--) { q_readFO(); } }
break;
case ExpHidden:
parent = q_readFO(); q_readFO(); q_readFO();
break;
case ExpForward:
parent = q_readFO(); /* note different to value of parentNode() */
break;
case ExpDoStmt:
if (hasSrcPos(tag)) q_readFO();
parent = q_readFO(); /* note different to value of parentNode() */
break;
case AtomVariable:
q_readFO();
{ int x; q_fread(&x,sizeof(int),1,HatFileSeq); }
{ int x; q_fread(&x,sizeof(int),1,HatFileSeq); }
{ char x; q_fread(&x,sizeof(char),1,HatFileSeq); }
{ char x; q_fread(&x,sizeof(char),1,HatFileSeq); }
q_readString();
break;
case AtomConstructor:
q_readFO();
{ int x; q_fread(&x,sizeof(int),1,HatFileSeq); }
{ int x; q_fread(&x,sizeof(int),1,HatFileSeq); }
{ char x; q_fread(&x,sizeof(char),1,HatFileSeq); }
{ char arity; q_fread(&arity,sizeof(char),1,HatFileSeq);
q_readString();
if (hasFields(tag)) while (arity--) q_readFO(); }
break;
case AtomAbstract:
q_readString();
break;
case ListCons:
q_readFO();
q_readFO();
default: break;
}
return parent;
}
/* readTraceAt() fills in a string containing a readable notation of the
* Trace stored at the given location in the file. It returns the
* parent trace. This routine is only currently used by the "virtual
* stack trace" program.
*/
FileOffset
readTraceAt (FileOffset fo, char** expr, SrcRef** sr, int* infix
,int followHidden, int depth)
{
char c, buf[10000]; /* fixed size no final solution */
FileOffset parent;
*infix = (int)noFixity; /* default */
if (depth <= 0) {
*expr = strdup("[7m [0m");
return fo;
}
if (fo<=DoLambda) {
switch (fo) {
case Root: sprintf(buf,"<Root>"); break;
case Unevaluated: sprintf(buf,"_"); break;
case Entered: sprintf(buf,"_|_"); break;
case Interrupted: sprintf(buf,"{^C}"); break;
case Lambda: sprintf(buf,"(\\..)"); break;
case DoLambda: sprintf(buf,"do"); break;
}
*expr = strdup(buf);
*infix = noFixity;
*sr = 0;
return fo;
} else {
HIDE(fprintf(stderr,"readTraceAt 0x%x\n",fo);)
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
if ((lower5(c)<ExpApp) || (lower5(c)>ExpDoStmt)) {
fprintf(stderr,"%s: expected Exp descriptor at position 0x%x (got 0x%x)\n"
,progname,fo,c);
exit(1);
}
HIDE(fprintf(stderr,"readTraceAt 0x%x -> tag 0x%x\n",fo,c);)
switch (lower5(c)) {
case ExpApp:
{ unsigned char i, arity;
FileOffset foExprs[20], foSR=0;
char* exprs[20];
int fixexp[20];
if (hasSrcPos(c)) { foSR = readFO(); }
parent = readFO(); /* get parent */
HIDE(fprintf(stderr,"enter parent of 0x%x -> 0x%x\n",fo,parent);)
readFO(); /* skip result */
foExprs[0] = readFO(); /* get fun */
fread(&arity,sizeof(unsigned char),1,HatFileRandom);
for (i=1; i<=arity; i++) {
foExprs[i] = readFO();
}
for (i=0; i<=arity; i++) {
(void)readTraceAt(getResult(foExprs[i],True)
,&(exprs[i]),sr,&(fixexp[i]),False,depth-1);
}
*infix = fixexp[0];
if (isInfix(fixexp[0]) && c >= 2) {
sprintf(buf,"%s",infixPrint(exprs[1],fixexp[1],exprs[0],fixexp[0]
,exprs[2],fixexp[2]));
for (i=3; i<=arity; i++) {
strcat(buf," ");
strcat(buf,exprs[i]);
}
} else { /* no fixity */
sprintf(buf,"(%s",exprs[0]);
for (i=1; i<=arity; i++) {
strcat(buf," ");
if (isInfix(fixexp[i])) {
strcat(buf,"(");
strcat(buf,exprs[i]);
strcat(buf,")");
} else
strcat(buf,exprs[i]);
}
strcat(buf,")");
}
*expr = strdup(buf);
*sr = readSRAt(foSR);
HIDE(fprintf(stderr,"return parent of 0x%x -> 0x%x\n",fo,parent);)
return parent;
} break;
case ExpValueApp:
{ unsigned char i, arity; Ident* id;
FileOffset foExprs[20], foSR=0;
char* exprs[20];
int fixexp[20];
if (hasSrcPos(c)) { foSR = readFO(); }
parent = readFO(); /* get parent */
HIDE(fprintf(stderr,"enter parent of 0x%x -> 0x%x\n",fo,parent);)
foExprs[0] = readFO(); /* get fun */
fread(&arity,sizeof(unsigned char),1,HatFileRandom);
for (i=1; i<=arity; i++) {
foExprs[i] = readFO();
}
id = readAtomAt(foExprs[0]);
for (i=1; i<=arity; i++) {
(void)readTraceAt(getResult(foExprs[i],True)
,&(exprs[i]),sr,&(fixexp[i]),False,depth-1);
}
*infix = id->fixity;
if (isInfix(id->fixity) && c >= 2) {
sprintf(buf,"%s",infixPrint(exprs[1],fixexp[1],id->idname,id->fixity
,exprs[2],fixexp[2]));
for (i=3; i<=arity; i++) {
strcat(buf," ");
strcat(buf,exprs[i]);
}
} else { /* no fixity */
sprintf(buf,"(%s",id->idname);
for (i=1; i<=arity; i++) {
strcat(buf," ");
if (isInfix(fixexp[i])) {
strcat(buf,"(");
strcat(buf,exprs[i]);
strcat(buf,")");
} else
strcat(buf,exprs[i]);
}
strcat(buf,")");
}
*expr = strdup(buf);
*sr = readSRAt(foSR);
HIDE(fprintf(stderr,"return parent of 0x%x -> 0x%x\n",fo,parent);)
return parent;
} break;
case ExpChar:
case ExpInt:
case ExpInteger:
case ExpRat:
case ExpRational:
case ExpFloat:
case ExpDouble:
case ExpValueUse:
case ExpConstUse:
case ExpConstDef:
{ FileOffset foSR=0;
Ident *id;
if (hasSrcPos(c)) { foSR = readFO(); }
parent = readFO();
id = readValueAt(fo);
*infix = id->fixity;
sprintf(buf,"%s",id->idname);
*expr = strdup(buf);
*sr = readSRAt(foSR);
return parent;
} break;
case ExpGuard:
case ExpCase:
case ExpIf:
{ FileOffset foCond, foSR;
char* cond;
int fixcond;
if (hasSrcPos(c)) { foSR = readFO(); }
parent = readFO(); /* get parent */
HIDE(fprintf(stderr,"enter parent of 0x%x -> 0x%x\n",fo,parent);)
readFO(); /* skip result */
foCond = readFO(); /* get condition */
readTraceAt(foCond,&cond,sr,&fixcond,False,depth-1);
switch (lower5(c)) {
case ExpGuard: sprintf(buf,"| "); break;
case ExpCase: sprintf(buf,"case "); break;
case ExpIf: sprintf(buf,"if "); break;
default: break;
}
if (isInfix(fixcond)) {
strcat(buf,"(");
strcat(buf,cond);
strcat(buf,")");
} else
strcat(buf,cond);
*expr = strdup(buf);
*sr = readSRAt(foSR);
HIDE(fprintf(stderr,"return parent of 0x%x -> 0x%x\n",fo,parent);)
} break;
case ExpFieldUpdate:
{
} break;
case ExpProjection:
{ if (hasSrcPos(c)) { readFO(); }
parent = readFO(); /* throw projective parent away */
parent = readFO(); /* choose original expression */
return readTraceAt(parent, expr, sr, infix, followHidden, depth);
} break;
case ExpHidden:
{ FileOffset result;
parent = readFO();
result = readFO();
if (!followHidden) {
sprintf(buf,"{?}");
*expr = strdup(buf);
return parent;
} else {
return readTraceAt(result, expr, sr, infix, followHidden, depth);
}
} break;
case ExpForward:
{ FileOffset result;
result = readFO();
return readTraceAt(result, expr, sr, infix, followHidden, depth);
} break;
case ExpDoStmt:
{ FileOffset foStmt, foSR;
char* stmt;
int fixstmt;
if (hasSrcPos(c)) { foSR = readFO(); }
HIDE(fprintf(stderr,"enter parent of 0x%x -> 0x%x\n",fo,parent);)
foStmt = readFO();
parent = readTraceAt(foStmt,&stmt,sr,&fixstmt,False,depth-1);
sprintf(buf,"do "); break;
if (isInfix(fixstmt)) {
strcat(buf,"(");
strcat(buf,stmt);
strcat(buf,")");
} else
strcat(buf,stmt);
*expr = strdup(buf);
*sr = readSRAt(foSR);
HIDE(fprintf(stderr,"return parent of 0x%x -> 0x%x\n",fo,parent);)
} break;
default: break;
}
return parent;
}
}
/* print an infix expression correctly according to the given priorities. */
char*
infixPrint (char* str1, int arg1, char* strfn, int fn, char* str2, int arg2)
{
char buf[10000]; /* fixed size no final solution */
if (!isInfix(arg1))
sprintf(buf,"%s",str1);
else if (priority(arg1) > priority(fn))
sprintf(buf,"%s",str1);
else if (priority(arg1) < priority(fn))
sprintf(buf,"(%s)",str1);
else if (isInfixN(fn))
sprintf(buf,"(%s)",str1);
else
sprintf(buf,"%s",str1);
strcat(buf,strfn);
if (!isInfix(arg2)) {
strcat(buf,str2);
} else if (priority(arg2) > priority(fn)) {
strcat(buf,str2);
} else if (priority(arg2) < priority(fn)) {
strcat(buf,"(");
strcat(buf,str2);
strcat(buf,")");
} else if (isInfixN(fn)) {
strcat(buf,"(");
strcat(buf,str2);
strcat(buf,")");
} else {
strcat(buf,str2);
}
return strdup(buf);
}
/* The next bunch of utility functions are for hat-trail.
* ------------------------------------------------------
*
*
*/
/* Open the .hat file */
void
openHatFile (char* prog, char* arg)
{
int err;
char header[8];
progname = basename(prog,0);
HatFileRandom = openFile(arg, "");
HatFileSeq = openFile(arg, "");
BridgeFile = openFile(arg,".bridge");
filesize = sizeFile(arg, "");
q_position = 0;
err = fread(header,sizeof(char),8,HatFileRandom);
if (err!=8) {
fprintf(stderr,"%s (error): file %s is too short\n",progname,arg);
exit(1);
}
if (strncmp(header,"Hat",3)) {
fprintf(stderr,"%s (error): file %s\n",progname,arg);
fprintf(stderr," does not appear to be a Hat archive. Quitting.\n");
exit(1);
}
if (strncmp(header+3,FILEVERSION,4)) {
fprintf(stderr,"%s (warning): file %s\n",progname,arg);
fprintf(stderr," appears to be a Hat archive in format %s\n",header+3);
fprintf(stderr," but this tool deals with format version %s\n",FILEVERSION);
fprintf(stderr," I'm continuing, but there may be unexpected errors.\n");
}
errorRoot = readFO();
errorMsg = readFO();
if (errorMsg==Entered) interrupt=True;
// signal(SIGINT,SIG_IGN);
}
void closeHatFile (void)
{
fclose(HatFileRandom);
fclose(HatFileSeq);
fclose(BridgeFile);
}
/* Return the contents of the bridge file, one item at a time. */
FileOffset
getBridgeValue (void)
{
int err;
FileOffset fo;
err = fread(&fo,sizeof(FileOffset),1,BridgeFile);
if (err==0) {
fclose(BridgeFile);
return 0;
} else return ntohl(fo);
}
/* Get the trace reference for an error, and the string associated with it. */
FileOffset
getErrorLoc (void)
{
FileOffset fo;
fseek(HatFileRandom,8,SEEK_SET);
fo = readFO();
return fo;
}
char *
errorMessage (void)
{
FileOffset fo;
char c='\0';
fseek(HatFileRandom,12,SEEK_SET);
fo = readFO();
if (fo==Entered) return "Interrupted (^C)";
if (fo) {
HIDE(fprintf(stderr,"errorMessage 0x%x\n",fo);)
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
if (lower5(c)==AtomAbstract) return readString();
}
return "";
}
char*
versionNumber (void)
{
return strdup(VERSION);
}
/* Read the tag bits and report the NodeType. */
int
getNodeType (FileOffset fo)
{
char c;
if (fo<=DoLambda) return -1;
HIDE(fprintf(stderr,"getNodeType 0x%x\n",fo);)
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
return (int)(lower5(c)); /* lower 5 bits are the identifying tag */
}
/* For any node type, get its parent. If it doesn't have one, we give 0. */
FileOffset
parentNode (FileOffset fo)
{
char c;
HIDE(fprintf(stderr,"parentNode 0x%x\n",fo);)
if (fo<=DoLambda) return 0;
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ListCons:
case Module:
case SrcPos:
case AtomVariable:
case AtomConstructor:
case AtomAbstract:
return 0;
break;
case ExpApp:
case ExpValueApp:
case ExpChar:
case ExpInt:
case ExpInteger:
case ExpRat:
case ExpRational:
case ExpFloat:
case ExpDouble:
case ExpValueUse:
case ExpConstUse:
case ExpConstDef:
case ExpGuard:
case ExpCase:
case ExpIf:
case ExpFieldUpdate:
case ExpProjection:
case ExpHidden:
if (hasSrcPos(c)) { readFO(); }
return readFO();
break;
case ExpForward:
case ExpDoStmt:
if (hasSrcPos(c)) { readFO(); }
return parentNode(readFO());
break;
}
}
/* Only for Exp nodes of value kind, we give back a string representation
* of the name (identifier, Integer, Double, etc), and its fixity etc.
* The predicate isLiteral reports True for values of basic
* types like Int, Char, Double etc, and isConstructor identifies Constrs.
*/
char *
getNm (FileOffset fo)
{
char *id;
Ident *name = readValueAt(fo);
if (name) {
id = name->idname;
free(name);
HIDE(fprintf(stderr,"getNm: %s\n",id);)
return id;
} else
return "";
}
char *
getNmMod (FileOffset fo)
{
char *id;
Ident *name = readValueAt(fo);
if (name) {
id = name->modname;
free(name);
return id;
} else
return "";
}
int
getFixity (FileOffset fo)
{
int f;
Ident *name = readValueAt(fo);
if (name) {
f = (int)name->fixity;
HIDE(fprintf(stderr,"getFixity: %d (%s)\n",f,name->idname);)
free(name);
return f;
} else
return (int)noFixity;
}
Bool
isLiteral (FileOffset fo)
{
Bool b;
Ident *name = readValueAt(fo);
if (name) {
b = (name->atomtype == Literal);
free(name);
return b;
} else
return False;
}
Bool
isConstructor (FileOffset fo)
{
Bool b;
Ident *name = readValueAt(fo);
if (name) {
b = (name->atomtype == Constructor) || (name->atomtype == ConstrFields);
free(name);
return b;
} else
return False;
}
Bool
isConstrFields (FileOffset fo)
{
Bool b;
char c;
Ident *name;
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case AtomVariable:
case AtomConstructor:
case AtomAbstract:
name = readAtomAt(fo);
break;
default:
name = readValueAt(fo);
break;
}
if (name) {
b = (name->atomtype == ConstrFields);
free(name);
HIDE(fprintf(stderr,"isConstrFields 0x%x: %s %s\n",fo,name->idname,
(b ? "True" : "False"));)
return b;
} else
return False;
}
Bool
isLambda (FileOffset fo)
{
Bool b; unsigned char c;
HIDE(fprintf(stderr,"isLambda 0x%x\n",fo);)
freadAt(fo,&c,sizeof(unsigned char),1,HatFileRandom);
switch (lower5(c)) {
case ExpValueUse:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
if (readFO()==Lambda) return True;
else return False;
break;
default:
return False;
break;
}
}
Bool
isDoLambda (FileOffset fo)
{
Bool b; unsigned char c;
HIDE(fprintf(stderr,"isDoLambda 0x%x\n",fo);)
freadAt(fo,&c,sizeof(unsigned char),1,HatFileRandom);
switch (lower5(c)) {
case ExpValueUse:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
if (readFO()==DoLambda) return True;
else return False;
break;
default:
return False;
break;
}
}
/* Get the an name of an identifier out of its struct Ident. */
char*
identName (Ident* id) { return id->idname; }
char*
identModName (Ident* id) { return id->modname; }
char*
identSrcFile (Ident* id) { return id->srcname; }
int
identFixity (Ident* id) { return (int)id->fixity; }
int
identArity (Ident* id) { return (int)id->arity; }
int
identDefnLine (Ident* id) { return id->defnline; }
int
identDefnCol (Ident* id) { return id->defncolumn; }
int
identDefnLineEnd (Ident* id) { return id->defnlineend; }
int
identDefnColEnd (Ident* id) { return id->defncolumnend; }
Bool
identIsTraced (Ident* id) { return id->isTraced; }
/* For all nodes, get number of arguments. */
int
getExpArity (FileOffset fo)
{
char c;
HIDE(fprintf(stderr,"getExpArity 0x%x\n",fo);)
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpApp:
case ExpFieldUpdate:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip result */
readFO(); /* skip fun/constructor */
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
return (int)(c);
break;
case ExpValueApp:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip constructor */
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
return (int)c;
break;
case AtomConstructor: /* only interested in fields */
if (!hasFields(c)) { return 0; }
readFO(); /* skip module */
{ int x; fread(&x,sizeof(int),1,HatFileRandom); }
{ int x; fread(&x,sizeof(int),1,HatFileRandom); }
{ char x; fread(&x,sizeof(char),1,HatFileRandom); }
{ char arity; fread(&arity,sizeof(char),1,HatFileRandom);
return (int)arity; }
break;
case Module:
case SrcPos:
case ExpChar:
case ExpInt:
case ExpInteger:
case ExpRat:
case ExpRational:
case ExpFloat:
case ExpDouble:
case ExpValueUse:
case ExpConstUse:
case ExpConstDef:
case ExpGuard:
case ExpCase:
case ExpIf:
case ExpProjection:
case ExpHidden:
case ExpForward:
case ExpDoStmt:
case AtomVariable:
case AtomAbstract:
return 0;
break;
}
}
/* For all nodes, get the value of the n'th subexpression. For basic values,
* the 0'th subexpr is the node itself. For an application, the 0'th subexpr
* is the final result of the fun ptr, the k'th subexpr is the final result of
* the k'th argument. In the case where a fun/arg resolves to an atom,
* we return the atom pointer rather than an Exp pointer - the Haskell code
* can interpret either form.
*/
FileOffset
getExpArg (FileOffset fo, int n)
{
char c;
int i=0;
FileOffset ptr;
HIDE(fprintf(stderr,"getExpArg 0x%x\n",fo);)
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpApp:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* fun/constructor */
if (n==0) return getResult(ptr,True);
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
if (n<=c) {
for (i=1; i<n; i++) readFO(); /* skip other args */
ptr = readFO(); /* get n'th arg */
return getResult(ptr,True);
} else
return fo;
break;
case ExpValueApp:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* fun/constructor */
if (n==0) return ptr; /* no result-chain - fun is already an atom */
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
if (n<=c) {
for (i=1; i<n; i++) readFO(); /* skip other args */
ptr = readFO(); /* get n'th arg */
return getResult(ptr,True);
} else
return fo;
break;
case ExpValueUse:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* CAF */
return ptr; /* no result-chain - fun is already an atom */
break;
case ExpConstDef:
case ExpConstUse:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* CAF */
return getResult(ptr,True);
break;
case ExpGuard:
case ExpCase:
case ExpIf:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* get condition */
return getResult(ptr,True);
break;
case ExpFieldUpdate:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* exp/constructor */
if (n==0) return getResult(ptr,True);
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
if (n<=c) {
for (i=0; i<c; i++) readFO(); /* skip binder labels */
for (i=1; i<n; i++) readFO(); /* skip other bindees */
ptr = readFO(); /* get n'th bindee */
return getResult(ptr,True);
} else
return fo;
break;
case ExpProjection:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* get expr */
return ptr;
break;
case ExpForward:
ptr = readFO(); /* get expr */
return ptr;
break;
case ExpChar:
case ExpInt:
case ExpInteger:
case ExpRat:
case ExpRational:
case ExpFloat:
case ExpDouble:
case ExpHidden:
case ExpDoStmt:
case Module:
case SrcPos:
case AtomVariable:
case AtomConstructor:
case AtomAbstract:
default:
return fo;
break;
}
}
/* Get the n'th subexpression (*not* its value),
* for any node that has subexpressions.
*/
FileOffset
peekExpArg (FileOffset fo, int n)
{
char c;
int i=0;
FileOffset ptr;
HIDE(fprintf(stderr,"peekExpArg 0x%x\n",fo);)
assert (n>=0);
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpApp:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* fun/constructor */
if (n==0) return ptr;
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
assert (n<=c);
for (i=1; i<n; i++) readFO(); /* skip other args */
ptr = readFO(); /* get n'th arg */
return ptr;
break;
case ExpValueApp:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* fun/constructor */
if (n==0) return ptr;
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
assert (n<=c);
for (i=1; i<n; i++) readFO(); /* skip other args */
ptr = readFO(); /* get n'th arg */
return ptr;
break;
case ExpValueUse:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* only arg */
return ptr; /* this is an atom */
break;
case ExpConstDef:
case ExpConstUse:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* only arg */
return ptr;
break;
case ExpGuard:
case ExpCase:
case ExpIf:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* get condition */
return ptr;
break;
case ExpFieldUpdate:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* exp/constructor */
if (n==0) return ptr;
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
assert (n<=c);
for (i=0; i<c; i++) readFO(); /* skip binder labels */
for (i=1; i<n; i++) readFO(); /* skip other bindees */
ptr = readFO(); /* get n'th bindee */
return ptr;
break;
case ExpProjection:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* get expr */
return ptr;
break;
case ExpForward:
ptr = readFO(); /* get expr */
return ptr;
break;
case ExpHidden:
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* get child list */
return ptr;
break;
case ListCons:
ptr = readFO(); /* get element */
if (n==1) return ptr;
ptr = readFO(); /* get tail */
return ptr;
break;
case ExpChar:
case ExpInt:
case ExpInteger:
case ExpRat:
case ExpRational:
case ExpFloat:
case ExpDouble:
case ExpDoStmt:
case Module:
case SrcPos:
case AtomVariable:
case AtomConstructor:
case AtomAbstract:
default:
assert (False);
break;
}
}
/* Only for an ExpFieldUpdate node, or an ExpConstructor that has fields,
* get the atom pointer of the n'th label.
*/
FileOffset
getFieldLabel (FileOffset fo, int n)
{
char c;
int i=0;
FileOffset ptr;
HIDE(fprintf(stderr,"getFieldLabel 0x%x: n=%d\n",fo,n);)
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpFieldUpdate:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
readFO(); /* skip result */
readFO(); /* skip exp/constructor */
fread(&c,sizeof(char),1,HatFileRandom); /* get arity */
if (n<=c) {
for (i=1; i<n; i++) readFO(); /* skip other labels */
ptr = readFO(); /* get n'th label */
return ptr;
} else
return 0;
break;
case ExpValueUse:
if (hasSrcPos(c)) { readFO(); } /* skip usage position */
readFO(); /* skip parent */
ptr = readFO(); /* atom pointer */
return getFieldLabel(ptr,n);
break;
case AtomConstructor:
if (hasFields(c)) {
readFO(); /* skip module ptr */
{ int x; fread(&x,sizeof(int),1,HatFileRandom); }
{ int x; fread(&x,sizeof(int),1,HatFileRandom); }
{ char x; fread(&x,sizeof(char),1,HatFileRandom); }
{ char arity; fread(&arity,sizeof(char),1,HatFileRandom);
readString();
while (n--) readFO();
ptr = readFO();
HIDE(fprintf(stderr,"getFieldLabel: return 0x%x\n",ptr);)
return ptr; }
} else {
fprintf(stderr,"constructor at 0x%x has no field labels\n",fo);
return 0;
} break;
default:
return 0;
break;
}
}
/* Get the SrcRef belonging to any node type. If the node doesn't have
* one, we give back a 0 reference.
*/
FileOffset
getSrcRef (FileOffset fo)
{
char c;
int i;
HIDE(fprintf(stderr,"getSrcRef 0x%x\n",fo);)
if (fo<=DoLambda) return 0;
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
if (hasSrcPos(c)) {
return readFO(); /* get SrcRef */
} else {
return 0;
}
}
/* Get the Atom node for the fun position of an expression.
* If the node doesn't look right, we give back a 0 reference.
*/
FileOffset
getDefnRef (FileOffset fo)
{
char c;
int i;
FileOffset ptr;
if (fo==0) return 0;
HIDE(fprintf(stderr,"getDefnRef 0x%x\n",fo);)
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpApp:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* get fun */
return getDefnRef(ptr); /* and follow it */
break;
case ExpValueApp:
case ExpValueUse:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
readFO(); /* skip parent */
ptr = readFO(); /* get Atom */
return ptr;
break;
case ExpConstUse:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
readFO(); /* skip parent */
ptr = readFO(); /* get ExpConstDef pointer */
return getDefnRef(ptr); /* and follow it */
break;
case ExpConstDef: /* never a use position */
readFO(); /* skip parent */
readFO(); /* skip result */
ptr = readFO(); /* get Atom */
return ptr;
break;
case AtomVariable:
case AtomConstructor:
return fo;
break;
default:
return 0;
break;
}
}
/* peekTrace() takes a peek backwards at a trace (or indirection), skipping
* over any Hidden or Projection nodes to find the nearest "real" trace.
* It is used by the code that clumps together characters in the output
* by their shared parentage.
*/
FileOffset
peekTrace(FileOffset fo)
{
char c;
while (1) { /* iterate until we find a `real' node */
if (fo<=DoLambda) return 0; /* trace is Root/Unevaluated/Entered/etc */
HIDE(fprintf(stderr,"peekTrace 0x%x\n",fo);)
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (c) {
case ExpProjection:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
fo = readFO(); /* get parent */
break; /* and look again */
case ExpHidden:
case ExpForward:
fo = readFO(); /* get parent */
break; /* and look again */
case Module:
case SrcPos:
case AtomVariable:
case AtomConstructor:
case AtomAbstract:
fprintf(stderr,"peekTrace failed\n");
exit(1);
default:
return fo; /* found a `real' node! */
break;
}
}
}
/* getResult() returns the result of an application, or 0 if there is
* apparently no result. (Results can also be Unevaluated, Entered,
* or Interrupted). To find the result, it is necessary to follow
* the result-pointer chain right to the end (but only as far as the
* terminating Exp, not right down to an Atom). If the final result
* is Unevaluated, Entered, Interrupted, or Lambda, then we return
* the previous step of the chain. (The pretty printer then decides
* how to represent these to the user.)
*
* It turns out that a result chain can contain a cycle, which we must
* detect. A cycle always involves some Forwards and one Hidden. It
* is sufficient to record the most recent Hidden that was seen, and
* if we come across it again, just stop and return the Hidden.
*/
static FileOffset mostRecentHidden=0;
FileOffset
getResult (FileOffset fo, Bool stopAtHidden)
{
if (fo==mostRecentHidden) return fo;
mostRecentHidden=0;
return getResultNoCycle(fo,stopAtHidden);
}
#define fixInterrupt(fo) (interrupt && fo==Entered ? Interrupted : fo)
FileOffset
getResultNoCycle (FileOffset fo, Bool stopAtHidden)
{
char c;
FileOffset result;
HIDE(fprintf(stderr,"getResult 0x%x\n",fo);)
if (fo<=DoLambda) return fixInterrupt(fo); /* trace is Unevaluated etc */
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpApp:
case ExpGuard:
case ExpCase:
case ExpIf:
case ExpFieldUpdate:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
readFO(); /* skip parent */
result = readFO(); /* get result */
HIDE(fprintf(stderr,"getResult: result is 0x%x\n",result);)
if (result==fo) return fo;
else if (result<=DoLambda) return fixInterrupt(fo);
else return getResultNoCycle(result,False);
break;
// case ExpValueApp:
// case ExpValueUse:
// if (hasSrcPos(c)) { readFO(); } /* skip use position */
// readFO(); /* skip parent */
// return readFO(); /* return Atom pointer */
// break;
case ExpConstUse:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
readFO(); /* skip parent */
result = readFO(); /* get result */
if (result<=DoLambda) return fixInterrupt(fo);
else return getResultNoCycle(result,False);
/* follow ExpConstDef pointer */
break;
case ExpConstDef:
readFO(); /* skip parent */
result = readFO(); /* get result */
if (result<=DoLambda) return fixInterrupt(fo);
return getResultNoCycle(result,False);
break;
case ExpForward:
return getResultNoCycle(readFO(),stopAtHidden);
break; /* continue to detect Hidden */
case ExpDoStmt:
return getResultNoCycle(readFO(),False); /* get result */
break;
case ExpProjection:
return fo;
case ExpValueApp:
case ExpValueUse:
case ExpChar:
case ExpInt:
case ExpInteger:
case ExpRat:
case ExpRational:
case ExpFloat:
case ExpDouble:
// case AtomVariable:
// case AtomConstructor:
// case AtomAbstract:
HIDE(fprintf(stderr,"getResult: result is itself\n");)
return fo;
break;
case ExpHidden:
if (stopAtHidden) return fo;
else if (fo==mostRecentHidden) return fo;
else {
mostRecentHidden = fo; /* keep, to detect a loop */
readFO(); /* skip parent */
result = readFO(); /* get result */
if (result==fo) return fo;
else if (result<=DoLambda) return fixInterrupt(fo);
else return getResultNoCycle(result,False);
}
break;
case AtomVariable:
case AtomConstructor:
case AtomAbstract:
default:
return 0;
break;
}
}
/* peekResult() is a one-step look at the result pointer. It does not
* follow the whole chain. It is mainly used to decide whether the
* pointer returned by getResult() leads directly to an Unevaluated,
* Entered, Interrupted, or Lambda.
*/
FileOffset
peekResult (FileOffset fo)
{
char c;
FileOffset result;
HIDE(fprintf(stderr,"peekResult 0x%x\n",fo);)
if (fo<=DoLambda) return fixInterrupt(fo); /* trace is Unevaluated etc */
freadAt(fo,&c,sizeof(char),1,HatFileRandom);
switch (lower5(c)) {
case ExpApp:
case ExpGuard:
case ExpCase:
case ExpIf:
case ExpFieldUpdate:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
readFO(); /* skip parent */
result = readFO(); /* get result */
return fixInterrupt(result);
break;
case ExpConstUse:
case ExpProjection:
if (hasSrcPos(c)) { readFO(); } /* skip use position */
readFO(); /* skip parent */
result = readFO(); /* get result */
return fixInterrupt(result);
break;
case ExpConstDef:
readFO(); /* skip parent */
result = readFO(); /* get result */
return fixInterrupt(result);
break;
case ExpForward:
case ExpDoStmt:
result = readFO(); /* get result */
return fixInterrupt(result);
break;
case ExpValueApp:
case ExpValueUse:
case ExpChar:
case ExpInt:
case ExpInteger:
case ExpRat:
case ExpRational:
case ExpFloat:
case ExpDouble:
HIDE(fprintf(stderr,"getResult: result is itself\n");)
return fo;
break;
case ExpHidden:
readFO(); /* skip parent */
result = readFO(); /* get result */
return fixInterrupt(result);
break;
case AtomVariable:
case AtomConstructor:
case AtomAbstract:
default:
return 0;
break;
}
}
/* Comparison of FileOffsets is the basic key-ordering for finite maps,
* used for gathering and looking up information during a linear sweep
* of the .hat file (in hat-observe and hat-detect).
*/
int
fileoffset_compare (FileOffset i, FileOffset j) /* for ordering the tree */
{
if (i<j) return -1;
else if (i==j) return 0;
else return 1;
}
/* Signal handler for user-interruption */
void
ctrlC (int sig)
{ hat_interrupted = True; }
/* sequential access from Haskell */
void
q_init (void)
{
q_position = 0x10;
fseek(HatFileSeq,q_position,SEEK_SET);
}
char
q_tag (void)
{
char c;
c = (char)fgetc(HatFileSeq);
q_position+=1;
return lower5(c);
}
syntax highlighted by Code2HTML, v. 0.9.1