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)); }