Beispiel #1
0
static List *extractsinglematch(const char *subject, const char *pattern,
				const char *quoting, List *result) {
	int i;
	const char *s;

	if (!haswild(pattern, quoting) /* no wildcards, so no matches */
	    || !match(subject, pattern, quoting))
		return NULL;

	for (s = subject, i = 0; pattern[i] != '\0'; s++) {
		if (ISQUOTED(quoting, i))
			i++;
		else {
			int c = pattern[i++];
			switch (c) {
			    case '*': {
				const char *begin;
				if (pattern[i] == '\0')
					return mklist(mkstr(gcdup(s)), result);
				for (begin = s;; s++) {
					const char *q = TAILQUOTE(quoting, i);
					assert(*s != '\0');
					if (match(s, pattern + i, q)) {
						result = mklist(mkstr(gcndup(begin, s - begin)), result);
						return haswild(pattern + i, q)
							? extractsinglematch(s, pattern + i, q, result)
							: result;
					}
				}
			    }
			    case '[': {
				int j = rangematch(pattern + i, TAILQUOTE(quoting, i), *s);
				assert(j != RANGE_FAIL);
				if (j == RANGE_ERROR) {
					assert(*s == '[');
					break;
				}
				i += j;
			    }
			    /* FALLTHROUGH */
			    case '?':
				result = mklist(mkstr(str("%c", *s)), result);
				break;
			    default:
				break;
			}
		}
	}

	return result;
}
Beispiel #2
0
void add_type(char* name){
	if(types == NULL)
		types = mklist();
	
	if(type_lookup(name) != UNDEFINED_TYPE)
		error("Redefinition of type '%s'", name);

	type_container* t = MKNEW(type_container);
	t->name		= name;
	t->methods	= mklist();
	t->traits	= mklist();

	append(types, (void*) t);
}
Beispiel #3
0
static char *
gettermname()
{
	char *tname;
	static char **tnamep = 0;
	static char **next;
	int err;

	if (resettermname) {
		resettermname = 0;
		if (tnamep && tnamep != unknown)
			free(tnamep);
		if ((tname = (char *)env_getvalue((unsigned char *)"TERM")) &&
				telnet_setupterm(tname, 1, &err) == 0) {
			tnamep = mklist(termbuf, tname);
		} else {
			if (tname && ((int)strlen(tname) <= 40)) {
				unknown[0] = tname;
				strupr(tname);
			} else
				unknown[0] = name_unknown;
			tnamep = unknown;
		}
		next = tnamep;
	}
	if (*next == 0)
		next = tnamep;
	return(*next++);
}
Beispiel #4
0
/* assign -- bind a list of values to a list of variables */
static List *assign(Tree *varform, Tree *valueform0, Binding *binding0) {
	Ref(List *, result, NULL);

	Ref(Tree *, valueform, valueform0);
	Ref(Binding *, binding, binding0);
	Ref(List *, vars, glom(varform, binding, FALSE));

	if (vars == NULL)
		fail("es:assign", "null variable name");

	Ref(List *, values, glom(valueform, binding, TRUE));
	result = values;

	for (; vars != NULL; vars = vars->next) {
		List *value;
		Ref(char *, name, getstr(vars->term));
		if (values == NULL)
			value = NULL;
		else if (vars->next == NULL || values->next == NULL) {
			value = values;
			values = NULL;
		} else {
			value = mklist(values->term, NULL);
			values = values->next;
		}
		vardef(name, binding, value);
		RefEnd(name);
	}

	RefEnd4(values, vars, binding, valueform);
	RefReturn(result);
}
Beispiel #5
0
/* bindargs -- bind an argument list to the parameters of a lambda */
extern Binding *bindargs(Tree *params, List *args, Binding *binding) {
	if (params == NULL)
		return mkbinding("*", args, binding);

	gcdisable();

	for (; params != NULL; params = params->u[1].p) {
		Tree *param;
		List *value;
		assert(params->kind == nList);
		param = params->u[0].p;
		assert(param->kind == nWord || param->kind == nQword);
		if (args == NULL)
			value = NULL;
		else if (params->u[1].p == NULL || args->next == NULL) {
			value = args;
			args = NULL;
		} else {
			value = mklist(args->term, NULL);
			args = args->next;
		}
		binding = mkbinding(param->u[0].s, value, binding);
	}

	Ref(Binding *, result, binding);
	gcenable();
	RefReturn(result);
}
Beispiel #6
0
/* Internal version of Common Lisp MAP function */
LOCAL LVAL map P4C(LVAL, type, LVAL, fcn, LVAL, args, int, rlen)
{
  LVAL nextr, result;
  int nargs, i;

  /* protect some pointers */
  xlstkcheck(2);
  xlsave(result);
  xlprotect(fcn);
 
  if (rlen < 0) rlen = findmaprlen(args); 
  if (type == a_vector)
    result = newvector(rlen);
  else
    result = mklist(rlen, NIL);
  nargs = llength(args);

  for (i = 0, nextr = result; i < rlen; i++) {
    pushnextargs(fcn, nargs, args, i);
    setnextelement(&nextr, i, xlapply(nargs));
  }

  /* restore the stack frame */
  xlpopn(2);
  
  return(result);
}
Beispiel #7
0
LVAL xsaxpy(V)
{
  LVAL result, next, tx, a, x, y;
  int i, j, m, n, start, end, lower;
  double val;
  
  a = getdarraydata(xlgamatrix());
  x = xlgaseq();
  y = xlgaseq();
  lower = (moreargs() && xlgetarg() != NIL) ? TRUE : FALSE;
  
  n = seqlen(x);
  m = seqlen(y);
  if (lower && m != n)
    xlfail("dimensions do not match");
  
  xlsave1(result);
  result = mklist(m, NIL);
  for (i = 0, start = 0, next = result;
       i < m;
       i++, start += n, next = cdr(next)) {
    val = makefloat(getnextelement(&y, i));
    end = (lower) ? i +1 : n;
    for (j = 0, tx = x; j < end; j++) {
      val += makefloat(getnextelement(&tx, j)) 
	* makefloat(gettvecelement(a, start + j));
    }
    rplaca(next, cvflonum((FLOTYPE) val));
  }
  xlpop();
  return(result);
}
Beispiel #8
0
static LVAL add_contour_point P10C(int, m,
				   int, i,
				   int, j,
				   int,  k,
				   int, l,
				   double *, x,
				   double *, y,
				   double *, z,
				   double, v,
				   LVAL, result)
{
  LVAL pt;
  double p, q;
  double zij = z[i * m + j];
  double zkl = z[k * m + l];
  
  if ((zij <= v && v < zkl) || (zkl <= v && v < zij)) {
    xlsave(pt);
    pt = mklist(2, NIL);
    p = (v - zij) / (zkl - zij);
    q = 1.0 - p;
    rplaca(pt, cvflonum((FLOTYPE) (q * x[i] + p * x[k])));
    rplaca(cdr(pt), cvflonum((FLOTYPE) (q * y[j] + p * y[l])));
    result = cons(pt, result);
    xlpop();
  }
  return(result);
}
Beispiel #9
0
static const char *
gettermname(void)
{
	char *tname;
	static const char **tnamep = NULL;
	static const char **next;
	int err;

	if (resettermname) {
		resettermname = 0;
		if (tnamep && tnamep != unknown)
			free(tnamep);
		if ((tname = env_getvalue("TERM")) &&
				(setupterm(tname, 1, &err) == 0)) {
			tnamep = mklist(termbuf, tname);
		} else {
			if (tname && (strlen(tname) <= 40)) {
				unknown[0] = tname;
				upcase(tname);
			} else
				unknown[0] = name_unknown;
			tnamep = unknown;
		}
		next = tnamep;
	}
	if (*next == NULL)
		next = tnamep;
	return(*next++);
}
Beispiel #10
0
/* pathsearch -- evaluate fn %pathsearch + some argument */
extern List *pathsearch(Term *term) {
	List *search, *list;
	search = varlookup("fn-%pathsearch", NULL);
	if (search == NULL)
		fail("es:pathsearch", "%E: fn %%pathsearch undefined", term);
	list = mklist(term, NULL);
	return eval(append(search, list), NULL, 0);
}
Beispiel #11
0
/* listify -- turn an argc/argv vector into a list */
extern List *listify(int argc, char **argv) {
    Ref(List *, list, NULL);
    while (argc > 0) {
        Term *term = mkterm(argv[--argc], NULL);
        list = mklist(term, list);
    }
    RefReturn(list);
}
Beispiel #12
0
call2(int type, char *name, expptr arg1, expptr arg2)
#endif
{
	struct Listblock *args;

	args = mklist( mkchain((char *)arg1, mkchain((char *)arg2, CHNULL) ) );
	return( callk(type,name, (chainp)args) );
}
Beispiel #13
0
/* glob1 -- glob pattern path against the file system */
static List *glob1(const char *pattern, const char *quote) {
	const char *s, *q;
	char *d, *p, *qd, *qp;
	size_t psize;
	List *matched;

	static char *dir = NULL, *pat = NULL, *qdir = NULL, *qpat = NULL, *raw = NULL;
	static size_t dsize = 0;

	assert(quote != QUOTED);

	if ((psize = strlen(pattern) + 1) > dsize || pat == NULL) {
		pat = erealloc(pat, psize);
		raw = erealloc(raw, psize);
		dir = erealloc(dir, psize);
		qpat = erealloc(qpat, psize);
		qdir = erealloc(qdir, psize);
		dsize = psize;
		memset(raw, 'r', psize);
	}
	d = dir;
	qd = qdir;
	q = (quote == UNQUOTED) ? raw : quote;

	s = pattern;
	if (*s == '/')
		while (*s == '/')
			*d++ = *s++, *qd++ = *q++;
	else
		while (*s != '/' && *s != '\0')
			*d++ = *s++, *qd++ = *q++; /* get first directory component */
	*d = '\0';

	/*
	 * Special case: no slashes in the pattern, i.e., open the current directory.
	 * Remember that w cannot consist of slashes alone (the other way *s could be
	 * zero) since doglob gets called iff there's a metacharacter to be matched
	 */
	if (*s == '\0')
		return dirmatch("", ".", dir, qdir);

	matched = (*pattern == '/')
			? mklist(mkstr(dir), NULL)
			: dirmatch("", ".", dir, qdir);
	do {
		size_t slashcount;
		SIGCHK();
		for (slashcount = 0; *s == '/'; s++, q++)
			slashcount++; /* skip slashes */
		for (p = pat, qp = qpat; *s != '/' && *s != '\0';)
			*p++ = *s++, *qp++ = *q++; /* get pat */
		*p = '\0';
		matched = listglob(matched, pat, qpat, slashcount);
	} while (*s != '\0' && matched != NULL);

	return matched;
}
Beispiel #14
0
void *mklist(int n)
{
  struct cell *cell;
  if (!n) return 0;
  cell= GC_malloc(8);  ++objs;  bytes += 8;
  GC_PROTECT(cell);
  cell->tag= n << 1 | 1;
  cell->next= mklist(n - 1);
  GC_UNPROTECT(cell);
  return cell;
}
Beispiel #15
0
extern List *endsplit(void) {
    List *result;

    if (buffer != NULL) {
        Term *term = mkterm(sealcountedbuffer(buffer), NULL);
        value = mklist(term, value);
        buffer = NULL;
    }
    result = reverse(value);
    value = NULL;
    return result;
}
Beispiel #16
0
void start_scope(){
	if(scope_list == NULL)
		scope_list = mklist();
	
	//Make a new variable, flagged as a new scope with no type and no name
	var_scope_t* sc = MKNEW(var_scope_t);
	sc->ident	= "";
	sc->tp		= UNDEFINED_TYPE;
	sc->scope_start	= true;
	
	//Add it to the list
	append(scope_list, sc);
}
Beispiel #17
0
/* importvar -- import a single environment variable */
static void importvar(char *name0, char *value) {
	char sep[2] = { ENV_SEPARATOR, '\0' };

	Ref(char *, name, name0);
	Ref(List *, defn, NULL);
	defn = fsplit(sep, mklist(mkstr(value + 1), NULL), FALSE);

	if (strchr(value, ENV_ESCAPE) != NULL) {
		List *list;
		gcdisable();
		for (list = defn; list != NULL; list = list->next) {
			int offset = 0;
			const char *word = list->term->str;
			const char *escape;
			while ((escape = strchr(word + offset, ENV_ESCAPE))
			       != NULL) {
				offset = escape - word + 1;
				switch (escape[1]) {
				    case '\0':
					if (list->next != NULL) {
						const char *str2
						  = list->next->term->str;
						char *str
						  = gcalloc(offset
							    + strlen(str2) + 1,
							    &StringTag);
						memcpy(str, word, offset - 1);
						str[offset - 1]
						  = ENV_SEPARATOR;
						strcpy(str + offset, str2);
						list->term->str = str;
						list->next = list->next->next;
					}
					break;
				    case ENV_ESCAPE: {
					char *str
					  = gcalloc(strlen(word), &StringTag);
					memcpy(str, word, offset);
					strcpy(str + offset, escape + 2);
					list->term->str = str;
					offset += 1;
					break;
				    }
				}
			}
		}
		gcenable();
	}
	vardef(name, NULL, defn);
	RefEnd2(defn, name);
}
Beispiel #18
0
/* dirmatch -- match a pattern against the contents of directory */
static List *dirmatch(const char *prefix, const char *dirname, const char *pattern, const char *quote) {
	List *list, **prevp;
	static DIR *dirp;
	static Dirent *dp;
	static struct stat s;

	/*
	 * opendir succeeds on regular files on some systems, so the stat call
	 * is necessary (sigh);  the check is done here instead of with the
	 * opendir to handle a trailing slash.
	 */
	if (stat(dirname, &s) == -1 || (s.st_mode & S_IFMT) != S_IFDIR)
		return NULL;	

	if (!haswild(pattern, quote)) {
		char *name = str("%s%s", prefix, pattern);
		if (lstat(name, &s) == -1)
			return NULL;
		return mklist(mkstr(name), NULL);
	}

	assert(gcisblocked());

	dirp = opendir(dirname);
	if (dirp == NULL)
		return NULL;	
	for (list = NULL, prevp = &list; (dp = readdir(dirp)) != NULL;)
		if (match(dp->d_name, pattern, quote)
		    && (!ishiddenfile(dp->d_name) || *pattern == '.')) {
			List *lp = mklist(mkstr(str("%s%s",
						    prefix, dp->d_name)),
					  NULL);
			*prevp = lp;
			prevp = &lp->next;
		}
	closedir(dirp);
	return list;
}
Beispiel #19
0
extern void splitstring(char *in, size_t len, Boolean endword) {
    Buffer *buf = buffer;
    unsigned char *s = (unsigned char *) in, *inend = s + len;

    if (splitchars) {
        assert(buf == NULL);
        while (s < inend) {
            Term *term = mkterm(gcndup((char *) s++, 1), NULL);
            value = mklist(term, value);
        }
        return;
    }

    if (!coalesce && buf == NULL)
        buf = openbuffer(0);

    while (s < inend) {
        int c = *s++;
        if (buf != NULL)
            if (isifs[c]) {
                Term *term = mkterm(sealcountedbuffer(buf), NULL);
                value = mklist(term, value);
                buf = coalesce ? NULL : openbuffer(0);
            } else
                buf = bufputc(buf, c);
        else if (!isifs[c])
            buf = bufputc(openbuffer(0), c);
    }

    if (endword && buf != NULL) {
        Term *term = mkterm(sealcountedbuffer(buf), NULL);
        value = mklist(term, value);
        buf = NULL;
    }
    buffer = buf;
}
Beispiel #20
0
static List *callsettor(char *name, List *defn) {
	Push p;
	List *settor;

	if (specialvar(name) || (settor = varlookup2("set-", name, NULL)) == NULL)
		return defn;

	Ref(List *, lp, defn);
	Ref(List *, fn, settor);
	varpush(&p, "0", mklist(mkstr(name), NULL));

	lp = listcopy(eval(append(fn, lp), NULL, 0));

	varpop(&p);
	RefEnd(fn);
	RefReturn(lp);
}
Beispiel #21
0
/* safereverse -- reverse a list, non-destructively */
extern List *safereverse(List *list) {
    List *lp;

    if (list == NULL)
        return NULL;
    if (list->next == NULL)
        return list;

    gcdisable(0);

    for (lp = NULL; list != NULL; list = list->next)
        lp = mklist(list->term, lp);

    Ref(List *, result, lp);
    gcenable();
    RefReturn(result);
}
Beispiel #22
0
//////////////////////////////////////////////////////////////////////
//
//traverse_s()- a tree library utility function to walk through the 
//              tree, by order of the indicated traversal mode, and
//              to produce a list of all the nodes encountered, in 
//              the order they were encountered.
//
//        note: traverse_s() focuses on the actual content of what
//              is in the tree, setting a (double) pointer to a
//              list that contains the ordered content as it was
//              encountered in the tree. To avoid an error, the list
//              should be NULL (create it).
//
//              the tree should not be modified as a result of
//              performing this action.
//
//              the stack-based implementation of traverse() will 
//              embody the utilization of a stack to the solution
//              of the tree traversal process. Once again, we are
//              sacrificing detail-oriented control in the moment
//              for conceptual elegance and simplification, which
//              will test your understanding of stack concepts.
//
//              traverse_s() could be used as a prerequisite step 
//              before calling the list display() function.
//
// status code: this function generates the following status codes:
//                DLT_SUCCESS:     traverse successful
//                DLT_EMPTY:       tree is in EMPTY state
//                DLT_NULL:        tree is in NULL state
//                DLT_ERROR:        an error has taken place (tree
//                                 is NULL, list exists, bad mode).
//
//              you are to have only ONE return statement for this
//              entire function. Change the existing one as needed.
//
code_t traverse_s(Tree *myTree, List **result, uc mode)
{
    //variable declarations and initializations
    code_t coderesult = 0;
    Node *tmp = NULL;
    List *myList = NULL;

    //creating a list to put nodes from tree
    //if (myList != NULL)
    //{
    //    coderesult = DLT_ERROR;
    //}
    //else
    //{
        coderesult = mklist(&myList);
    //}

    if (myTree == NULL)
    {
        coderesult = DLT_ERROR;
    }
    else
    {
        if (myTree == NULL)
        {
            coderesult = DLT_NULL | DLT_ERROR;
        }
        else
        {
            if (myTree->root == NULL)
            {
                coderesult = DLT_EMPTY;
            }
        }
    }

    if (mode == 0)
    {

    }

	return(coderesult);
}
Beispiel #23
0
void end_scope(){
	if(scope_list == NULL)
		scope_list = mklist();
	
	//Pop elements off the stack and free them
	//When we find a scope_start flag, we know we're done
	size_t length = len(scope_list);
	if(length != 0)
		for(int i = length - 1; i >= 0; i--){
			var_scope_t* sc = (var_scope_t*) pop(scope_list);
			bool flag = sc->scope_start;
			free(sc);
			if(flag)
				return;
		}
	
	//For some reason no scope_start was found in the entire list, bail out
	error("Scope ended before a scope was opened");
}
Beispiel #24
0
void add_to_scope(char* ident, type_t tp){
	if(scope_list == NULL)
		scope_list = mklist();

	var_scope_t* sc = MKNEW(var_scope_t);
	sc->ident	= ident;
	sc->tp		= tp;
	sc->scope_start	= false;

	//Find our previous scope to know the new offset
	size_t length = len(scope_list);
	if(length != 0)
		for(int i = length - 1; i >= 0; i--){
			var_scope_t* v = scopeget(scope_list, i);
			if(v->scope_start == true)
				sc->arg_offset = v->arg_offset++;
		}
	
	append(scope_list, sc);
}
Beispiel #25
0
/* varlookup -- lookup a variable in the current context */
extern List *varlookup(const char *name, Binding *bp) {
	Var *var;

	if (iscounting(name)) {
		Term *term = nth(varlookup("*", bp), strtol(name, NULL, 10));
		if (term == NULL)
			return NULL;
		return mklist(term, NULL);
	}

	validatevar(name);
	for (; bp != NULL; bp = bp->next)
		if (streq(name, bp->name))
			return bp->defn;

	var = dictget(vars, name);
	if (var == NULL)
		return NULL;
	return var->defn;
}
Beispiel #26
0
/* letbindings -- create a new Binding containing let-bound variables */
static Binding *letbindings(Tree *defn0, Binding *outer0,
			    Binding *context0, int evalflags) {
	Ref(Binding *, binding, outer0);
	Ref(Binding *, context, context0);
	Ref(Tree *, defn, defn0);

	for (; defn != NULL; defn = defn->u[1].p) {
		assert(defn->kind == nList);
		if (defn->u[0].p == NULL)
			continue;

		Ref(Tree *, assign, defn->u[0].p);
		assert(assign->kind == nAssign);
		Ref(List *, vars, glom(assign->u[0].p, context, FALSE));
		Ref(List *, values, glom(assign->u[1].p, context, TRUE));

		if (vars == NULL)
			fail("es:let", "null variable name");

		for (; vars != NULL; vars = vars->next) {
			List *value;
			Ref(char *, name, getstr(vars->term));
			if (values == NULL)
				value = NULL;
			else if (vars->next == NULL || values->next == NULL) {
				value = values;
				values = NULL;
			} else {
				value = mklist(values->term, NULL);
				values = values->next;
			}
			binding = mkbinding(name, value, binding);
			RefEnd(name);
		}

		RefEnd3(values, vars, assign);
	}

	RefEnd2(defn, context);
	RefReturn(binding);
}
Beispiel #27
0
/* forkexec -- fork (if necessary) and exec */
extern List *forkexec(char *file, List *list, Boolean inchild) {
	int pid, status;
	Vector *env;
	gcdisable();
	env = mkenv();
	pid = efork(!inchild, FALSE);
	if (pid == 0) {
		execve(file, vectorize(list)->vector, env->vector);
		failexec(file, list);
	}
	gcenable();
	status = ewaitfor(pid);
	if ((status & 0xff) == 0) {
		sigint_newline = FALSE;
		SIGCHK();
		sigint_newline = TRUE;
	} else
		SIGCHK();
	printstatus(0, status);
	return mklist(mkterm(mkstatus(status), NULL), NULL);
}
Beispiel #28
0
LVAL iview_hist_bin_counts(V)
{
  LVAL object, hdata, result, next;
  IVIEW_WINDOW w;
  int i, bins;
  IViewHist h;
  
  gethistargs(&w, &object, &hdata);
  xllastarg();
  
  if (hdata == NULL || (h = getinternals(hdata)) == NULL) result = NIL;
  else {
    bins = h->num_bins;
    xlsave1(result);
    result = mklist(bins, NIL);
    for (i = 0, next = result; i < bins; i++, next = cdr(next))
      rplaca(next, cvfixnum((FIXTYPE) h->bins[i].count));
    xlpop();
  }
  return(result);
}
Beispiel #29
0
int main(int argc, char **argv)
{
	int fd1, fd2;

	struct lnode *clist;
	struct kpnode *tree;

	if (argc < 1) {
		fprintf(stderr, "Error: not enough arguments.\n");
		return 1;
	}

	if ((fd1 = open(argv[1], O_RDONLY)) < 0) {
		fprintf(stderr, "Error: cannot open file.\n");
		return 1;
	}

	if ((clist = mklist(fd1)) == 0) {
		fprintf(stderr, "Error while compiling frequencies.\n");
		return 1;
	}

	displist(clist);

	tree = mktree(clist);

	disptree(tree);

	encode();

	/*save(fd2);*/

	remlnode(&clist);
	/*remnode(&tree);*/

	close(fd1);

	return 0;
}
Beispiel #30
0
var_scope_t* search_scope(char* ident){
	if(scope_list == NULL)
		scope_list = mklist();
	
	//Search backwards to respect our scoping rules
	size_t length = len(scope_list);
	if(length == 0)
		return NULL;

	for(size_t i = length - 1; i >= 0; i--){
		var_scope_t* sc = scopeget(scope_list, i);
		if(strcmp(sc->ident, ident) == 0)
			return sc;
		if(sc->scope_start == true)
			return NULL;
	}
	
	//Something is very wrong...
	error("No scope in scope search");

	//This won't be reached...
	return NULL;
}