示例#1
0
文件: chars.c 项目: skagedal/lipa
LObject *
lisp_char_smallerp (LObject *args)
{
  if (!lipa_list_at_least (args, 2) || !CHARP (lipa_car (args)))
    {
      fputs ("char<? wants at least two arguments\n", stderr);
      return NULL;
    }
  
  while (lipa_cdr (args))
    {
      if (!CHARP (lipa_cadr (args)))
	{
	  fputs ("char<? wants char arguments!\n", stderr);
	  return NULL;
	}
      else if (L_CHAR (lipa_car (args)) >= (L_CHAR (lipa_cadr (args))))
	{
	  return lisp_false;
	}
      else
	args = (lipa_cdr (args));
    }

  return lisp_true;
}
示例#2
0
文件: chars.c 项目: skagedal/lipa
LObject *
lisp_char_greater_or_equalp_ci (LObject *args)
{
  if (!lipa_list_at_least (args, 2) || !CHARP (lipa_car (args)))
    {
      fputs ("char-ci>=? wants at least two arguments\n", stderr);
      return NULL;
    }
  
  while (lipa_cdr (args))
    {
      if (!CHARP (lipa_cadr (args)))
	{
	  fputs ("char-ci>=? wants char arguments!\n", stderr);
	  return NULL;
	}
      else if (tolower (L_CHAR (lipa_car (args))) <
	       (tolower (L_CHAR (lipa_cadr (args)))))
	{
	  return lisp_false;
	}
      else
	args = (lipa_cdr (args));
    }

  return lisp_true;
}
示例#3
0
/**
 * dup an object
 */
lv_t *lisp_dup_item(lv_t *v) {
    lv_t *r;
    lv_t *vptr = v;
    lv_t *rptr;
    assert(v);

    switch(v->type) {
    case l_int:
        r = lisp_create_int(0);
        mpz_set(L_INT(r), L_INT(v));
        return r;
    case l_rational:
        r = lisp_create_rational(1, 1);
        mpq_set(L_RAT(r), L_RAT(v));
        return r;
    case l_float:
        r = lisp_create_float(0.0);
        mpfr_set(L_FLOAT(r), L_FLOAT(v), MPFR_ROUND_TYPE);
        return r;
    case l_bool:
        return v;
    case l_sym:
        return lisp_create_symbol(L_SYM(v));
    case l_str:
        return lisp_create_string(L_STR(v));
    case l_null:
        return v;
    case l_port:
        /* can't really copy this -- it's a socket or a file
           handle, or something else.  */
        return v;
    case l_char:
        return lisp_create_char(L_CHAR(v));
    case l_fn:
        /* can't really copy this either, but it's essentially
           immutable */
        return v;
    case l_err:
        return lisp_create_err(L_ERR(v));
    case l_hash:
        /* FIXME: should really be a copy */
        return v;
    case l_pair:
        r = lisp_create_pair(NULL, NULL);
        rptr = r;

        while(vptr && L_CAR(vptr)) {
            L_CAR(rptr) = lisp_dup_item(L_CAR(vptr));
            vptr = L_CDR(vptr);
            if(vptr) {
                L_CDR(rptr) = lisp_create_pair(NULL, NULL);
                rptr = L_CDR(rptr);
            }
        }
        return r;
    }

    assert(0);
}
示例#4
0
文件: basic.c 项目: skagedal/lipa
LObject *
lipa_new_char (guchar c)
{
  LObject *obj = g_new0 (LObject, 1);
  
  obj->type = L_OBJ_CHAR;
  L_CHAR (obj) = c;

  return obj;
}
示例#5
0
文件: chars.c 项目: skagedal/lipa
LObject *
lisp_char_lowerp (LObject *args)
{
  if (!lipa_list_length (args, 1) || !CHARP (lipa_car (args)))
    {
      fputs ("char-lower? wants 1 character argument\n", stderr);
      return NULL;
    }
  
  return (islower (L_CHAR (lipa_car (args))) ? lisp_true : lisp_false);
}
示例#6
0
lv_t *lisp_create_type(void *value, lisp_type_t type) {
    lv_t *result;

    result = safe_malloc(sizeof(lv_t));

    result->type = type;

    result->row = 0;
    result->col = 0;
    result->file = NULL;

    switch(type) {
    case l_char:
        L_CHAR(result) = *((char*)value);
        break;
    case l_int:
        mpz_init(L_INT(result));
        mpz_set_si(L_INT(result), *(int64_t *)value);
        break;
    case l_rational:
        mpq_init(L_RAT(result));
        break;
    case l_float:
        mpfr_init(L_FLOAT(result));
        mpfr_set_d(L_FLOAT(result), *(double*)value, MPFR_ROUND_TYPE);
        break;
    case l_bool:
        L_BOOL(result) = *((int*)value);
        break;
    case l_sym:
        L_SYM(result) = safe_strdup((char*)value);
        break;
    case l_str:
        L_STR(result) = safe_strdup((char*)value);
        break;
    case l_err:
        L_ERR(result) = *((lisp_errsubtype_t *)value);
        break;
    case l_fn:
        L_FN(result) = (lisp_method_t)value;
        break;
    case l_port:
        L_PORT(result) = (port_info_t *)value;
        break;
    default:
        assert(0);
        fprintf(stderr, "Bad type");
        exit(EXIT_FAILURE);
    }

    return result;
}
示例#7
0
/**
 * print the object specified by v in the provided buffer.
 * follows standard snprintf rules, in that it returns the
 * number of bytes required to print if an insufficient buffer
 * length is provided.
 *
 * if display is true, then the results are printed as human
 * readable (p_display), otherwise it is printed as machine
 * readable (p_write)
 */
int lisp_snprintf(lexec_t *exec, char *buf, int len, lv_t *v, int display) {
    int pair_len = 0;

    switch(v->type) {
    case l_null:
        return snprintf(buf, len, "()");
    case l_int:
        /* return snprintf(buf, len, "%" PRIu64, L_INT(v)); */
        return gmp_snprintf(buf, len, "%Zd", L_INT(v));
    case l_rational:
        return gmp_snprintf(buf, len, "%Qd", L_RAT(v));
    case l_float:
        /* return snprintf(buf, len, "%0.16g", L_FLOAT(v)); */
        return mpfr_snprintf(buf, len, "%Rg", L_FLOAT(v));
    case l_bool:
        return snprintf(buf, len, "%s", L_BOOL(v) ? "#t": "#f");
    case l_sym:
        return snprintf(buf, len, "%s", L_SYM(v));
    case l_str:
        if(display)
            return snprintf(buf, len, "%s", L_STR(v));
        else
            return snprintf(buf, len, "\"%s\"", L_STR(v));
    case l_pair:
        if(len >= 1)
            sprintf(buf, "(");

        pair_len += 1;

        lv_t *vp = v;

        while(vp && L_CAR(vp)) {
            pair_len += lisp_snprintf(exec, buf + pair_len,
                                      (len - pair_len) > 0 ? len - pair_len : 0,
                                      L_CAR(vp), display);

            if(L_CDR(vp) && (L_CDR(vp)->type != l_pair)) {
                pair_len += snprintf(buf + pair_len,
                                     (len - pair_len) > 0 ? len - pair_len : 0,
                                     " . ");

                pair_len += lisp_snprintf(exec, buf + pair_len,
                                          (len - pair_len) > 0 ? len - pair_len : 0,
                                          L_CDR(vp), display);
                vp = NULL;
            } else {
                vp = L_CDR(vp);
                if(vp) {
                    if (len - pair_len > 0)
                        snprintf(buf + pair_len, len - pair_len, " ");
                    pair_len++;
                }
            }
        }

        if (len - pair_len > 0) {
            sprintf(buf + pair_len, ")");
        }

        pair_len++;
        return pair_len;
        break;
    case l_fn:
        rt_assert(!display, le_type, "cannot display function types");

        if(L_FN(v) == NULL)
            return snprintf(buf, len, "<lambda@%p>", v);
        else
            return snprintf(buf, len, "<built-in@%p>", v);
        break;
    case l_char:
        if(display)
            return snprintf(buf, len, "%c", L_CHAR(v));
        else
            return snprintf(buf, len, "#\\x%02x", L_CHAR(v));
        break;
    case l_port:
        rt_assert(!display, le_type, "cannot display port types");
        return snprintf(buf, len, "<port@%p>", v);
        break;
    case l_err:
        rt_assert(!display, le_type, "cannot display error types");
        return snprintf(buf, len, "<error@%p:%d>", v, L_ERR(v));
        break;
    default:
        // missing a type check.
        assert(0);
    }

}