Exemple #1
0
/* Evaluate an S-expression */
long
l_eval(long s)
{
  long  v, f, a, av[2];
  int n;

  switch(D_GET_TAG(s)){

  case TAG_NIL:        /* self-evaluating objects */
  case TAG_T:
  case TAG_INT:
    v = s;
    break;

  case TAG_SYMB:       /* symbol ... refer to the symbol table */
    if ((v = t_symb_val[D_GET_DATA(s)]) == TAG_UNDEF)
      return err_msg(errmsg_sym_undef, 1, s);
    break;

  case TAG_CONS:       /* cons ... function call */
    f = l_car(s);   /* function name or lambda exp */
    a = l_cdr(s);   /* actual argument list */
#ifndef minimalistic
    if ((D_GET_TAG(f) == TAG_CONS) && (D_GET_TAG(l_car(f)) == TAG_SYMB) 
        && ((D_GET_DATA(l_car(f)) == KW_LAMBDA))){   /* lambda exp */
      if (eval_args(f, a, av, FTYPE_ANY_ARGS) < 0)
        return -1;
      v = apply(l_cdr(f), av[0], list_len(l_car(l_cdr(f))));
    } else
#endif
        if (D_GET_TAG(f) == TAG_SYMB){
      n = FTYPE_GET_NARGS(t_symb_ftype[D_GET_DATA(f)]);
      switch (FTYPE_GET_TYPE(t_symb_ftype[D_GET_DATA(f)])){
      case FTYPE_UNDEF:
        return err_msg(errmsg_func_undef, 1, f);
      case FTYPE_SPECIAL:
        v = special(f, a);
        break;
      case FTYPE_SYS:
        if (eval_args(f, a, av, n) < 0)
          return -1;
        v = fcall(f, av/*, n*/);
        break;
      case FTYPE_USER:
        if (eval_args(f, a, av, FTYPE_ANY_ARGS) < 0)
          return -1;
        v = apply(f, av[0], n);
      }
    } else {
      return err_msg(errmsg_ill_call, 1, s);
    }
    break;
  }
  return v;
}
Exemple #2
0
/* Evaluate arguments */
long
eval_args(long func, long arg, long av[2], int n)
{
  long  x, y;

  if ((n != FTYPE_ANY_ARGS) && (n != list_len(arg)))
    return err_msg(errmsg_ill_nargs, 1, func);

  switch (n){

  case 0:
    av[0] = TAG_NIL;
    break;

  case 1:
    if ((av[0] = l_eval(l_car(arg))) < 0)
      return -1;
    break;

  case 2:
    if ((av[0] = l_eval(l_car(arg))) < 0)
      return -1;
    if (gc_protect(av[0]) < 0)
      return -1;
    if ((av[1] = l_eval(l_car(l_cdr(arg)))) < 0)
      return -1;
    gc_unprotect(av[0]);
    break;

  case FTYPE_ANY_ARGS:   /* return evaluated arguments as a list */
    if (D_GET_TAG(arg) != TAG_CONS){
      av[0] = TAG_NIL;
    } else {
      if ((x = l_eval(l_car(arg))) < 0)
        return -1;
      if ((av[0] = y = l_cons(x, TAG_NIL)) < 0)
        return -1;
      if (gc_protect(av[0]) < 0)
        return -1;
      for (arg = l_cdr(arg); D_GET_TAG(arg) == TAG_CONS; arg = l_cdr(arg)){
        if ((x = l_eval(l_car(arg))) < 0)
          return -1;
        rplacd(y, l_cons(x, TAG_NIL)); 
        y = l_cdr(y);
      }
      gc_unprotect(av[0]);
    }
  }
  return av[0];
}
Exemple #3
0
/* Length of a list */
int
list_len(long s)
{
  int i;

  for (i = 0; D_GET_TAG(s) == TAG_CONS; s = l_cdr(s))
    i++;
  return i;
}
Exemple #4
0
/* mark recursively */
void
gc_mark(long s)
{
  for ( ; D_GET_TAG(s) == TAG_CONS; s = l_cdr(s)){
    if ((t_cons_car[D_GET_DATA(s)] & D_GC_MARK) != 0) /* visited before */
      return;
    t_cons_car[D_GET_DATA(s)] |= D_GC_MARK;  /* mark */
    gc_mark(l_car(s));                       /* visit car part */
  }
}
Exemple #5
0
Term *
func_op_names(TermList terms)
{
  Term *ops_t;

  ops_t  = (Term *)get_list_pos(terms, 1);
  if (! ops_t ) {
    report_fatal_external_error((char *)"Cannot retrieve OP instance term");
  }
  if (ops_t->type != LISP_LIST) {
    report_fatal_external_error((char *)"Term is not of type LISP_LIST");
  }

  TermList name_list = sl_make_slist();

  for (L_List p_l = ops_t->u.l_list; p_l; p_l = l_cdr(p_l)) {
    Term *t = l_car(p_l);
    if (t->type == TT_INTENTION) {
      Op_Instance *opi = (Op_Instance *)(t->u.in->top_op);
      Op_Structure *op_s = op_instance_op(opi);
      name_list = build_term_list(name_list, build_id(op_name(op_s)));
    } else if (t->type == TT_OP_INSTANCE) {
      Op_Instance *opi = (Op_Instance *)(t->u.opi);
      Op_Structure *op_s = op_instance_op(opi);
      if (! op_s) {
        name_list = build_term_list(name_list, build_id(declare_atom("NOT-AN-OP")));
      } else {
        name_list = build_term_list(name_list, build_id(op_name(op_s)));
      }
    } else {
      name_list = build_term_list(name_list, build_id(declare_atom("NOT-AN-OP-INSTANCE")));
    }
  }

  return build_term_l_list_from_c_list(name_list);
}
Exemple #6
0
/* 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;
}
Exemple #7
0
/* Execute special form (defun, setq. etc... arguments are not evaluated) */
long
special(long f, long a)
{
  long  t, v, u;
  int l, i;

  switch (D_GET_DATA(f)){

  case KW_DEFUN:
    if (list_len(a) < 2)
      return err_msg(errmsg_ill_syntax, 1, f);
#ifdef SCHEME
    /* (define (func var1 varn) (func content)) */
    v = l_car(a);            /* function name  */
    v = l_car(v);            /* list of function name, arg and function body */
    if (D_GET_TAG(v) != TAG_SYMB)
      return err_msg(errmsg_ill_syntax, 1, f);
    t = l_cdr(v);   /* list of function args */
    l = list_len(t);  /* #args */
    a = l_cons(  v, l_cons(   l_cdr(l_car(a))  , l_cdr(a)));
#endif
    /* (defun func (var1 varn) (func content)) */
    v = l_car(a);            /* function name  */
    if (D_GET_TAG(v) != TAG_SYMB)
      return err_msg(errmsg_ill_syntax, 1, f);
    t = l_cdr(a);            /* list of function arg and function body */
    l = list_len(l_car(t));  /* #args */

    i = D_GET_DATA(v);
    t_symb_fval[i]  = t;
    t_symb_ftype[i] = FTYPE(FTYPE_USER, l);
    break;

  case KW_SETQ:
    t = l_car(a);  /* symbol name */
    if (D_GET_TAG(t) != TAG_SYMB)
      return err_msg(errmsg_ill_type, 1, f);
    if ((v = l_eval(l_car(l_cdr(a)))) < 0)  /* value */
      return -1;
    t_symb_val[D_GET_DATA(t)] = v;
    break;

  case KW_QUOTE:
    v = l_car(a);
    break;

  case KW_PROGN:
    for (v = TAG_NIL, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
      if ((v = l_eval(l_car(t))) < 0)
        return -1;
    }
    break;

  case KW_WHILE:
    if (D_GET_TAG(a) != TAG_CONS)
      return err_msg(errmsg_ill_syntax, 1, f);
    if ((v = l_eval(l_car(a))) < 0)
      return -1;
    while (D_GET_TAG(v) != TAG_NIL) {
      for (t = l_cdr(a); D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
        if ((v = l_eval(l_car(t))) < 0)
          return -1;
      }
      v = l_eval(l_car(a));
    }
    break;

#ifndef MINIMALISTIC
  case KW_AND:
    for (v = TAG_T, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
      if ((v = l_eval(l_car(t))) < 0)
        return -1;
      if (D_GET_TAG(t) == TAG_NIL)
        break;
    }
    break;
#endif

  case KW_OR:
    for (v = TAG_NIL, t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
      if ((v = l_eval(l_car(t))) < 0)
        return -1;
      if (D_GET_TAG(v) != TAG_NIL)
        break;
    }
    break; 

  case KW_COND:
    if (D_GET_TAG(a) != TAG_CONS)
      return err_msg(errmsg_ill_syntax, 1, f);
    v = TAG_NIL; 
    for (t = a; D_GET_TAG(t) == TAG_CONS; t = l_cdr(t)){
      u = l_car(t);
      if (D_GET_TAG(u) != TAG_CONS)
        return err_msg(errmsg_ill_syntax, 1, f);
      if ((v = l_eval(l_car(u))) < 0)
        return -1;
      if (D_GET_TAG(v) != TAG_NIL){
                for (u = l_cdr(u); D_GET_TAG(u) == TAG_CONS; u = l_cdr(u)){ 
                  if ((v = l_eval(l_car(u))) < 0)
                        return -1;
                }
        break;
      }
    }
    break;

#ifndef MINIMALISTIC
  case KW_COMMENT:
    v = TAG_T;
    break;
#endif

  case KW_IF:
    if (D_GET_TAG(a) != TAG_CONS)
      return err_msg(errmsg_ill_syntax, 1, f);
    l = list_len(a);
    if ((l == 2) || (l == 3)){
      if ((v = l_eval(l_car(a))) < 0)
    return -1;
      if (D_GET_TAG(v) != TAG_NIL)
    return l_eval(l_car(l_cdr(a)));
      return  (l == 2) ? TAG_NIL : l_eval(l_car(l_cdr(l_cdr(a))));
    } else {
      return err_msg(errmsg_ill_syntax, 1, f);
    }
    break;
  }
  return v;
}
Exemple #8
0
/* Print an S-expression */ 
long
l_print(long s)
{
  long  v, t;
  int i;

  switch(D_GET_TAG(s)){

#ifdef SCHEME
  case TAG_NIL:
    printf("#f");
    break;

  case TAG_T:
    printf("#t");
    break;
#else
  case TAG_NIL:
    printf("nil");
    break;

  case TAG_T:
    printf("t");
    break;
#endif
  case TAG_INT:
    v = int_get_c(s);
    printf("%ld", v);
    break;

  case TAG_SYMB:
    i = s & D_MASK_DATA;
    printf("%s", t_symb_pname[i]);
    break;

  case TAG_EOF:
    printf("<eof>");
    break;

  case TAG_UNDEF:  /* for debugging */
    printf("<undefined>"); 
    break;

  case TAG_CONS:
    printf("(");
    t = s;
    l_print(l_car(t));
    while (D_GET_TAG(l_cdr(t)) == TAG_CONS) {
      printf(" ");
      t = l_cdr(t);
      l_print(l_car(t));
    }
    if (D_GET_TAG(l_cdr(t)) != TAG_NIL){
      printf(" . ");
      l_print(l_cdr(t)); 
    }
    printf(")");
    break;
  }
  return TAG_T;
}
Exemple #9
0
/* 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;
}
Exemple #10
0
/* Function application (user defined function) */
long
apply(long func, long aparams, int n) 
{
  long   fdef, fbody, f, sym, a, v;
  int  i;

#ifdef ZX81
/*
..almost  useless, let's save space
#asm
    ld hl,0
    add hl,sp
    ld (__sp),hl
#endasm
    if (200 + &t_stack[t_stack_ptr]>=_sp)
      return err_msg(errmsg_stack_of, 0, 0);
*/
#else
  if (t_stack_ptr + n > STACK_SIZE)   /* stack overflow */
    return err_msg(errmsg_stack_of, 0, 0);
#endif

  if (D_GET_TAG(func) == TAG_SYMB){         /* function symbol */
    fdef = t_symb_fval[D_GET_DATA(func)];
  } else if (D_GET_TAG(func) == TAG_CONS){  /* lambda exp */
    fdef = func;
  }

  /* bind */
  f = l_car(fdef);  /* formal parameters */
  a = aparams;      /* actual parameters */
  t_stack_ptr = t_stack_ptr + n;
  for (i = 0; i < n; i++, f = l_cdr(f), a = l_cdr(a)){
    sym = l_car(f);
    /* push old symbol values onto stack */
    t_stack[t_stack_ptr - i - 1] = t_symb_val[D_GET_DATA(sym)];
    /* bind argument value to symbol */
    t_symb_val[D_GET_DATA(sym)] = l_car(a);
  }

  if (gc_protect(aparams) < 0)
    return -1;

  /* evaluate function body */
  fbody = l_cdr(fdef);  /* function body */
  for (v = TAG_NIL; D_GET_TAG(fbody) == TAG_CONS; fbody = l_cdr(fbody)){
    if ((v = l_eval(l_car(fbody))) < 0)
      break;   /* error ... never return immediately - need unbinding. */
  }

  /* pop gc_protected objects, including 'gc_unprotect(aparams)'. */
  while ((t_stack[t_stack_ptr-1] & D_GC_MARK) != 0)
    --t_stack_ptr;   

  /* unbind: restore old variable values from stack */
  for (i = 0, f = l_car(fdef); i < n; i++, f = l_cdr(f)){
    sym = l_car(f);
    t_symb_val[D_GET_DATA(sym)] = t_stack[t_stack_ptr - i - 1];
  }
  t_stack_ptr = t_stack_ptr - n;

  return v;
}