int main(int argc , char **argv )
{ int file ;
int tmp ;
void *cbuf ;
void *tmp___0 ;
int a ;
ssize_t tmp___1 ;
char *__cil_tmp9 ;
unsigned int __cil_tmp10 ;
size_t __cil_tmp11 ;
char *__cil_tmp12 ;
size_t __cil_tmp13 ;
{
{
__cil_tmp9 = (char *)"unknown";
tmp = l_open(__cil_tmp9, 0);
file = tmp;
__cil_tmp10 = 1U * 100U;
__cil_tmp11 = (size_t )__cil_tmp10;
tmp___0 = malloc(__cil_tmp11);
cbuf = tmp___0;
__cil_tmp12 = (char *)cbuf;
__cil_tmp13 = (size_t )99;
tmp___1 = l_read(file, __cil_tmp12, __cil_tmp13);
a = (int )tmp___1;
}
return (0);
}
}
int get_next_line(int const fd, char **line)
{
static char str[BUFF_SIZE + 1];
static size_t cursor;
static ssize_t size;
char *newlinepos;
if (line == NULL)
return (-1);
*line = ft_strnew(0);
while (42)
{
if ((ssize_t)cursor >= size)
init(&size, fd, str, &cursor);
if (size <= 0)
return (size);
newlinepos = ft_strchr(str + cursor, '\n');
if (newlinepos == NULL)
{
if (process(line, str, &cursor, &size) != -2)
return (-1);
}
else
return (l_read(line, str, &cursor, newlinepos));
}
}
int main(int argc , char **argv )
{ int file ;
int tmp ;
void *cbuf ;
void *tmp___0 ;
int a ;
ssize_t tmp___1 ;
char *__cil_tmp9 ;
unsigned int __cil_tmp10 ;
size_t __cil_tmp11 ;
char *__cil_tmp12 ;
size_t __cil_tmp13 ;
{
{
#line 14
__cil_tmp9 = (char *)"unknown";
#line 14
tmp = l_open(__cil_tmp9, 0);
#line 14
file = tmp;
#line 15
__cil_tmp10 = 1U * 100U;
#line 15
__cil_tmp11 = (size_t )__cil_tmp10;
#line 15
tmp___0 = malloc(__cil_tmp11);
#line 15
cbuf = tmp___0;
#line 16
__cil_tmp12 = (char *)cbuf;
#line 16
__cil_tmp13 = (size_t )99;
#line 16
tmp___1 = l_read(file, __cil_tmp12, __cil_tmp13);
#line 16
a = (int )tmp___1;
}
#line 17
return (0);
}
}
/* Top level */
void
toplevel(void)
{
long s, v;
for (;;){
t_stack_ptr = 0;
printf("\n] "); /* prompt */
if ((s = l_read()) < 0) /* read */
continue;
if (s == TAG_EOF) /* end of file */
break;
if (gc_protect(s) < 0)
break;
if ((v = l_eval(s)) < 0) /* eval */
continue;
gc_unprotect(s);
printf("\n");
(void) l_print(v); /* print */
}
}
int x_rsne(cilist *a)
{
int ch, got1, k, n, nd, quote, readall;
Namelist *nl;
static char where[] = "namelist read";
char buf[64];
hashtab *ht;
Vardesc *v;
dimen *dn, *dn0, *dn1;
ftnlen *dims, *dims1;
ftnlen b, b0, b1, ex, no, nomax, size, span;
ftnint no1, no2, type;
char *vaddr;
long iva, ivae;
dimen dimens[MAXDIM], substr;
if (!Alpha['a'])
nl_init();
f__reading=1;
f__formatted=1;
got1 = 0;
top:
for(;;) switch(GETC(ch)) {
case EOF:
eof:
err(a->ciend,(EOF),where0);
case '&':
case '$':
goto have_amp;
#ifndef No_Namelist_Questions
case '?':
print_ne(a);
continue;
#endif
default:
if (ch <= ' ' && ch >= 0)
continue;
#ifndef No_Namelist_Comments
while(GETC(ch) != '\n')
if (ch == EOF)
goto eof;
#else
errfl(a->cierr, 115, where0);
#endif
}
have_amp:
if (ch = getname(buf,sizeof(buf)))
return ch;
nl = (Namelist *)a->cifmt;
if (strcmp(buf, nl->name))
#ifdef No_Bad_Namelist_Skip
errfl(a->cierr, 118, where0);
#else
{
fprintf(stderr,
"Skipping namelist \"%s\": seeking namelist \"%s\".\n",
buf, nl->name);
fflush(stderr);
for(;;) switch(GETC(ch)) {
case EOF:
err(a->ciend, EOF, where0);
case '/':
case '&':
case '$':
if (f__external)
e_rsle();
else
z_rnew();
goto top;
case '"':
case '\'':
quote = ch;
more_quoted:
while(GETC(ch) != quote)
if (ch == EOF)
err(a->ciend, EOF, where0);
if (GETC(ch) == quote)
goto more_quoted;
Ungetc(ch,f__cf);
default:
continue;
}
}
#endif
ht = mk_hashtab(nl);
if (!ht)
errfl(f__elist->cierr, 113, where0);
for(;;) {
for(;;) switch(GETC(ch)) {
case EOF:
if (got1)
return 0;
err(a->ciend, EOF, where0);
case '/':
case '$':
case '&':
return 0;
default:
if (ch <= ' ' && ch >= 0 || ch == ',')
continue;
Ungetc(ch,f__cf);
if (ch = getname(buf,sizeof(buf)))
return ch;
goto havename;
}
havename:
v = hash(ht,buf);
if (!v)
errfl(a->cierr, 119, where);
while(GETC(ch) <= ' ' && ch >= 0);
vaddr = v->addr;
type = v->type;
if (type < 0) {
size = -type;
type = TYCHAR;
}
else
size = f__typesize[type];
ivae = size;
iva = readall = 0;
if (ch == '(' /*)*/ ) {
dn = dimens;
if (!(dims = v->dims)) {
if (type != TYCHAR)
errfl(a->cierr, 122, where);
if (k = getdimen(&ch, dn, (ftnlen)size,
(ftnlen)size, &b))
errfl(a->cierr, k, where);
if (ch != ')')
errfl(a->cierr, 115, where);
b1 = dn->extent;
if (--b < 0 || b + b1 > size)
return 124;
iva += b;
size = b1;
while(GETC(ch) <= ' ' && ch >= 0);
goto scalar;
}
nd = (int)dims[0];
nomax = span = dims[1];
ivae = iva + size*nomax;
colonseen = 0;
if (k = getdimen(&ch, dn, size, nomax, &b))
errfl(a->cierr, k, where);
no = dn->extent;
b0 = dims[2];
dims1 = dims += 3;
ex = 1;
for(n = 1; n++ < nd; dims++) {
if (ch != ',')
errfl(a->cierr, 115, where);
dn1 = dn + 1;
span /= *dims;
if (k = getdimen(&ch, dn1, dn->delta**dims,
span, &b1))
errfl(a->cierr, k, where);
ex *= *dims;
b += b1*ex;
no *= dn1->extent;
dn = dn1;
}
if (ch != ')')
errfl(a->cierr, 115, where);
readall = 1 - colonseen;
b -= b0;
if (b < 0 || b >= nomax)
errfl(a->cierr, 125, where);
iva += size * b;
dims = dims1;
while(GETC(ch) <= ' ' && ch >= 0);
no1 = 1;
dn0 = dimens;
if (type == TYCHAR && ch == '(' /*)*/) {
if (k = getdimen(&ch, &substr, size, size, &b))
errfl(a->cierr, k, where);
if (ch != ')')
errfl(a->cierr, 115, where);
b1 = substr.extent;
if (--b < 0 || b + b1 > size)
return 124;
iva += b;
b0 = size;
size = b1;
while(GETC(ch) <= ' ' && ch >= 0);
if (b1 < b0)
goto delta_adj;
}
if (readall)
goto delta_adj;
for(; dn0 < dn; dn0++) {
if (dn0->extent != *dims++ || dn0->stride != 1)
break;
no1 *= dn0->extent;
}
if (dn0 == dimens && dimens[0].stride == 1) {
no1 = dimens[0].extent;
dn0++;
}
delta_adj:
ex = 0;
for(dn1 = dn0; dn1 <= dn; dn1++)
ex += (dn1->extent-1)
* (dn1->delta *= dn1->stride);
for(dn1 = dn; dn1 > dn0; dn1--) {
ex -= (dn1->extent - 1) * dn1->delta;
dn1->delta -= ex;
}
}
else if (dims = v->dims) {
no = no1 = dims[1];
ivae = iva + no*size;
}
else
scalar:
no = no1 = 1;
if (ch != '=')
errfl(a->cierr, 115, where);
got1 = nml_read = 1;
f__lcount = 0;
readloop:
for(;;) {
if (iva >= ivae || iva < 0) {
f__lquit = 1;
goto mustend;
}
else if (iva + no1*size > ivae)
no1 = (ivae - iva)/size;
f__lquit = 0;
if (k = l_read(&no1, vaddr + iva, size, type))
return k;
if (f__lquit == 1)
return 0;
if (readall) {
iva += dn0->delta;
if (f__lcount > 0) {
no2 = (ivae - iva)/size;
if (no2 > f__lcount)
no2 = f__lcount;
if (k = l_read(&no2, vaddr + iva,
size, type))
return k;
iva += no2 * dn0->delta;
}
}
mustend:
GETC(ch);
if (readall)
if (iva >= ivae)
readall = 0;
else for(;;) {
switch(ch) {
case ' ':
case '\t':
case '\n':
GETC(ch);
continue;
}
break;
}
if (ch == '/' || ch == '$' || ch == '&') {
f__lquit = 1;
return 0;
}
else if (f__lquit) {
while(ch <= ' ' && ch >= 0)
GETC(ch);
Ungetc(ch,f__cf);
if (!Alpha[ch & 0xff] && ch >= 0)
errfl(a->cierr, 125, where);
break;
}
Ungetc(ch,f__cf);
if (readall && !Alpha[ch & 0xff])
goto readloop;
if ((no -= no1) <= 0)
break;
for(dn1 = dn0; dn1 <= dn; dn1++) {
if (++dn1->curval < dn1->extent) {
iva += dn1->delta;
goto readloop;
}
dn1->curval = 0;
}
break;
}
}
}
/* Call a built-in function */
long
fcall(long f, long av[2]) /*, int n*/
{
long v, t;
long r, d;
switch (D_GET_DATA(f)){
case KW_RPLACA:
case KW_RPLACD:
case KW_CAR:
case KW_CDR:
if (D_GET_TAG(av[0]) != TAG_CONS)
return err_msg(errmsg_ill_type, 1, f);
break;
case KW_GT:
#ifndef MINIMALISTIC
case KW_LT:
case KW_GTE:
case KW_LTE:
case KW_REM:
#endif
if ((D_GET_TAG(av[0]) != TAG_INT) || (D_GET_TAG(av[1]) != TAG_INT))
return err_msg(errmsg_ill_type, 1, f);
break;
#ifndef MINIMALISTIC
case KW_ZEROP:
case KW_RAND:
case KW_INCR:
case KW_DECR:
if (D_GET_TAG(av[0]) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
break;
#endif
}
switch (D_GET_DATA(f)){
#ifndef MINIMALISTIC
case KW_LAMBDA:
return err_msg(errmsg_ill_call, 1, f);
break;
#endif
case KW_QUIT:
quit();
break;
case KW_EQ:
#ifndef MINIMALISTIC
case KW_EQMATH:
#endif
v = (av[0] == av[1]) ? TAG_T : TAG_NIL;
break;
#ifndef MINIMALISTIC
case KW_EQUAL:
return l_equal(av[0], av[1]);
#endif
case KW_CONS:
v = l_cons(av[0], av[1]);
break;
case KW_RPLACA:
v = t_cons_car[D_GET_DATA(av[0])] = av[1];
break;
case KW_RPLACD:
v = t_cons_cdr[D_GET_DATA(av[0])] = av[1];
break;
case KW_CAR:
v = l_car(av[0]);
break;
case KW_CDR:
v = l_cdr(av[0]);
break;
case KW_NULL:
v = (D_GET_TAG(av[0]) == TAG_NIL) ? TAG_T : TAG_NIL;
break;
case KW_CONSP:
return (D_GET_TAG(av[0]) == TAG_CONS) ? TAG_T : TAG_NIL;
case KW_SYMBP:
return (D_GET_TAG(av[0]) == TAG_SYMB) ? TAG_T : TAG_NIL;
case KW_NUMBERP:
v = (D_GET_TAG(av[0]) == TAG_INT) ? TAG_T : TAG_NIL;
break;
case KW_LIST:
v = av[0];
break;
case KW_NOT:
v = (D_GET_TAG(av[0]) == TAG_NIL) ? TAG_T : TAG_NIL;
break;
case KW_READ:
v = l_read();
break;
case KW_EVAL:
v = l_eval(av[0]);
break;
case KW_PRINC:
v = l_print(av[0]);
break;
case KW_TERPRI:
printf("\n");
v = TAG_NIL;
break;
case KW_GC:
gcollect();
v = TAG_T;
break;
case KW_ADD:
for (r = 0, t = av[0]; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
r = r + int_get_c(l_car(t));
}
v = int_make_l(r);
break;
case KW_TIMES:
for (r = 1, t = av[0]; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
r = r * int_get_c(l_car(t));
}
v = int_make_l(r);
break;
case KW_SUB:
if (D_GET_TAG(av[0]) == TAG_NIL){
r = 0;
} else if (D_GET_TAG(l_car(av[0])) != TAG_INT){
return err_msg(errmsg_ill_type, 1, f);
} else if (D_GET_TAG(l_cdr(av[0])) == TAG_NIL){
r = 0 - int_get_c(l_car(av[0]));
} else {
r = int_get_c(l_car(av[0]));
for (t = l_cdr(av[0]); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
r = r - int_get_c(l_car(t));
}
}
v = int_make_l(r);
break;
case KW_QUOTIENT:
if (D_GET_TAG(av[0]) == TAG_NIL){
r = 1;
} else if (D_GET_TAG(l_car(av[0])) != TAG_INT){
return err_msg(errmsg_ill_type, 1, f);
} else if ((d = int_get_c(l_car(av[0]))) == 0){
return err_msg(errmsg_zero_div, 1, f);
} if (D_GET_TAG(l_cdr(av[0])) == TAG_NIL){
r = 1 / d;
} else {
for (r = d, t = l_cdr(av[0]); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
if (D_GET_TAG(l_car(t)) != TAG_INT)
return err_msg(errmsg_ill_type, 1, f);
if ((d = int_get_c(l_car(t))) == 0)
return err_msg(errmsg_zero_div, 1, f);
r = r / d;
}
}
v = int_make_l(r);
break;
case KW_GT:
v = (int_get_c(av[0]) > int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
#ifndef MINIMALISTIC
case KW_DIVIDE:
r = int_get_c(av[0]);
if ((d = int_get_c(av[1])) == 0)
return err_msg(errmsg_zero_div, 1, f);
v = l_cons(int_make_l(r / d), int_make_l(r % d));
break;
case KW_LT:
v = (int_get_c(av[0]) < int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
case KW_ATOM:
v = (D_GET_TAG(av[0]) != TAG_CONS) ? TAG_T : TAG_NIL;
break;
case KW_GTE:
v = (int_get_c(av[0]) >= int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
case KW_LTE:
v = (int_get_c(av[0]) <= int_get_c(av[1])) ? TAG_T : TAG_NIL;
break;
case KW_ZEROP:
v = (int_get_c(av[0]) == 0) ? TAG_T : TAG_NIL;
break;
case KW_RAND:
v = int_make_l(rand() % int_get_c(av[0]));
break;
case KW_INCR:
v = int_make_l(int_get_c(av[0])+1);
break;
case KW_DECR:
v = int_make_l(int_get_c(av[0])-1);
break;
case KW_REM:
r = int_get_c(av[0]);
if ((d = int_get_c(av[1])) == 0)
return err_msg(errmsg_zero_div, 1, f);
v = int_make_l(r % d);
break;
#endif
}
return v;
}
/* Read an S-expression */
long
l_read(void)
{
long s, v, t;
char token[32];
char ch, i;
/* skip spaces */
if ((ch = skip_space()) < 0){ /* eof */
return TAG_EOF;
} else if (ch == ';'){ /* comment */
while (gchar() != '\n')
;
return -1;
}
#ifdef ZX81
else if (ch == '\"'){ /* quote macro */
#else
else if (ch == '\''){ /* quote macro */
#endif
if ((t = l_read()) < 0)
return -1;
if (t == TAG_EOF)
return err_msg(errmsg_eof, 0, 0);
t = l_cons(t, TAG_NIL);
s = l_cons((TAG_SYMB|KW_QUOTE), t);
} else if (ch != '('){ /* t, nil, symbol, or integer */
token[0] = ch;
for (i = 1; ; i++){
ch = gchar();
if (isspace(ch) || iscntrl(ch) || (ch < 0)
|| (ch == ';') || (ch == '(') || (ch == ')')){
ugchar(ch);
token[i] = '\0';
/* Changed to permint the definition of "1+" and "1-" */
if ((isdigit((char)token[0]) && (token[1] != '+') && (token[1] != '-'))
/* if (isdigit((char)token[0]) */
|| ((token[0] == '-') && isdigit((char)token[1]))
|| ((token[0] == '+') && isdigit((char)token[1]))){ /* integer */
s = int_make_l(atol(token));
#ifdef SCHEME
} else if (strcmp(token, "#f") == 0){ /* nil */
s = TAG_NIL;
} else if (strcmp(token, "#t") == 0){ /* t */
s = TAG_T;
#else
} else if (strcmp(token, "nil") == 0){ /* nil */
s = TAG_NIL;
} else if (strcmp(token, "t") == 0){ /* t */
s = TAG_T;
#endif
} else { /* symbol */
s = TAG_SYMB | symb_make(token);
}
break;
}
token[i] = ch;
}
} else /* ch == '(' */ { /* list */
if ((ch = skip_space()) < 0){
return err_msg(errmsg_eof, 0, 0);
} else if (ch == ')'){
s = TAG_NIL; /* "()" = nil */
} else {
ugchar(ch);
if ((t = l_read()) < 0)
return err_msg(errmsg_eof, 0, 0);
if (t == TAG_EOF)
return -1;
if ((s = v = l_cons(t, TAG_NIL)) < 0)
return -1;
if (gc_protect(s) < 0)
return -1;
for (;;){
if ((ch = skip_space()) < 0) /* look ahead next char */
return err_msg(errmsg_eof, 0, 0);
if (ch == ')')
break;
ugchar(ch);
if ((t = l_read()) < 0)
return -1;
if (t == TAG_EOF)
return err_msg(errmsg_eof, 0, 0);
if ((t = l_cons(t, TAG_NIL)) < 0)
return -1;
rplacd(v, t);
v = l_cdr(v);
}
gc_unprotect(s);
}
}
return s;
}
char
skip_space(void)
{
char ch;
for (;;){
if ((ch = gchar()) < 0)
return -1; /* end-of-file */
if (!isspace(ch) && !iscntrl(ch))
break;
}
return ch;
}