Пример #1
0
/* listglob -- glob a directory plus a filename pattern into a list of names */
static List *listglob(List *list, char *pattern, char *quote, size_t slashcount) {
	List *result, **prevp;

	for (result = NULL, prevp = &result; list != NULL; list = list->next) {
		const char *dir;
		size_t dirlen;
		static char *prefix = NULL;
		static size_t prefixlen = 0;

		assert(list->term != NULL);
		assert(!isclosure(list->term));
		
		dir = getstr(list->term);
		dirlen = strlen(dir);
		if (dirlen + slashcount + 1 >= prefixlen) {
			prefixlen = dirlen + slashcount + 1;
			prefix = erealloc(prefix, prefixlen);
		}
		memcpy(prefix, dir, dirlen);
		memset(prefix + dirlen, '/', slashcount);
		prefix[dirlen + slashcount] = '\0';

		*prevp = dirmatch(prefix, dir, pattern, quote);
		while (*prevp != NULL)
			prevp = &(*prevp)->next;
	}
	return result;
}
Пример #2
0
/* glob -- globbing prepass (glob if we need to, and dispatch for tilde expansion) */
extern List *glob(List *list, StrList *quote) {
	List *lp;
	StrList *qp;
	Boolean doglobbing = FALSE;

	for (lp = list, qp = quote; lp != NULL; lp = lp->next, qp = qp->next)
		if (qp->str != QUOTED) {
			assert(lp->term != NULL);
			assert(!isclosure(lp->term));
			Ref(char *, str, getstr(lp->term));
			assert(qp->str == UNQUOTED || strlen(qp->str) == strlen(str));
			if (hastilde(str, qp->str)) {
				Ref(List *, l0, list);
				Ref(List *, lr, lp);
				Ref(StrList *, q0, quote);
				Ref(StrList *, qr, qp);
				str = expandhome(str, qp);
				lr->term = mkstr(str);
				lp = lr;
				qp = qr;
				list = l0;
				quote = q0;
				RefEnd4(qr, q0, lr, l0);
			}
			if (haswild(str, qp->str))
				doglobbing = TRUE;
			RefEnd(str);
		}
Пример #3
0
static Boolean hasbindings(List *list) {
	for (; list != NULL; list = list->next)
		if (isclosure(list->term)) {
			Closure *closure = getclosure(list->term);
			assert(closure != NULL);
			if (closure->binding != NULL)
				return TRUE;
		}
	return FALSE;
}
Пример #4
0
void print_traverse(value_t v)
{
    value_t *bp;
    while (iscons(v)) {
        if (ismarked(v)) {
            bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
            if (*bp == (value_t)HT_NOTFOUND)
                *bp = fixnum(printlabel++);
            return;
        }
        mark_cons(v);
        print_traverse(car_(v));
        v = cdr_(v);
    }
    if (!ismanaged(v) || issymbol(v))
        return;
    if (ismarked(v)) {
        bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
        if (*bp == (value_t)HT_NOTFOUND)
            *bp = fixnum(printlabel++);
        return;
    }
    if (isvector(v)) {
        if (vector_size(v) > 0)
            mark_cons(v);
        unsigned int i;
        for(i=0; i < vector_size(v); i++)
            print_traverse(vector_elt(v,i));
    }
    else if (iscprim(v)) {
        mark_cons(v);
    }
    else if (isclosure(v)) {
        mark_cons(v);
        function_t *f = (function_t*)ptr(v);
        print_traverse(f->bcode);
        print_traverse(f->vals);
        print_traverse(f->env);
    }
    else {
        assert(iscvalue(v));
        cvalue_t *cv = (cvalue_t*)ptr(v);
        // don't consider shared references to ""
        if (!cv_isstr(cv) || cv_len(cv)!=0)
            mark_cons(v);
        fltype_t *t = cv_class(cv);
        if (t->vtable != NULL && t->vtable->print_traverse != NULL)
            t->vtable->print_traverse(v);
    }
}
Пример #5
0
void fl_print_child(ios_t *f, value_t v)
{
    char *name, *str;
    char buf[64];
    if (print_level >= 0 && P_LEVEL >= print_level &&
        (iscons(v) || isvector(v) || isclosure(v))) {
        outc('#', f);
        return;
    }
    P_LEVEL++;

    switch (tag(v)) {
    case TAG_NUM :
    case TAG_NUM1: //HPOS+=ios_printf(f, "%ld", numval(v)); break;
        str = uint2str(&buf[1], sizeof(buf)-1, labs(numval(v)), 10);
        if (numval(v)<0)
            *(--str) = '-';
        outs(str, f);
        break;
    case TAG_SYM:
        name = symbol_name(v);
        if (print_princ)
            outs(name, f);
        else if (ismanaged(v)) {
            outsn("#:", f, 2);
            outs(name, f);
        }
        else
            print_symbol_name(f, name);
        break;
    case TAG_FUNCTION:
        if (v == FL_T) {
            outsn("#t", f, 2);
        }
        else if (v == FL_F) {
            outsn("#f", f, 2);
        }
        else if (v == FL_NIL) {
            outsn("()", f, 2);
        }
        else if (v == FL_EOF) {
            outsn("#<eof>", f, 6);
        }
        else if (isbuiltin(v)) {
            if (!print_princ)
                outsn("#.", f, 2);
            outs(builtin_names[uintval(v)], f);
        }
        else {
            assert(isclosure(v));
            if (!print_princ) {
                if (print_circle_prefix(f, v)) break;
                function_t *fn = (function_t*)ptr(v);
                outs("#fn(", f);
                char *data = cvalue_data(fn->bcode);
                size_t i, sz = cvalue_len(fn->bcode);
                for(i=0; i < sz; i++) data[i] += 48;
                fl_print_child(f, fn->bcode);
                for(i=0; i < sz; i++) data[i] -= 48;
                outc(' ', f);
                fl_print_child(f, fn->vals);
                if (fn->env != NIL) {
                    outc(' ', f);
                    fl_print_child(f, fn->env);
                }
                if (fn->name != LAMBDA) {
                    outc(' ', f);
                    fl_print_child(f, fn->name);
                }
                outc(')', f);
            }
            else {
                outs("#<function>", f);
            }
        }
        break;
    case TAG_CVALUE:
    case TAG_CPRIM:
        if (v == UNBOUND) { outs("#<undefined>", f); break; }
    case TAG_VECTOR:
    case TAG_CONS:
        if (print_circle_prefix(f, v)) break;
        if (isvector(v)) {
            outc('[', f);
            int newindent = HPOS, est;
            int i, sz = vector_size(v);
            for(i=0; i < sz; i++) {
                if (print_length >= 0 && i >= print_length && i < sz-1) {
                    outsn("...", f, 3);
                    break;
                }
                fl_print_child(f, vector_elt(v,i));
                if (i < sz-1) {
                    if (!print_pretty) {
                        outc(' ', f);
                    }
                    else {
                        est = lengthestimate(vector_elt(v,i+1));
                        if (HPOS > SCR_WIDTH-4 ||
                            (est!=-1 && (HPOS+est > SCR_WIDTH-2)) ||
                            (HPOS > SCR_WIDTH/2 &&
                             !smallp(vector_elt(v,i+1)) &&
                             !tinyp(vector_elt(v,i))))
                            newindent = outindent(newindent, f);
                        else
                            outc(' ', f);
                    }
                }
            }
            outc(']', f);
            break;
        }
        if (iscvalue(v) || iscprim(v))
            cvalue_print(f, v);
        else
            print_pair(f, v);
        break;
    }
    P_LEVEL--;
}
Пример #6
0
static value_t cyc_compare(value_t a, value_t b, htable_t *table, int eq)
{
    value_t d, ca, cb;
 cyc_compare_top:
    if (a==b)
        return fixnum(0);
    if (iscons(a)) {
        if (iscons(b)) {
            value_t aa = car_(a); value_t da = cdr_(a);
            value_t ab = car_(b); value_t db = cdr_(b);
            int tagaa = tag(aa); int tagda = tag(da);
            int tagab = tag(ab); int tagdb = tag(db);
            if (leafp(aa) || leafp(ab)) {
                d = bounded_compare(aa, ab, 1, eq);
                if (d!=NIL && numval(d)!=0) return d;
            }
            else if (tagaa < tagab)
                return fixnum(-1);
            else if (tagaa > tagab)
                return fixnum(1);
            if (leafp(da) || leafp(db)) {
                d = bounded_compare(da, db, 1, eq);
                if (d!=NIL && numval(d)!=0) return d;
            }
            else if (tagda < tagdb)
                return fixnum(-1);
            else if (tagda > tagdb)
                return fixnum(1);

            ca = eq_class(table, a);
            cb = eq_class(table, b);
            if (ca!=NIL && ca==cb)
                return fixnum(0);

            eq_union(table, a, b, ca, cb);
            d = cyc_compare(aa, ab, table, eq);
            if (numval(d)!=0) return d;
            a = da;
            b = db;
            goto cyc_compare_top;
        }
        else {
            return fixnum(1);
        }
    }
    else if (isvector(a) && isvector(b)) {
        return cyc_vector_compare(a, b, table, eq);
    }
    else if (isclosure(a) && isclosure(b)) {
        function_t *fa = (function_t*)ptr(a);
        function_t *fb = (function_t*)ptr(b);
        d = bounded_compare(fa->bcode, fb->bcode, 1, eq);
        if (numval(d) != 0) return d;
        
        ca = eq_class(table, a);
        cb = eq_class(table, b);
        if (ca!=NIL && ca==cb)
            return fixnum(0);
        
        eq_union(table, a, b, ca, cb);
        d = cyc_compare(fa->vals, fb->vals, table, eq);
        if (numval(d) != 0) return d;
        a = fa->env;
        b = fb->env;
        goto cyc_compare_top;
    }
    return bounded_compare(a, b, 1, eq);
}