예제 #1
0
파일: clisp.c 프로젝트: meesokim/z88dk
/* Print an error message */
char
err_msg(char *msg, char f, long s)
{
  printf("\nERROR. \n%s", msg);
  if (f != 0)
    l_print(s);
  printf("\n");
  return -1;
}
예제 #2
0
파일: factorial.c 프로젝트: jleffler/soq
static inline int l_factorial(int f_max, int l_max)
{
    long double factorial = 1.0;
    long double old_value = factorial;
    int i;
    for (i = 1; i < 300; i++)
    {
        old_value = factorial;
        factorial *= i;
        if (!isfinite(factorial))
            break;
        if (i <= 12 ||
            (i == f_max + 1 || i == f_max) ||
            (i == l_max + 1 || i == l_max))
            l_print(i, factorial);
    }
    l_print(i - 1, old_value);
    return i - 1;
}
예제 #3
0
/*
  Test the print function. Just print the expected output
  and actual output to the screen. The array vals
  contains the items expected in the list, in order of appearance
  in the list.
*/
void print_test(linked_list list, int* vals, int n) {
  printf("Expecting:");
  int i;
  for (i = 0; i < n; i++) {
    printf(" %d", vals[i]);
  }
  printf("\n");
  printf("Got      : ");
  l_print(list);
  printf("\n\n");
}
예제 #4
0
/*
** Do the REPL: repeatedly read (load) a line, evaluate (call) it, and
** print any results.
*/
static void doREPL (lua_State *L) {
  int status;
  const char *oldprogname = progname;
  progname = NULL;  /* no 'progname' on errors in interactive mode */
  while ((status = loadline(L)) != -1) {
    if (status == LUA_OK)
      status = docall(L, 0, LUA_MULTRET);
    if (status == LUA_OK) l_print(L);
    else report(L, status);
  }
  lua_settop(L, 0);  /* clear stack */
  lua_writeline();
  progname = oldprogname;
}
예제 #5
0
파일: clisp.c 프로젝트: meesokim/z88dk
/* 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 */
  }
}
예제 #6
0
파일: clisp.c 프로젝트: meesokim/z88dk
/* 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;
}
예제 #7
0
파일: clisp.c 프로젝트: meesokim/z88dk
/* 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;
}