bool subtype(node s, node t){
if (ispos(s)) s = s->body.position.contents;
if (ispos(t)) t = t->body.position.contents;
assert(istype(s) && istype(t));
s = typeforward(s);
t = typeforward(t);
if (s == t) return TRUE;
if (s == bad_or_undefined_T || t == bad_or_undefined_T) return TRUE;
if (isortype(s) && isortype(t)) {
int i, j, slen, tlen;
s = typedeftail(s); slen = length(s);
t = typedeftail(t); tlen = length(t);
for (i=1; i<=slen; i++) {
for (j=1; j<=tlen; j++) {
if (subtype(nth(s,i),nth(t,j))) goto okay;
}
return FALSE;
okay:;
}
return TRUE;
}
if (isortype(s)) return FALSE;
if (isortype(t)) {
int j, tlen;
t = typedeftail(t); tlen = length(t);
for (j=1; j<=tlen; j++) {
if (subtype(s,nth(t,j))) return TRUE;
}
return FALSE;
}
return FALSE; /* for other types, we assume that totypesRec has worked and made equivalent types identical */
}
LISP evalclosure (LISP func, LISP expr)
{
LISP ctx = closurectx (func), body = closurebody (func);
LISP arg = car (body);
/* Расширяем контекст аргументами вызова */
while (istype (arg, TPAIR)) {
LISP val;
if (istype (expr, TPAIR)) {
val = car (expr);
expr = cdr (expr);
} else
/* Недостающие аргументы получают значение NIL */
val = NIL;
if (istype (car (arg), TSYMBOL))
ctx = cons (cons (car (arg), val), ctx);
arg = cdr (arg);
}
if (istype (arg, TSYMBOL))
ctx = cons (cons (arg, expr), ctx);
if (trace) {
printf ("CALL ");
putexpr (cdr (body), stdout);
printf ("\nCONTEXT ");
putexpr (ctx, stdout);
printf ("\n");
}
return (evalblock (cdr (body), ctx));
}
node typeforward(node e){
assert(istype(e));
while (e->body.type.forward != NULL) {
assert(istype(e->body.type.forward));
e = e->body.type.forward;
}
return e;
}
LISP quasiquote (LISP expr, LISP ctx, int level)
{
LISP val, tail, func, v;
if (! istype (expr, TPAIR))
return (expr);
if (istype (func = car (expr), TSYMBOL)) {
char *funcname = symname (func);
if (!strcmp (funcname, "quasiquote")) {
v = !istype (v = cdr (expr), TPAIR) ? NIL :
quasiquote (car (v), ctx, level+1);
return (cons (func, cons (v, NIL)));
}
if (!strcmp (funcname, "unquote") ||
!strcmp (funcname, "unquote-splicing")) {
if (!istype (v = cdr (expr), TPAIR))
return (level ? expr : NIL);
if (level)
return (cons (func, cons (quasiquote (car (v),
ctx, level-1), NIL)));
return (eval (car (v), &ctx));
}
}
tail = val = cons (NIL, NIL);
for (;;) {
v = car (expr);
if (! istype (v, TPAIR))
setcar (tail, v);
else if (istype (func = car (v), TSYMBOL) &&
!strcmp (symname (func), "unquote-splicing")) {
if (!istype (v = cdr (v), TPAIR)) {
if (level)
setcar (tail, car (expr));
} else if (level)
setcar (tail, cons (func,
cons (quasiquote (car (v), ctx,
level-1), NIL)));
else {
v = eval (car (v), &ctx);
if (istype (v, TPAIR)) {
LISP newtail;
setcar (tail, car (v));
setcdr (tail, copy (cdr (v), &newtail));
tail = newtail;
} else if (v != NIL) {
setcar (tail, v);
setcdr (tail, cons (NIL, NIL));
tail = cdr (tail);
}
}
} else
setcar (tail, quasiquote (v, ctx, level));
if (! istype (expr = cdr (expr), TPAIR)) {
setcdr (tail, expr);
return (val);
}
setcdr (tail, cons (NIL, NIL));
tail = cdr (tail);
}
}
int equal (LISP a, LISP b) /* рекурсивное сравнение */
{
if (a == b)
return (1);
while (istype (a, TPAIR)) {
if (! istype (b, TPAIR) || ! equal (car (a), car (b)))
return (0);
a = cdr (a);
b = cdr (b);
}
return (eqv (a, b));
}
LISP evalfunc (LISP func, LISP arg, LISP ctx)
{
/* Встроенная функция */
if (istype (func, THARDW))
return ((*hardwval (func)) (arg, ctx));
/* Обычная функция, вычисляем ее значение */
if (istype (func, TCLOSURE))
return (evalclosure (func, arg));
/* Ни то ни се, игнорируем */
return (NIL);
}
bool iscompositeortype(node e){
node f;
assert(istype(e));
e = typeforward(e);
f = e->body.type.definition;
return iscons(f) && car(f) == or_K && (e->body.type.flags & composite_F);
}
static void debug_dumptypedefs(NAMESPACEVALUES *nameSpace)
{
int i;
HASHTABLE *syms = nameSpace->syms;
for (i = 0; i < syms->size; i++)
{
HASHREC *h = syms->table[i];
if (h != 0)
{
while (h)
{
SYMBOL *sp = (SYMBOL *)h->p;
if (sp->storage_class == sc_namespace)
{
debug_dumptypedefs(sp->nameSpaceValues);
}
else
if (istype(sp))
chosenDebugger->outputtypedef(sp);
h = h->next;
}
}
}
}
node arrayElementType(node arraytype){
node m, n;
if (istype(arraytype)) m = typedeftail(arraytype);
else m = cdr(arraytype);
n = car(m);
return typeforward(n);
}
BOOLEAN startOfType(LEXEME *lex, BOOLEAN assumeType)
{
if (!lex)
return FALSE;
if (lex->type == l_id)
{
TEMPLATEPARAM *tparam = TemplateLookupSpecializationParam(lex->value.s.a);
if (tparam)
{
return tparam->type == kw_typename || tparam->type == kw_template;
}
}
if (lex->type == l_id || MATCHKW(lex, classsel))
{
SYMBOL *sp, *strSym = NULL;
LEXEME *placeholder = lex;
BOOLEAN dest = FALSE;
nestedSearch(lex, &sp, &strSym, NULL, &dest, NULL, FALSE, sc_global, FALSE, FALSE);
if (cparams.prm_cplusplus)
prevsym(placeholder);
return (sp && istype(sp)) || (assumeType && strSym && (strSym->tp->type == bt_templateselector || strSym->tp->type == bt_templatedecltype));
}
else
{
return KWTYPE(lex, TT_POINTERQUAL | TT_LINKAGE | TT_BASETYPE | TT_STORAGE_CLASS | TT_TYPENAME);
}
}
LISP copy (LISP a, LISP *t)
{
LISP val, tail;
if (! istype (a, TPAIR))
return (NIL);
tail = val = cons (NIL, NIL);
for (;;) {
setcar (tail, car (a));
if (! istype (a = cdr (a), TPAIR))
break;
setcdr (tail, cons (NIL, NIL));
tail = cdr (tail);
}
if (t)
*t = tail;
return (val);
}
bool israwtypeexpr(node e) {
while (ispos(e)) e = e->body.position.contents;
while (issym(e)) {
if (e->body.symbol.type != type__T) return FALSE;
e = e->body.symbol.value;
}
if (!istype(e)) return FALSE;
return israwtype(e);
}
LISP evalblock (LISP expr, LISP ctx)
{
/* Вычисление блока в отдельном контексте */
LISP value = NIL;
while (istype (expr, TPAIR)) {
value = eval (car (expr), &ctx);
expr = cdr (expr);
}
return (value);
}
bool forwardtype(node old,node newn){
assert(istype(old));
assert(istype(newn));
assert(old->body.type.flags & deferred_F);
assert(old != deferred__T);
old->body.type.flags &= ~deferred_F;
if ((old->body.type.flags & should_be_pointer_F) && !ispointertype(newn)) {
errorpos(newn,"expected a pointer type");
return FALSE;
}
old->body.type.flags &= ~should_be_pointer_F;
if ((old->body.type.flags & should_be_tagged_F) && !istaggedtype(newn)) {
errorpos(newn,"expected a tagged pointer type");
return FALSE;
}
old->body.type.flags &= ~should_be_tagged_F;
old->body.type.forward = typeforward(newn);
return TRUE;
}
bool istaggedarraytypeexpr(node e){
while (ispos(e)) e = e->body.position.contents;
while (issym(e)) {
if (e->body.symbol.type != type__T) return FALSE;
e = e->body.symbol.value;
}
if (istype(e)) return istaggedarraytype(e);
if (!iscons(e)) return FALSE;
return equal(car(e),tarray_K);
}
static void psymbol(node s){
assertpos(s->tag == symbol_tag,s);
cprint(s->body.symbol.name);
if (s->body.symbol.cprintvalue) {
put("\n cprintvalue => ");
cprint(s->body.symbol.cprintvalue);
put("\n ");
}
if (s->body.symbol.Cname != NULL) {
put("\n Cname => ");
put(s->body.symbol.Cname);
}
put("\n type => ");
pprint(s->body.symbol.type);
put("\n value => ");
if (s->body.symbol.value != NULL) {
node val = s->body.symbol.value;
if (istype(val) && val->body.type.name == s) {
pprint(val->body.type.definition);
}
else pprint(val);
}
else {
put("none");
}
put("\n flags:");
if (s->body.symbol.flags & macro_function_F) put(" macro-function");
if (s->body.symbol.flags & macro_variable_F) put(" macro-variable");
if (s->body.symbol.flags & readonly_F) put(" readonly");
if (s->body.symbol.flags & symbol_F) put(" symbol");
if (s->body.symbol.flags & keyword_F) put(" keyword");
if (s->body.symbol.flags & constant_F) put(" constant");
if (s->body.symbol.flags & defined_F) put(" initialized");
if (s->body.symbol.flags & export_F) put(" export");
if (s->body.symbol.flags & import_F) put(" import");
if (s->body.symbol.flags & threadLocal_F) put(" thread");
if (s->body.symbol.flags & const_F) put(" const");
if (s->body.symbol.flags & global_F) put(" global");
if (s->body.symbol.flags & literal_F) put(" literal");
if (s->body.symbol.flags & visible_F) put(" visible");
if ( !(s->body.symbol.flags & defined_F) && !(s->body.symbol.flags & import_F) ) put(" (never initialized)");
if (s->body.symbol.args != NULL) {
put("\n args => ");
cprintlist(s->body.symbol.args);
}
if (s->body.symbol.body != NULL) {
put("\n body => ");
pprint(s->body.symbol.body);
}
if (s->body.symbol.export_list != NULL) {
put("\n export_list => ");
cprintlist(s->body.symbol.export_list);
}
pput("\n");
}
int haswidth(char *fstr)
{
while (isprecision(*fstr) == 0 && islength(*fstr) == 0 &&
istype(*fstr) == 0 && *fstr != '\0')
{
if (*fstr == '*' || ft_isdigit(*fstr))
return (1);
fstr++;
}
return (0);
}
LISP evallist (LISP expr, LISP ctx)
{
LISP val, tail;
tail = val = cons (NIL, NIL);
for (;;) {
setcar (tail, eval (car (expr), &ctx));
if (! istype (expr = cdr (expr), TPAIR))
return (val);
setcdr (tail, cons (NIL, NIL));
tail = cdr (tail);
}
}
bool is_atomic_memory(node t){
assert(istype(t));
if (isobjecttype(t) || istaggedobjecttype(t)) return FALSE;
if (isortype(t)) return FALSE;
if (isarraytype(t)||istaggedarraytype(t)) return FALSE;
if (t->body.type.flags & raw_pointer_type_F) return FALSE;
if (t->body.type.flags & raw_atomic_pointer_type_F) return FALSE;
if (t->body.type.flags & raw_type_F) return FALSE;
if (t->body.type.flags & raw_atomic_type_F) return TRUE;
if (isbasictype(t)) return TRUE;
assert(FALSE);
return FALSE;
}
void putexpr (LISP p, FILE *fd)
{
LISP h, a;
if (! istype (p, TPAIR)) {
putatom (p, fd);
return;
}
if (istype (h = car (p), TSYMBOL) &&
istype (a = cdr (p), TPAIR) &&
cdr (a) == NIL) {
char *funcname = symname (h);
if (!strcmp (funcname, "quote")) {
putc ('\'', fd);
putexpr (car (a), fd);
return;
}
if (!strcmp (funcname, "quasiquote")) {
putc ('`', fd);
putexpr (car (a), fd);
return;
}
if (!strcmp (funcname, "unquote")) {
putc (',', fd);
putexpr (car (a), fd);
return;
}
if (!strcmp (funcname, "unquote-splicing")) {
putc (',', fd);
putc ('@', fd);
putexpr (car (a), fd);
return;
}
}
putc ('(', fd);
putlist (p, fd);
putc (')', fd);
}
struct POS *pos(node n) {
struct POS *p;
while (iscons(n)) {
if (n->body.cons.pos.filename != NULL) return &n->body.cons.pos;
p = pos(CAR(n));
if (p != NULL) return p;
n = CDR(n);
}
return (
ispos(n) ? &n->body.position.pos
: issym(n) && n->body.symbol.pos.filename != NULL ? &n->body.symbol.pos
: istype(n) && n->body.type.name != NULL ? pos(n->body.type.name)
: NULL );
}
bool pointer_to_atomic_memory(node t){
/* return true if the memory allocated for an object of type t contains no pointers */
assert(istype(t));
if (isobjecttype(t) || istaggedobjecttype(t)) {
node m;
for (m=typedeftail(t); m != NULL; m = CDR(m)) {
node k = CADAR(m);
assert(istype(k));
if (k == void_T) continue;
if (k->body.type.flags & raw_atomic_type_F) continue;
if (k->body.type.flags & (raw_pointer_type_F|raw_atomic_pointer_type_F)) return FALSE;
if (isbasictype(CADAR(m))) continue;
return FALSE;
}
return TRUE;
}
if (isortype(t)) {
return FALSE;
}
if (isarraytype(t)||istaggedarraytype(t)) {
node m = typedeftail(t);
assert(length(m) >= 1);
node typ = CAR(m);
assert(istype(typ));
if (typ->body.type.flags & (raw_pointer_type_F|raw_atomic_pointer_type_F)) {
return FALSE; /* can we redefine isbasictype? */
}
return isbasictype(typ);
}
if (t->body.type.flags & raw_pointer_type_F) return FALSE;
if (t->body.type.flags & raw_atomic_pointer_type_F) return TRUE;
assert(!((t->body.type.flags & raw_type_F)));
assert(!((t->body.type.flags & raw_atomic_type_F)));
if (isbasictype(t)) return TRUE;
assert(FALSE);
return FALSE;
}
void putlist (LISP p, FILE *fd)
{
int first = 1;
while (istype (p, TPAIR)) {
if (first)
first = 0;
else
putc (' ', fd);
putexpr (car (p), fd);
p = cdr (p);
}
if (p != NIL) {
fputs (" . ", fd);
putatom (p, fd);
}
}
node membertype(node structtype, node membername) {
node m;
membername = unpos(membername);
if (membername == len_S) return int_T;
if (membername == type__S) return int_T;
if (istype(structtype)) m = typedeftail(structtype);
else m = CDR(structtype);
if (ispos(membername)) membername = membername->body.position.contents;
while (m != NULL) {
if (equal(CAAR(m),membername)) {
node t = typeforward(CADAR(m));
return t;
}
m = CDR(m);
}
return NULL;
}
int tolua_istype (lua_State* L, int narg, int tag, int def)
{
if (lua_gettop(L)<abs(narg))
{
if (def==0)
{
toluaI_eh_set(L,narg,toluaI_tt_getobjtype(L,narg),gettype(L,tag));
return 0;
}
}
else
{
if (!istype(L,narg,tag))
{
toluaI_eh_set(L,narg,toluaI_tt_getobjtype(L,narg),gettype(L,tag));
return 0;
}
}
return 1;
}
int get_width(va_list vlst, char *fstr)
{
char width[5];
int cnt;
cnt = 0;
while (isprecision(*fstr) == 0 && islength(*fstr) == 0 &&
istype(*fstr) == 0)
{
if (ft_isdigit(*fstr))
{
width[cnt] = *fstr;
cnt++;
}
else if (*fstr == '*')
return (va_arg(vlst, int));
fstr++;
}
width[cnt] = '\0';
return (ft_atoi(width));
}
int tolua_arrayistype (lua_State* L, int narg, int tag, int dim, int def)
{
int i;
for (i=0; i<dim; ++i)
{
int tf;
lua_pushnumber(L,(long)(i+1));
lua_gettable(L,narg);
tf = lua_gettop(L);
if (!istype(L,tf,tag) && (!def || !lua_isnil(L,tf)))
{
static char t1[BUFSIZ], t2[BUFSIZ];
sprintf(t1,"array of %s",toluaI_tt_getobjtype(L,tf));
sprintf(t2,"array of %s (dimension=%d)",gettype(L,tag),dim);
toluaI_eh_set(L,narg,t1,t2);
return 0;
}
lua_pop(L,1);
}
return 1;
}
LISP findatom (LISP atom, LISP ctx)
{
/* Поиск атома по контексту */
/* Контекст - это список пар (имя, значение) */
if (! istype (atom, TSYMBOL))
return (NIL);
/* Сначала ищем в текущем контексте */
for (; ctx!=NIL; ctx=cdr(ctx)) {
LISP pair = car (ctx);
LISP sym = car (pair);
if (atom == sym || !strcmp (symname (atom), symname (sym)))
return (pair);
}
/* Затем просматриваем контекст верхнего уровня */
for (ctx=ENV; ctx!=NIL; ctx=cdr(ctx)) {
LISP pair = car (ctx);
LISP sym = car (pair);
if (atom == sym || !strcmp (symname (atom), symname (sym)))
return (pair);
}
return (NIL);
}
//process a line at a time
//this is the heart of the program
//it takes a line and adds all declared variables to a binary tree
//comments and strings are ignored
struct tnode *processline(char *line, struct tnode *root)
{
while(*line != '\0' && *line != '\n') {
while(isspace(*line)) //skip whitespace
line++;
if(ignore)
line += ignoreend(line); //process if ignore should be switched to 0
else {
int c = specialchar(line); //see if line has any special characters
if(c == BREAK)
break;
else if(c == CONTINUE) {
line++;
continue;
}
if(isalnum(*line)) {
line += getnextword(line);
if(istype(word)) {
line += getnextvar(line);
if(*line == '(') { //if var is actually a function
line++;
while(*line != ')' && *line != '\0')
line++;
}
else //var is a variable not a function
if(var[0] != '\0')
root = addtree(root, var); //add variable to binary tree
}
}
else //if character is not alphanumeric
line++;
}
}
return root;
}
int get_precision(va_list vlst, char *fstr)
{
int cnt;
char prec[10];
char *prec_str;
cnt = 0;
prec_str = ft_strchr(fstr, '.');
while (islength(*prec_str) == 0 && istype(*prec_str) == 0 &&
prec_str[cnt] != '\0')
{
if (ft_isdigit(*prec_str))
{
prec[cnt] = *prec_str;
cnt++;
}
else if (*prec_str == '*')
return (va_arg(vlst, int));
prec_str++;
}
prec[cnt] = '\0';
return (ft_atoi(prec));
}
