TPoss
tpossIntersect(TPoss S, TPoss T)
{
TFormList LS, LT, l = 0;
if (S == NULL || T == NULL)
return NULL;
/* If T is free of duplicates, then the result will also be. */
for (LT = T->possl; LT; LT = cdr(LT)) {
car(LT) = tfFollowOnly(car(LT));
for (LS = S->possl; LS; LS = cdr(LS)) {
car(LS) = tfFollowOnly(car(LS));
if (tfSatisfies(car(LS), car(LT))) {
l = listCons(TForm)(car(LT), l);
break;
}
if (tfSatisfies(car(LT), car(LS))) {
if (!listMember(TForm)(l, car(LS), tfEqual))
l = listCons(TForm)(car(LS), l);
}
}
}
l = listNReverse(TForm)(l);
return tpossFrTheList(l);
}
SymeList
symeTwins(Syme syme)
{
static SymeList symes0 = listNil(Syme);
SymeList symes;
if (symes0 == listNil(Syme))
symes0 = listCons(Syme)((Syme) NULL, symes0);
if (symeHasTrigger(syme) && symeHasLocal(syme, SYFI_Twins)) {
symeClrTrigger(syme);
libGetAllSymes(symeLib(syme));
}
/* Use symeFull(syme) as an implicit twin if present. */
symes = symeLocalTwins(syme);
if (symeFullTwin(syme)) {
Syme osyme = symeFull(syme);
if (symes == listNil(Syme)) {
setcar(symes0, osyme);
symes = symes0;
}
else if (!listMemq(Syme)(symes, osyme)) {
symes = listCons(Syme)(osyme, symes);
symeSetTwins(syme, symes);
}
}
return symes;
}
static StringList
uclConstructOptList(String name, StringList given)
{
StringList res;
String flag;
String tmp;
Bool sep;
flag = cfgLookupString(name, uclOptions);
tmp = strConcat(name, "-sep");
sep = cfgLookupBoolean(tmp, uclOptions);
strFree(tmp);
res = listNil(String);
while (given) {
if (sep) {
res = listCons(String)(flag, res);
res = listCons(String)(car(given), res);
}
else {
tmp = strConcat(flag, car(given));
res = listCons(String)(tmp, res);
}
given = cdr(given);
}
return listNReverse(String)(res);
}
TfCond
tfCondFloat(Stab stab, TfCond tfcond)
{
TfCond newTfCond;
TfCondEltList conditionElts = tfcond->conditions;
int floatDepth = stabLevelNo(stab);
Bool containsEmpty = false;
TfCondEltList filteredConditions = listNil(TfCondElt);
tfCondDEBUG(dbOut, "tform depth: %d\n", floatDepth);
while (conditionElts != listNil(TfCondElt) && !containsEmpty) {
TfCondElt elt = car(conditionElts);
AbSynList filteredCondition = listNil(AbSyn);
AbSynList condition = elt->list;
while (condition != listNil(AbSyn)) {
ULong idepth = abOuterDepth(elt->stab, car(condition));
tfCondDEBUG(dbOut, "ConditionDepth: %pAbSyn %d/%d\n",
car(condition), idepth, floatDepth);
if (floatDepth >= idepth) {
tfCondDEBUG(dbOut, "Keeping %pAbSyn\n", car(condition));
filteredCondition = listCons(AbSyn)(car(condition),
filteredCondition);
}
condition = cdr(condition);
}
tfCondDEBUG(dbOut, "Floating conditions - filtered: %pAbSynList\n",
filteredCondition);
if (filteredCondition == listNil(AbSyn)) {
containsEmpty = true;
}
else {
TfCondElt filteredConditionElt = tfCondEltNew(stab, filteredCondition);
filteredConditions = listCons(TfCondElt)(filteredConditionElt, filteredConditions);
}
tfCondDEBUG(dbOut, "Floating conditions: %pAbSynList\n",
car(conditionElts)->list);
conditionElts = cdr(conditionElts);
}
newTfCond = tfCondNew();
if (containsEmpty || filteredConditions == listNil(TfCondElt)) {
newTfCond->containsEmpty = true;
newTfCond->conditions = listNil(TfCondElt);
}
else {
newTfCond->containsEmpty = false;
newTfCond->conditions = filteredConditions;
}
return newTfCond;
}
static inline ListCell *parseHeaders(char *segment) {
ListCell *headers = NULL;
size_t len;
char *header;
while (segment != NULL) {
segment = strtok(NULL, ":\n");
if (segment == NULL || *segment == '\r')
break;
header = segment;
segment = strtok(NULL, "\n");
if (segment == NULL)
break;
if (*segment == ' ')
segment += 1;
len = strlen(segment);
if (*(segment + len - 1) == '\r')
*(segment + len - 1) = '\0';
headers = listCons(kvNew(header, segment), sizeof(KV), headers);
}
return headers;
}
static inline ListCell *parseCookies(char *header) {
ListCell *cookies = NULL;
char *copy = bsNew(header);
char *segment, *key;
bool s = true;
for (;;) {
if (s) {segment = strtok(copy, "="); s = false;}
else {segment = strtok(NULL, "=");}
if (segment == NULL) break;
if (*segment == ' ') segment += 1;
key = segment;
segment = strtok(NULL, ";\0");
if (segment == NULL) break;
cookies = listCons(kvNew(key, segment), sizeof(KV), cookies);
}
bsDel(copy);
return cookies;
}
static inline ListCell *parseQS(char *path) {
ListCell *qs = NULL;
char *copy = bsNew(path);
char *segment, *key, *value;
bool s = true;
for (;;) {
if (s) {segment = strtok(copy, "="); s = false;}
else {segment = strtok(NULL, "=");}
if (segment == NULL) break;
if (*(segment + strlen(segment) + 1) == '&') continue;
key = segment;
segment = strtok(NULL, "&\0");
if (segment == NULL) break;
key = urldecode(key);
value = urldecode(segment);
qs = listCons(kvNew(key, value), sizeof(KV), qs);
bsDel(key);
bsDel(value);
}
bsDel(copy);
return qs;
}
local void
testSymeAddCondition()
{
String B_imp = "import from Boolean";
String C_txt = "C: Category == with";
String D1_txt = "D1: with == add";
String D2_txt = "D2: with == add";
StringList lines = listList(String)(4, B_imp, C_txt, D1_txt, D2_txt);
AbSynList code = listCons(AbSyn)(stdtypes(), abqParseLines(lines));
AbSyn absyn = abNewSequenceL(sposNone, code);
initFile();
Stab stab = stabFile();
abPutUse(absyn, AB_Use_NoValue);
scopeBind(stab, absyn);
typeInfer(stab, absyn);
AbSyn D1 = abFrSyme(uniqueMeaning(stabFile(), "D1"));
AbSyn D2 = abFrSyme(uniqueMeaning(stabFile(), "D2"));
AbSyn C = abFrSyme(uniqueMeaning(stabFile(), "C"));
Syme syme1 = symeNewExport(symInternConst("syme2"), tfNewAbSyn(TF_General, id("D")), car(stab));
symeAddCondition(syme1, sefo(has(D1, C)), true);
testIntEqual("test1", 1, listLength(Sefo)(symeCondition(syme1)));
Syme syme2 = symeNewExport(symInternConst("syme1"),tfNewAbSyn(TF_General, id("D")), car(stab));
symeAddCondition(syme2, sefo(and(has(D1, C),
has(D2, C))), true);
testIntEqual("test2", 2, listLength(Sefo)(symeCondition(syme2)));
finiFile();
}
local void
testSymeSExpr()
{
String aSimpleDomain = "+++Comment\nDom: Category == with {f: () -> () ++ f\n}";
StringList lines = listList(String)(1, aSimpleDomain);
AbSynList code = listCons(AbSyn)(stdtypes(), abqParseLines(lines));
AbSyn absyn = abNewSequenceL(sposNone, code);
initFile();
Stab stab = stabFile();
abPutUse(absyn, AB_Use_NoValue);
scopeBind(stab, absyn);
typeInfer(stab, absyn);
testTrue("Declare is sefo", abIsSefo(absyn));
testIntEqual("Error Count", 0, comsgErrorCount());
SymeList symes = stabGetMeanings(stab, ablogFalse(), symInternConst("Dom"));
testIntEqual("unique meaning", 1, listLength(Syme)(symes));
Syme syme = car(symes);
SExpr sx = symeSExprAList(syme);
finiFile();
}
ListPtr
listConsF(ListPtr cdr, const char *f, ...)
{
va_list args;
char *string;
{
int n, size = 20;
while(1) {
if(size > 4096)
return NULL;
string = malloc(size);
if(!string)
return NULL;
va_start(args, f);
n = vsnprintf(string, size, f, args);
va_end(args);
if(n >= 0 && n < size)
return listCons(string, cdr);
else if(n >= size)
size = n + 1;
else
size = size * 3 / 2 + 1;
free(string);
}
}
}
/*
* Invent some absyn for the parameter list of a function.
*/
local AbSyn
ab0ImplicitExportArgs(TForm tf)
{
/* How many parameters does this function have? */
Length numargs = tfIsMulti(tf) ? tfMultiArgc(tf) : 1;
/* Deal with single and multiple arguments separately */
if (numargs > 1)
{
/* Multiple arguments: (Comma ...) */
Length i;
AbSynList lst = listNil(AbSyn);
/* Create each argument */
for (i = 0; i < numargs; i++)
{
AbSyn arg = ab1ImplicitExportArg(i);
lst = listCons(AbSyn)(arg, lst);
}
/* Make sure that the list is in the right order */
lst = listNReverse(AbSyn)(lst);
/* Return the absyn for the parameter list */
return abNewCommaL(sposNone, lst);
}
else
return ab1ImplicitExportArg((Length)0);
}
local void
tpossCons(TPoss tp, TForm t)
{
assert(tp);
t = tfFollowOnly(t);
tp->possl = listCons(TForm)(t, tp->possl);
tp->possc += 1;
}
Foam
gen0MakeDoubleCode(Foam foam, FoamList *plst)
{
FoamList lst;
Foam t1;
int format;
format = gen0MakeDoubleFormat();
t1 = gen0TempLocal0(FOAM_Rec, format);
lst = listNil(Foam);
lst = listCons(Foam)(gen0RNew(t1, format), lst);
lst = listCons(Foam)(gen0RSet(t1, format, (AInt) 0, foam), lst);
*plst = lst;
return foamNewCast(FOAM_Word, t1);
}
ListPtr
listAdjoin(char *car, ListPtr cdr)
{
if(listMember(car, cdr)) {
free(car);
return cdr;
}
return listCons(car, cdr);
}
Foam
gen0MakeFloatRecValue(Foam foam, FoamList *plst)
{
FoamList lst;
Foam t1, t2;
int format;
format = gen0MakeFloatFormat();
t1 = gen0TempLocal0(FOAM_Rec, format);
t2 = foamCopy(foam);
lst = listNil(Foam);
lst = listCons(Foam)(gen0RNew(t1, format), lst);
lst = listCons(Foam)(gen0RSet(t1, format, (AInt) 0, t2), lst);
*plst = lst;
return foamNewCast(FOAM_Word, t1);
}
/*
* Destructive copy of any complex number from the foam value `src'
* represented as a record with format `sfmt', into `dst' represented
* as a record with format `dfmt'. All the field types of `sfmt' and
* `dfmt' must be compatible. This means that this function may be used
* copy from a Fortran COMPLEX REAL into an Aldor Complex SF and vice
* versa. Similarly for COMPLEX DOUBLE/Complex DF. It must not be used
* to copy Complex SF to/from Complex DF or vice versa.
*
* IMPORTANT: this function adds statements to `*lst' which must be
* a valid list on entry.
*/
void
gen0CopyComplex(Foam dst, Foam src, AInt dfmt, AInt sfmt, FoamList *lst)
{
Foam tmp;
FoamList code = *lst;
/* Start with the imaginary part */
tmp = foamNewRElt(sfmt, foamCopy(src), (AInt)1);
tmp = gen0RSet(foamCopy(dst), dfmt, (AInt)1, tmp);
code = listCons(Foam)(tmp, code);
/* Finish with the real part */
tmp = foamNewRElt(sfmt, foamCopy(src), (AInt)0);
tmp = gen0RSet(foamCopy(dst), dfmt, (AInt)0, tmp);
code = listCons(Foam)(tmp, code);
/* No need to reverse the code list */
*lst = code;
}
void
vpFreeVar(VarPool pool, int var)
{
int type;
Foam decl;
decl = fboxNth(pool->fbox, var);
type = decl->foamDecl.type;
pool->vars[type] = listCons(AInt)(var, pool->vars[type]);
}
AbSynList
abqParseLines(StringList lines)
{
AbSynList result = listNil(AbSyn);
while (lines != listNil(String)) {
result = listCons(AbSyn)(abqParse(car(lines)), result);
lines = listFreeCons(String)(lines);
}
return listNReverse(AbSyn)(result);
}
/*
* Open a file, looking first in the current directory, then
* in the list of include directories.
*/
local FileName
inclFind(String fname, String curdir)
{
StringList dl;
FileName fn;
dl = listCons(String)(curdir, incSearchPath());
fn = fileRdFind(dl, fname, FTYPE_SRC);
listFreeCons(String)(dl);
return fn;
}
local void
saveAndEmptyPhaseSymbolData(Symbol sym)
{
if (symInfo(sym) && symCoInfo(sym) && symCoInfo(sym)->phaseVal.generic){
PhaseSymbolData psd =
(PhaseSymbolData) stoAlloc(OB_Other, sizeof(*psd));
psd->sym = sym;
psd->data = symCoInfo(sym)->phaseVal.generic;
psdl = listCons(PhaseSymbolData)(psd, psdl);
symCoInfo(sym)->phaseVal.generic = 0;
}
}
static ConfigItemList
uclInitialOptions()
{
ConfigItemList lst = listNil(ConfigItem);
int i = 0;
while (defaultOptions[i].name != NULL) {
lst = listCons(ConfigItem)(cfgNew(defaultOptions[i].name, defaultOptions[i].value),
lst);
i++;
}
return lst;
}
SymeList
symeListAddCondition(SymeList symes0, Sefo cond, Bool pos)
{
SymeList symes, nsymes = listNil(Syme);
for (symes = symes0; symes; symes = cdr(symes)) {
Syme nsyme = symeCopy(car(symes));
symeAddCondition(nsyme, cond, pos);
nsymes = listCons(Syme)(nsyme, nsymes);
}
return listNReverse(Syme)(nsymes);
}
void responseWrite(Response *response, int fd)
{
ListCell *buffer = NULL;
ListCell *header;
char sbuffer[2048];
// HEADERS
header = response->headers;
while (header) {
sprintf(sbuffer, "%s: %s\r\n",
((KV *)header->value)->key,
((KV *)header->value)->value);
buffer = listCons(sbuffer,
sizeof(char) * (strlen(sbuffer) + 1), buffer);
header = header->next;
}
// STATUS
sprintf(sbuffer, "HTTP/1.0 %d %s\r\n",
response->status,
STATUSES[response->status / 100 - 1][response->status % 100]);
buffer = listCons(sbuffer, sizeof(char) * (strlen(sbuffer) + 1), buffer);
// OUTPUT
while (buffer) {
write(fd, buffer->value, strlen(buffer->value));
buffer = buffer->next;
}
write(fd, "\r\n", 2);
if (response->body)
write(fd, response->body, bsGetLen(response->body));
}
DepDag
depdagAddDependency(DepDag dag, DepDag dep)
{
DepDagList dags = depdagDependsOn(dag);
/* Check that it isn't a known dependency */
if (!listMemq(DepDag)(dags, dep))
depdagSetDependsOn(dag, listCons(DepDag)(dep, dags));
/* Return the modified dag */
return dag;
}
/*
* Construct the parameter list for the function
*/
local FoamList
gen0ImplicitExportArgs(TForm tf)
{
Foam par;
FoamList lst = listNil(Foam);
Length i, numargs;
/* How many parameters does this function have? */
numargs = tfIsMulti(tf) ? tfMultiArgc(tf) : 1;
/* Deal with single and multiple arguments separately */
if (numargs > 1)
{
/* Process each argument */
for (i = 0;i < numargs;i++)
{
/* Get the next argument */
TForm t = tfMultiArgN(tf, i);
par = gen1ImplicitExportArg(t, (Length)i);
lst = listCons(Foam)(par, lst);
}
}
else if (numargs == 1)
{
/* A single argument */
par = gen1ImplicitExportArg(tf, (Length)0);
lst = listCons(Foam)(par, lst);
}
/* Reverse the list and return it */
lst = listNReverse(Foam)(lst);
return lst;
}
local void
testAblog()
{
initFile();
ablogDebug = 0;
String Boolean_imp = "import from Boolean";
String C0_def = "C0: Category == with";
String C1_def = "C1: Category == C0 with";
String D0_def = "D0: C0 with == add";
String D1_def = "D1: C1 with == add";
StringList lines = listList(String)(5, Boolean_imp, C0_def, C1_def, D0_def, D1_def);
AbSynList code = listCons(AbSyn)(stdtypes(), abqParseLines(lines));
AbSyn absyn = abNewSequenceL(sposNone, code);
abPutUse(absyn, AB_Use_NoValue);
Stab file = stabFile();
Stab stab = stabPushLevel(file, sposNone, STAB_LEVEL_LARGE);
scopeBind(stab, absyn);
typeInfer(stab, absyn);
testTrue("Declare is sefo", abIsSefo(absyn));
testIntEqual("Error Count", 0, comsgErrorCount());
Syme C0 = uniqueMeaning(stab, "C0");
Syme C1 = uniqueMeaning(stab, "C1");
Syme D0 = uniqueMeaning(stab, "D0");
Syme D1 = uniqueMeaning(stab, "D1");
AbSyn sefo1 = has(abFrSyme(D1), abFrSyme(C1));
AbSyn sefo0 = has(abFrSyme(D1), abFrSyme(C0));
tiSefo(stab, sefo0);
tiSefo(stab, sefo1);
AbLogic cond0 = ablogFrSefo(sefo0);
AbLogic cond1 = ablogFrSefo(sefo1);
afprintf(dbOut, "Implies: %pAbLogic %pAbLogic %d\n", cond1, cond0, ablogImplies(cond1, cond0));
afprintf(dbOut, "Implies: %pAbLogic %pAbLogic %d\n", cond0, cond1, ablogImplies(cond0, cond1));
testTrue("00", ablogImplies(cond0, cond0));
testTrue("10", ablogImplies(cond1, cond0));
testFalse("01",ablogImplies(cond0, cond1));
testTrue("11", ablogImplies(cond1, cond1));
}
Foam
genYield(AbSyn absyn)
{
/* set the place variable */
gen0AddStmt(foamNewSet(yieldPlaceVar,
foamNewSInt(++gen0State->yieldCount)), absyn);
gen0AddStmt(foamNewSet(foamCopy(gen0State->yieldValueVar),
genFoamVal(absyn->abYield.value)), absyn);
gen0AddStmt(foamNewGoto(gen0State->yieldPlace), absyn);
gen0AddStmt(foamNewLabel(gen0State->labelNo), absyn);
gen0State->yieldLabels = listCons(AInt)(gen0State->labelNo++,
gen0State->yieldLabels);
return 0;
}
static void
uclAddSysArgs(StringList *plst, char *opts)
{
char **argv;
int i, argc;
if (opts[0] == '\0') {
*plst = listSingleton(String)("\0");
return;
}
cstrParseCommaified(opts, &argc, &argv);
for (i=0; i<argc; i++)
*plst = listNConcat(String)(*plst, listCons(String)(argv[i], listNil(String)));
stoFree(argv);
}
Bool
errorSetPrintf(ErrorSet errors, Bool test, String format, ...)
{
String message;
va_list argp;
if (test)
return true;
va_start(argp, format);
message = vaStrPrintf(format, argp);
va_end(argp);
errorSetAdd(errors, message);
errors->alloc = listCons(String)(message, errors->alloc);
return false;
}
TConst
tcAlloc(TConstTag tag, TForm owner, AbLogic known, AbSyn ab0, Length argc, va_list argp)
{
TConst tc;
Length i;
assert(owner == NULL || tfIsPending(owner));
tc = (TConst) stoAlloc((unsigned) OB_TConst,
sizeof(*tc) + argc * sizeof(TForm));
tc->tag = tag;
tc->pos = NULL;
tc->parent = NULL;
tc->id = NULL;
tc->known = known;
tc->serial = ++tcSerialNum;
tc->owner = owner;
tc->ab0 = ab0;
tc->argc = argc;
tc->argv = (argc ? (TForm *) (tc + 1) : NULL);
for (i = 0; i < argc; i += 1)
tcArgv(tc)[i] = va_arg(argp, TForm);
for (i = 0; i < argc; i += 1) {
AbSyn abi = tfGetExpr(tcArgv(tc)[i]);
if (abi && !sposIsNone(abPos(abi))) {
tcPos(tc) = abi;
break;
}
}
assert(owner == NULL || tcParents);
if (tcParents) tcSetParent(tc, car(tcParents));
if (owner == NULL)
tcParents = listCons(TConst)(tc, tcParents);
else {
if (DEBUG(tc)) {
listPush(TConst, tc, tcList);
}
tcCount += 1;
}
return tc;
}