int node_compare(ast_node_t tok1, ast_node_t tok2) {
if(tok1==tok2) {
return 0;
}
if(isNil(tok1)) {
return isNil(tok2)?0:-1;
} else if(isNil(tok2)) {
return 1;
} else if(isAtom(tok1)) {
return isPair(tok2)
? 1
: isAtom(tok2)
? strcmp(node_compare_tag(Value(tok1)), node_compare_tag(Value(tok2)))
: 0;
} else if(isPair(tok1)) {
if(isPair(tok2)) {
int ret = node_compare(Car(tok1), Car(tok2));
return ret?ret:node_compare(Cdr(tok1), Cdr(tok2));
} else {
return 1;
}
}
return tok1>tok2?1:-1;
}
static bool printlist (Tree l, FILE* out)
{
if (isList(l)) {
char sep = '(';
do {
fputc(sep, out); sep = ',';
print(hd(l));
l = tl(l);
} while (isList(l));
if (! isNil(l)) {
fprintf(out, " . ");
print(l, out);
}
fputc(')', out);
return true;
} else if (isNil(l)) {
fprintf(out, "nil");
return true;
} else {
return false;
}
}
// (loop ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
any doLoop(any ex) {
any x, y, a;
for (;;) {
x = cdr(ex);
do {
if (isCell(y = car(x))) {
if (isNil(car(y))) {
y = cdr(y);
if (isNil(a = EVAL(car(y))))
return prog(cdr(y));
val(At) = a;
}
else if (car(y) == T) {
y = cdr(y);
if (!isNil(a = EVAL(car(y)))) {
val(At) = a;
return prog(cdr(y));
}
}
else
evList(y);
}
} while (isCell(x = cdr(x)));
}
}
/**
* Search the environment for the definition of a symbol
* ID and evaluate it. Detects recursive definitions using
* a set of visited IDxENV. Associates the symbol as a definition name
* property of the definition.
* @param id the symbol ID t-o search
* @param visited set of visited symbols (used for recursive definition detection)
* @param lenv the environment where to search
* @return the evaluated definition of ID
*/
static Tree evalIdDef(Tree id, Tree visited, Tree lenv)
{
Tree def = NULL;
Tree name = NULL;
// search the environment env for a definition of symbol id
while (!isNil(lenv) && !getProperty(lenv, id, def)) {
lenv = lenv->branch(0);
}
// check that the definition exists
if (isNil(lenv)) {
evalerror(getDefFileProp(id), getDefLineProp(id), "undefined symbol", id);
}
//cerr << "Id definition is " << *def << endl;
// check that it is not a recursive definition
Tree p = cons(id,lenv);
// set the definition name property
assert(def);
if (!getDefNameProperty(def, name)) {
// if the definition has no name use the identifier
stringstream s; s << boxpp(id);
//XXXXXX setDefNameProperty(def, s.str());
}
// return the evaluated definition
return eval(def, addElement(p,visited), gGlobal->nil);
}
ClassBuilder &ClassBuilder::setSuperclass(Class *superClass, Metaclass *metaSuper)
{
// Copy the format from the super class
clazz->superclass = superClass;
if(!isNil(superClass))
{
clazz->format = superClass->format;
clazz->fixedVariableCount = superClass->fixedVariableCount;
}
else
{
clazz->format = Oop::encodeSmallInteger(OF_EMPTY);
clazz->fixedVariableCount = Oop::encodeSmallInteger(0);
}
// Set the meta class super class.
metaclass->superclass = metaSuper;
// Set the meta class format and fixed size
metaclass->format = metaSuper->format;
metaclass->fixedVariableCount = metaSuper->fixedVariableCount;
if(isNil(superClass))
{
metaclass->format = Oop::encodeSmallInteger(OF_FIXED_SIZE);
metaclass->fixedVariableCount = Oop::encodeSmallInteger(Class::ClassVariableCount);
}
return *this;
}
static void putSrc(any s, any k) {
if (!isNil(val(Dbg)) && !isExt(s) && InFile && InFile->name) {
any x, y;
cell c1;
Push(c1, boxCnt(InFile->src));
data(c1) = cons(data(c1), mkStr(InFile->name));
x = get(s, Dbg);
if (!k) {
if (isNil(x))
put(s, Dbg, cons(data(c1), Nil));
else
car(x) = data(c1);
}
else if (isNil(x))
put(s, Dbg, cons(Nil, cons(data(c1), Nil)));
else {
for (y = cdr(x); isCell(y); y = cdr(y))
if (caar(y) == k) {
cdar(y) = data(c1);
drop(c1);
return;
}
cdr(x) = cons(cons(k, data(c1)), cdr(x));
}
drop(c1);
}
}
// ($ sym|lst lst . prg) -> any
any doTrace(any x) {
any foo, body;
outFile *oSave;
void (*putSave)(int);
cell c1;
x = cdr(x);
if (isNil(val(Dbg)))
return prog(cddr(x));
oSave = OutFile, putSave = Env.put;
OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout;
foo = car(x);
x = cdr(x), body = cdr(x);
traceIndent(++Env.trace, foo, " :");
for (x = car(x); isCell(x); x = cdr(x))
space(), print(val(car(x)));
if (!isNil(x)) {
if (x != At)
space(), print(val(x));
else {
int i = Env.next;
while (--i >= 0)
space(), print(data(Env.arg[i]));
}
}
newline();
Env.put = putSave, OutFile = oSave;
Push(c1, prog(body));
OutFile = OutFiles[STDERR_FILENO], Env.put = putStdout;
traceIndent(Env.trace--, foo, " = "), print(data(c1));
newline();
Env.put = putSave, OutFile = oSave;
return Pop(c1);
}
Tree setIntersection (Tree A, Tree B)
{
if (isNil(A)) return A;
if (isNil(B)) return B;
if (hd(A) == hd(B)) return cons(hd(A), setIntersection(tl(A),tl(B)));
if (hd(A) < hd(B)) return setIntersection(tl(A),B);
/* (hd(A) > hd(B)*/ return setIntersection(A,tl(B));
}
Tree setDifference (Tree A, Tree B)
{
if (isNil(A)) return A;
if (isNil(B)) return A;
if (hd(A) == hd(B)) return setDifference(tl(A),tl(B));
if (hd(A) < hd(B)) return cons(hd(A), setDifference(tl(A),B));
/* (hd(A) > hd(B)*/ return setDifference(A,tl(B));
}
Tree setUnion (Tree A, Tree B)
{
if (isNil(A)) return B;
if (isNil(B)) return A;
if (hd(A) == hd(B)) return cons(hd(A), setUnion(tl(A),tl(B)));
if (hd(A) < hd(B)) return cons(hd(A), setUnion(tl(A),B));
/* hd(A) > hd(B) */ return cons(hd(B), setUnion(A,tl(B)));
}
/**
* Transform a list of expressions in a parallel construction
*
* @param larg list of expressions
* @return parallel construction
*/
static Tree larg2par(Tree larg)
{
if (isNil(larg)) {
evalerror(yyfilename, -1, "empty list of arguments", larg);
}
if (isNil(tl(larg))) {
return hd(larg);
}
return boxPar(hd(larg), larg2par(tl(larg)));
}
static bool boxlistOutputs(Tree boxlist, int* outputs)
{
int ins, outs;
*outputs = 0;
while (!isNil(boxlist) && getBoxType(hd(boxlist), &ins, &outs)) {
*outputs += outs;
boxlist = tl(boxlist);
}
return isNil(boxlist);
}
// (do 'flg|num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
any doDo(any x) {
any y, z, a;
cell c1;
x = cdr(x);
if (isNil(data(c1) = EVAL(car(x))))
return Nil;
Save(c1);
if (isNum(data(c1))) {
if (isNeg(data(c1))) {
drop(c1);
return Nil;
}
data(c1) = bigCopy(data(c1));
}
x = cdr(x), z = Nil;
for (;;) {
if (isNum(data(c1))) {
if (IsZero(data(c1))) {
drop(c1);
return z;
}
digSub1(data(c1));
}
y = x;
do {
if (!isNum(z = car(y))) {
if (isSym(z))
z = val(z);
else if (isNil(car(z))) {
z = cdr(z);
if (isNil(a = EVAL(car(z)))) {
drop(c1);
return prog(cdr(z));
}
val(At) = a;
z = Nil;
}
else if (car(z) == T) {
z = cdr(z);
if (!isNil(a = EVAL(car(z)))) {
val(At) = a;
drop(c1);
return prog(cdr(z));
}
z = Nil;
}
else
z = evList(z);
}
} while (isCell(y = cdr(y)));
}
}
void append(List& xs, List& ys){
if(isNil(xs)){
xs = ys;
}
else{
if(not(isNil(ys))){
xs -> last -> next = ys -> first;
xs -> last = ys -> last;
delete(ys);
}
}
}
API value_t list_append(value_t list, value_t values) {
if (isNil(list)) return values;
value_t node = list;
while (node.type == PairType) {
value_t next = cdr(node);
if (isNil(next)) {
set_cdr(node, values);
return list;
}
node = next;
}
return Undefined;
}
API value_t list_add(value_t list, value_t val) {
if (isNil(list)) return cons(val, Nil);
value_t node = list;
while (node.type == PairType) {
pair_t pair = get_pair(node);
if (eq(pair.left, val)) return list;
if (isNil(pair.right)) {
set_cdr(node, cons(val, Nil));
return list;
}
node = pair.right;
}
return TypeError;
}
static status
initialiseTileAdjuster(TileAdjuster p, TileObj t)
{ Image img = getClassVariableValueObject(p, NAME_image);
Size size;
CursorObj crs;
BitmapObj bm;
if ( isNil(t->super) )
return errorPce(p, NAME_noSubTile, t);
if ( t->super->orientation == NAME_horizontal )
{ img = getClassVariableValueObject(p, NAME_himage);
crs = getClassVariableValueObject(p, NAME_horizontalResizeCursor);
} else
{ img = getClassVariableValueObject(p, NAME_vimage);
crs = getClassVariableValueObject(p, NAME_verticalResizeCursor);
}
size = getCopySize(img->size);
initialiseWindow((PceWindow) p, NAME_adjuster, size, DEFAULT);
assign(p, pen, ZERO);
assign(p, cursor, crs);
assign(p, orientation, t->super->orientation);
send(p, NAME_display, bm=newObject(ClassBitmap, img, EAV), EAV);
/*send(bm, NAME_cursor, crs, EAV);*/
assign(t, adjuster, p);
assign(p, client, t);
succeed;
}
/**
* Iterate generateMacroInterfaceTree on a list of user interface elements
*/
void Compiler::generateMacroInterfaceElements(const string& pathname, Tree elements)
{
while (!isNil(elements)) {
generateMacroInterfaceTree(pathname, right(hd(elements)));
elements = tl(elements);
}
}
/**
* Iterate generateUserInterfaceTree on a list of user interface elements
*/
void Compiler::generateUserInterfaceElements(Tree elements)
{
while (!isNil(elements)) {
generateUserInterfaceTree(right(hd(elements)));
elements = tl(elements);
}
}
static Int
getArityObtain(Obtain msg)
{ if ( isNil(msg->arguments) )
answer(TWO);
else
answer(add(msg->arguments->size, TWO));
}
void KDSoapValue::writeElementContents(KDSoapNamespacePrefixes &namespacePrefixes, QXmlStreamWriter &writer, KDSoapValue::Use use, const QString &messageNamespace) const
{
const QVariant value = this->value();
if (isNil() && d->m_nillable) {
writer.writeAttribute(KDSoapNamespaceManager::xmlSchemaInstance2001(), QLatin1String("nil"), QLatin1String("true"));
}
if (use == EncodedUse) {
// use=encoded means writing out xsi:type attributes. http://www.eherenow.com/soapfight.htm taught me that.
QString type;
if (!this->type().isEmpty()) {
type = namespacePrefixes.resolve(this->typeNs(), this->type());
}
if (type.isEmpty() && !value.isNull()) {
type = variantToXMLType(value); // fallback
}
if (!type.isEmpty()) {
writer.writeAttribute(KDSoapNamespaceManager::xmlSchemaInstance2001(), QLatin1String("type"), type);
}
// cppcheck-suppress redundantCopyLocalConst
const KDSoapValueList list = this->childValues();
const bool isArray = !list.arrayType().isEmpty();
if (isArray) {
writer.writeAttribute(KDSoapNamespaceManager::soapEncoding(), QLatin1String("arrayType"), namespacePrefixes.resolve(list.arrayTypeNs(), list.arrayType()) + QLatin1Char('[') + QString::number(list.count()) + QLatin1Char(']'));
}
}
writeChildren(namespacePrefixes, writer, use, messageNamespace, false);
if (!value.isNull()) {
writer.writeCharacters(variantToTextValue(value, this->typeNs(), this->type()));
}
}
// (new ['flg|num] ['typ ['any ..]]) -> obj
any doNew(any ex) {
any x, y, *h;
cell c1, c2;
x = cdr(ex);
if (isCell(y = EVAL(car(x))))
Push(c1, consSym(y,Nil));
else {
if (isNil(y))
data(c1) = consSym(Nil,Nil);
else {
y = newId(ex, isNum(y)? (int)unDig(y)/2 : 1);
if (data(c1) = findHash(y, h = Extern + ehash(y)))
tail(data(c1)) = y;
else
*h = cons(data(c1) = consSym(Nil,y), *h);
mkExt(data(c1));
}
Save(c1);
x = cdr(x), val(data(c1)) = EVAL(car(x));
}
TheKey = T, TheCls = NULL;
if (y = method(data(c1)))
evMethod(data(c1), y, cdr(x));
else {
Push(c2, Nil);
while (isCell(x = cdr(x))) {
data(c2) = EVAL(car(x)), x = cdr(x);
put(data(c1), data(c2), EVAL(car(x)));
}
}
return Pop(c1);
}
static Tree privatisation (const Tree& k, const Tree& t)
{
Tree v;
if (t->arity() == 0) {
return t;
} else if (getProperty(t, k, v)) {
/* Terme deja visité. La propriété nous indique
la version privatisée ou nil si elle est identique
au terme initial.
*/
return isNil(v) ? t : v;
} else {
/* Calcul du terme privatisé et mis à jour
de la propriété. Nil indique que le terme
privatisé est identique à celui de depart
(pour eviter les boucles avec les compteurs
de references)
*/
v = computePrivatisation(k,t);
if (v != t) {
setProperty(t, k, v );
} else {
setProperty(t, k, nil);
}
return v;
}
}
Tree buildBoxAppl(Tree fun, Tree revarglist)
{
if(isNil(revarglist))
exit(1); // a revoir !!!!!!
return boxAppl(fun, revarglist);
}
lcpp::Ptr<lcpp::LispObject>
lcpp::LispFunction_UserDefined::call(Ptr<LispObject> pArgList)
{
EZ_ASSERT(m_pBody, "The function body MUST be valid!");
RecursionCounter counter(LispRuntime::instance());
auto pEnv = LispEnvironment::create(m_pName, m_pParentEnv);
// Process args
//////////////////////////////////////////////////////////////////////////
processArguments(pEnv, pArgList);
// Process body
//////////////////////////////////////////////////////////////////////////
Ptr<LispObject> pCodePointer = m_pBody;
Ptr<LispObject> pResult = LCPP_NIL;
while(!isNil(pCodePointer))
{
EZ_ASSERT(pCodePointer->is<LispCons>(), "Function body must be a cons.");
auto pCons = pCodePointer.cast<LispCons>();
pResult = LispRuntime::instance()->evaluator()->evalulate(pEnv, pCons->car());
pCodePointer = pCons->cdr();
}
return pResult;
}
static void list2vec(Tree l, vector<Tree>& v)
{
while (!isNil(l)) {
v.push_back(hd(l));
l = tl(l);
}
}
void Description::addGroup(int level, Tree t)
{
Tree label, elements, varname, sig;
const char* groupnames[] =
{
"vgroup", "hgroup", "tgroup"
};
if(isUiFolder(t, label, elements))
{
const int orient = tree2int(left(label));
addLayoutLine(level, subst("<group type=\"$0\">", groupnames[orient]));
addLayoutLine(level + 1, subst("<label>$0</label>", checkNullLabel(t, xmlize(tree2str(right(label))), false)));
while(!isNil(elements))
{
addGroup(level + 1, right(hd(elements)));
elements = tl(elements);
}
addLayoutLine(level, "</group>");
}
else if(isUiWidget(t, label, varname, sig))
{
int w = addWidget(label, varname, sig);
addLayoutLine(level, subst("<widgetref id=\"$0\" />", T(w)));
}
else
{
fprintf(stderr, "error in user interface generation 2\n");
exit(1);
}
}
void
assocObjectToHWND(HWND hwnd, Any obj)
{ int key = handleKey(hwnd);
WinAssoc *p = &wintable[key];
WinAssoc a = *p;
if ( !lock_initialized ) /* we are serialized by the XPCE */
{ lock_initialized = TRUE; /* lock, so this must be safe */
InitializeCriticalSection(&lock);
}
if ( isNil(obj) ) /* delete from table */
{ EnterCriticalSection(&lock);
for( ; a ; p = &a->next, a = a->next )
{ if ( a->hwnd == hwnd )
{ *p = a->next;
unalloc(sizeof(winassoc), a);
break;
}
}
LeaveCriticalSection(&lock);
/* not in the table!? */
} else
{ WinAssoc n = alloc(sizeof(winassoc));
n->hwnd = hwnd;
n->object = obj;
n->next = *p;
*p = n;
}
DEBUG(NAME_window, Cprintf("Binding 0x%04x --> %s\n", hwnd, pp(obj)));
}
static Tree subst (Tree t, Tree propkey, Tree id, Tree val)
{
Tree p;
if (t==id) {
return val;
} else if (t->arity() == 0) {
return t;
} else if (getProperty(t, propkey, p)) {
return (isNil(p)) ? t : p;
} else {
tvec br;
int n = t->arity();
for (int i = 0; i < n; i++) {
br.push_back( subst(t->branch(i), propkey, id, val) );
}
Tree r = tree(t->node(), br);
if (r == t) {
setProperty(t, propkey, gGlobal->nil);
} else {
setProperty(t, propkey, r);
}
return r;
}
}
Tree tmap (Tree key, tfun f, Tree t)
{
//printf("start tmap\n");
Tree p;
if (getProperty(t, key, p)) {
return (isNil(p)) ? t : p; // truc pour eviter les boucles
} else {
tvec br;
int n = t->arity();
for (int i = 0; i < n; i++) {
br.push_back( tmap(key, f, t->branch(i)) );
}
Tree r1 = tree(t->node(), br);
Tree r2 = f(r1);
if (r2 == t) {
setProperty(t, key, gGlobal->nil);
} else {
setProperty(t, key, r2);
}
return r2;
}
}
