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;
}
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);
}
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++);
}
/* 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);
}
/* 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);
}
/* 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);
}
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);
}
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);
}
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++);
}
/* 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);
}
/* 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);
}
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) );
}
/* 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;
}
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;
}
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;
}
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);
}
/* 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);
}
/* 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;
}
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;
}
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);
}
/* 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);
}
//////////////////////////////////////////////////////////////////////
//
//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);
}
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");
}
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);
}
/* 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;
}
/* 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);
}
/* 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);
}
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);
}
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;
}
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;
}