void
untag(U *p)
{
int i;
if (iscons(p)) {
do {
if (p->tag == 0)
return;
p->tag = 0;
untag(p->u.cons.car);
p = p->u.cons.cdr;
} while (iscons(p));
untag(p);
return;
}
if (p->tag) {
p->tag = 0;
if (istensor(p)) {
for (i = 0; i < p->u.tensor->nelem; i++)
untag(p->u.tensor->elem[i]);
}
}
}
void
append(void)
{
int h;
save();
p2 = pop();
p1 = pop();
h = tos;
while (iscons(p1)) {
push(car(p1));
p1 = cdr(p1);
}
while (iscons(p2)) {
push(car(p2));
p2 = cdr(p2);
}
list(tos - h);
restore();
}
static value_t fl_nconc(value_t *args, u_int32_t nargs)
{
if (nargs == 0)
return FL_NIL;
value_t lst, first=FL_NIL;
value_t *pcdr = &first;
cons_t *c;
uint32_t i=0;
while (1) {
lst = args[i++];
if (i >= nargs) break;
if (iscons(lst)) {
*pcdr = lst;
c = (cons_t*)ptr(lst);
while (iscons(c->cdr))
c = (cons_t*)ptr(c->cdr);
pcdr = &c->cdr;
}
else if (lst != FL_NIL) {
type_error("nconc", "cons", lst);
}
}
*pcdr = lst;
return first;
}
fltype_t *get_type(value_t t)
{
fltype_t *ft;
if (issymbol(t)) {
ft = ((symbol_t*)ptr(t))->type;
if (ft != NULL)
return ft;
}
void **bp = equalhash_bp(&TypeTable, (void*)t);
if (*bp != HT_NOTFOUND)
return *bp;
int align, isarray=(iscons(t) && car_(t) == arraysym && iscons(cdr_(t)));
size_t sz;
if (isarray && !iscons(cdr_(cdr_(t)))) {
// special case: incomplete array type
sz = 0;
}
else {
sz = ctype_sizeof(t, &align);
}
ft = (fltype_t*)malloc(sizeof(fltype_t));
ft->type = t;
if (issymbol(t)) {
ft->numtype = sym_to_numtype(t);
((symbol_t*)ptr(t))->type = ft;
}
else {
ft->numtype = N_NUMTYPES;
}
ft->size = sz;
ft->vtable = NULL;
ft->artype = NULL;
ft->marked = 1;
ft->elsz = 0;
ft->eltype = NULL;
ft->init = NULL;
if (iscons(t)) {
if (isarray) {
fltype_t *eltype = get_type(car_(cdr_(t)));
if (eltype->size == 0) {
free(ft);
lerror(ArgError, "invalid array element type");
}
ft->elsz = eltype->size;
ft->eltype = eltype;
ft->init = &cvalue_array_init;
eltype->artype = ft;
}
}
*bp = ft;
return ft;
}
static value_t fl_assq(value_t *args, u_int32_t nargs)
{
argcount("assq", nargs, 2);
value_t item = args[0];
value_t v = args[1];
value_t bind;
while (iscons(v)) {
bind = car_(v);
if (iscons(bind) && car_(bind) == item)
return bind;
v = cdr_(v);
}
return FL_F;
}
void
eval_factor(void)
{
push(cadr(p1));
eval();
push(caddr(p1));
eval();
p2 = pop();
if (p2 == symbol(NIL))
guess();
else
push(p2);
factor();
// more factoring?
p1 = cdddr(p1);
while (iscons(p1)) {
push(car(p1));
eval();
factor_again();
p1 = cdr(p1);
}
}
void
factor_again(void)
{
int h, n;
save();
p2 = pop();
p1 = pop();
h = tos;
if (car(p1) == symbol(MULTIPLY)) {
p1 = cdr(p1);
while (iscons(p1)) {
push(car(p1));
push(p2);
factor_term();
p1 = cdr(p1);
}
} else {
push(p1);
push(p2);
factor_term();
}
n = tos - h;
if (n > 1)
multiply_all_noexpand(n);
restore();
}
void
cosine_of_angle_sum(void)
{
p2 = cdr(p1);
while (iscons(p2)) {
B = car(p2);
if (isnpi(B)) {
push(p1);
push(B);
subtract();
A = pop();
push(A);
cosine();
push(B);
cosine();
multiply();
push(A);
sine();
push(B);
sine();
multiply();
subtract();
return;
}
p2 = cdr(p2);
}
cosine_of_angle();
}
static void
roots2(void)
{
save();
p2 = pop();
p1 = pop();
push(p1);
push(p2);
factorpoly();
p1 = pop();
if (car(p1) == symbol(MULTIPLY)) {
p1 = cdr(p1);
while (iscons(p1)) {
push(car(p1));
push(p2);
roots3();
p1 = cdr(p1);
}
} else {
push(p1);
push(p2);
roots3();
}
restore();
}
void
expand_get_A(void)
{
int h, i, n;
if (!istensor(C)) {
push(A);
reciprocate();
A = pop();
return;
}
h = tos;
if (car(A) == symbol(MULTIPLY)) {
T = cdr(A);
while (iscons(T)) {
F = car(T);
expand_get_AF();
T = cdr(T);
}
} else {
F = A;
expand_get_AF();
}
n = tos - h;
T = alloc_tensor(n);
T->u.tensor->ndim = 1;
T->u.tensor->dim[0] = n;
for (i = 0; i < n; i++)
T->u.tensor->elem[i] = stack[h + i];
tos = h;
A = T;
}
int
simplify_polar(void)
{
int n;
n = isquarterturn(p2);
switch(n) {
case 0:
break;
case 1:
push_integer(1);
return 1;
case 2:
push_integer(-1);
return 1;
case 3:
push(imaginaryunit);
return 1;
case 4:
push(imaginaryunit);
negate();
return 1;
}
if (car(p2) == symbol(ADD)) {
p3 = cdr(p2);
while (iscons(p3)) {
n = isquarterturn(car(p3));
if (n)
break;
p3 = cdr(p3);
}
switch (n) {
case 0:
return 0;
case 1:
push_integer(1);
break;
case 2:
push_integer(-1);
break;
case 3:
push(imaginaryunit);
break;
case 4:
push(imaginaryunit);
negate();
break;
}
push(p2);
push(car(p3));
subtract();
exponential();
multiply();
return 1;
}
return 0;
}
void
umain(int argc, char **argv)
{
int r, interactive, echocmds;
interactive = '?';
echocmds = 0;
ARGBEGIN{
case 'd':
debug++;
break;
case 'i':
interactive = 1;
break;
case 'x':
echocmds = 1;
break;
default:
usage();
}ARGEND
if (argc > 1)
usage();
if (argc == 1) {
close(0);
if ((r = open(argv[0], O_RDONLY)) < 0)
panic("open %s: %e", argv[0], r);
assert(r == 0);
}
if (interactive == '?')
interactive = iscons(0);
while (1) {
char *buf;
buf = readline(interactive ? "$ " : NULL);
if (buf == NULL) {
if (debug)
cprintf("EXITING\n");
exit(); // end of file
}
if (debug)
cprintf("LINE: %s\n", buf);
if (buf[0] == '#')
continue;
if (echocmds)
printf("# %s\n", buf);
if (debug)
cprintf("BEFORE FORK\n");
if ((r = fork()) < 0)
panic("fork: %e", r);
if (debug)
cprintf("FORK: %d\n", r);
if (r == 0) {
runcmd(buf);
exit();
} else
wait(r);
}
}
void
partition(void)
{
save();
p2 = pop();
p1 = pop();
push_integer(1);
p3 = pop();
p4 = p3;
p1 = cdr(p1);
while (iscons(p1)) {
if (find(car(p1), p2)) {
push(p4);
push(car(p1));
multiply();
p4 = pop();
} else {
push(p3);
push(car(p1));
multiply();
p3 = pop();
}
p1 = cdr(p1);
}
push(p3);
push(p4);
restore();
}
void print(FILE *f, value_t v)
{
value_t cd;
switch (tag(v)) {
case TAG_NUM:
fprintf(f, "%d", numval(v));
break;
case TAG_SYM:
fprintf(f, "%s", ((symbol_t*)ptr(v))->name);
break;
case TAG_BUILTIN:
fprintf(f, "#<builtin %s>",
builtin_names[intval(v)]);
break;
case TAG_CONS:
fprintf(f, "(");
while (1) {
print(f, car_(v));
cd = cdr_(v);
if (!iscons(cd)) {
if (cd != NIL) {
fprintf(f, " . ");
print(f, cd);
}
fprintf(f, ")");
break;
}
fprintf(f, " ");
v = cd;
}
break;
}
}
char *
readline(const char *prompt)
{
int i, c, echoing;
if (prompt != NULL)
cprintf("%s", prompt);
i = 0;
echoing = (iscons(0) > 0);
while (1) {
c = getchar();
if (c < 0) {
cprintf("read error: %e\n", c);
return NULL;
} else if (c >= ' ' && i < BUFLEN-1) {
if (echoing)
cputchar(c);
buf[i++] = c;
} else if (c == '\b' && i > 0) {
if (echoing)
cputchar(c);
i--;
} else if (c == '\n' || c == '\r') {
if (echoing)
cputchar(c);
buf[i] = 0;
return buf;
}
}
}
void eval() {
cont = continuation(cont_end, NIL);
C(cont)->expand = YES;
eval:
if (C(cont)->expand)
cont = continuation(cont_macroexpand, continuation(cont_eval, cont));
else if (iscons(expr))
cont = continuation(cont_list, cont);
else if (issymbol(expr))
cont = continuation(cont_symbol, cont);
apply_cont:
assert(iscontinuation(cont));
switch(C(cont)->fn()) {
case ACTION_EVAL:
goto eval;
case ACTION_APPLY_CONT:
goto apply_cont;
case ACTION_DONE:
break;
default:
abort();
}
/* By the time we get here, we should have finished the entire
computation, so should no longer have a continuation.*/
assert(isnil(cont));
}
static value_t fl_length(value_t *args, u_int32_t nargs)
{
argcount("length", nargs, 1);
value_t a = args[0];
cvalue_t *cv;
if (isvector(a)) {
return fixnum(vector_size(a));
}
else if (iscprim(a)) {
cv = (cvalue_t*)ptr(a);
if (cp_class(cv) == bytetype)
return fixnum(1);
else if (cp_class(cv) == wchartype)
return fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv)));
}
else if (iscvalue(a)) {
cv = (cvalue_t*)ptr(a);
if (cv_class(cv)->eltype != NULL)
return size_wrap(cvalue_arraylen(a));
}
else if (a == FL_NIL) {
return fixnum(0);
}
else if (iscons(a)) {
return fixnum(llength(a));
}
type_error("length", "sequence", a);
}
node returntype(node fun){
node t = type(fun);
if (iscons(t) && car(t) == function_S && length(t) == 3) {
return caddr(t);
}
else return bad_or_undefined_T;
}
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);
}
void
yydegree(U *p)
{
if (equal(p, X)) {
if (iszero(DEGREE))
DEGREE = one;
} else if (car(p) == symbol(POWER)) {
if (equal(cadr(p), X) && isnum(caddr(p)) && lessp(DEGREE, caddr(p)))
DEGREE = caddr(p);
} else if (iscons(p)) {
p = cdr(p);
while (iscons(p)) {
yydegree(car(p));
p = cdr(p);
}
}
}
void
push_cars(U *p)
{
while (iscons(p)) {
push(car(p));
p = cdr(p);
}
}
size_t llength(value_t v)
{
size_t n = 0;
while (iscons(v)) {
n++;
v = cdr_(v);
}
return n;
}
int
length(U *p)
{
int n = 0;
while (iscons(p)) {
p = cdr(p);
n++;
}
return n;
}
sexp_t *prim_consp(sexp_t *args)
{
if (list_len(args) != 1) {
fprintf(stderr, "error: argument count\n");
return NULL;
}
if (iscons(car(args)))
return t;
return nil;
}
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 int smallp(value_t v)
{
if (tinyp(v)) return 1;
if (fl_isnumber(v)) return 1;
if (iscons(v)) {
if (tinyp(car_(v)) && (tinyp(cdr_(v)) ||
(iscons(cdr_(v)) && tinyp(car_(cdr_(v))) &&
cdr_(cdr_(v))==NIL)))
return 1;
return 0;
}
if (isvector(v)) {
size_t s = vector_size(v);
return (s == 0 || (tinyp(vector_elt(v,0)) &&
(s == 1 || (s == 2 &&
tinyp(vector_elt(v,1))))));
}
return 0;
}
jl_value_t *jl_parse_next(void)
{
value_t c = fl_applyn(0, symbol_value(symbol("jl-parser-next")));
if (c == FL_EOF)
return NULL;
if (iscons(c)) {
if (cdr_(c) == FL_EOF)
return NULL;
value_t a = car_(c);
if (isfixnum(a)) {
jl_lineno = numval(a);
//jl_printf(JL_STDERR, " on line %d\n", jl_lineno);
c = cdr_(c);
}
}
// for error, get most recent line number
if (iscons(c) && car_(c) == fl_error_sym)
jl_lineno = numval(fl_applyn(0, symbol_value(symbol("jl-parser-current-lineno"))));
return scm_to_julia(c,0);
}
static value_t fl_memq(value_t *args, u_int32_t nargs)
{
argcount("memq", nargs, 2);
while (iscons(args[1])) {
cons_t *c = (cons_t*)ptr(args[1]);
if (c->car == args[0])
return args[1];
args[1] = c->cdr;
}
return FL_F;
}
static value_t fl_constantp(value_t *args, u_int32_t nargs)
{
argcount("constant?", nargs, 1);
if (issymbol(args[0]))
return (isconstant((symbol_t*)ptr(args[0])) ? FL_T : FL_F);
if (iscons(args[0])) {
if (car_(args[0]) == QUOTE)
return FL_T;
return FL_F;
}
return FL_T;
}
void
push_terms(U *p)
{
if (car(p) == symbol(ADD)) {
p = cdr(p);
while (iscons(p)) {
push(car(p));
p = cdr(p);
}
} else if (!iszero(p))
push(p);
}
