コード例 #1
0
ファイル: types.c プロジェクト: 6e441f9c/julia
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;
}
コード例 #2
0
static void getFloat( ss_block *ss_new, char *start, int skip, int command )
{
    char    *text = start + skip;

    ss_new->type = SE_FLOAT;

    switch( command ) {
    case AFTER_DOT:
        if( !isdigit( *text ) ) {
            if( *text == 'E' || *text == 'D' ) {
                getFloat( ss_new, start, text - start + 1, AFTER_EXP );
                return;
            }
            if( *text && !isspace( *text ) && !issymbol( *text ) ) {
                if( *text ) {
                    text++;
                }
                ss_new->type = SE_INVALIDTEXT;
            }
            break;
        }
        text++;
        while( isdigit( *text ) ) {
            text++;
        }
        if( *text != 'E' && *text != 'D' ) {
            break;
        }
        text++;
        // fall through
    case AFTER_EXP:
        if( *text == '+' || *text == '-' ) {
            text++;
        }
        if( !isdigit( *text ) ) {
            if( *text ) {
                text++;
            }
            ss_new->type = SE_INVALIDTEXT;
            break;
        }
        text++;
        while( isdigit( *text ) ) {
            text++;
        }
        if( *text && !isspace( *text ) && !issymbol( *text ) ) {
            ss_new->type = SE_INVALIDTEXT;
            text++;
        }
    }
    ss_new->len = text - start;
}
コード例 #3
0
ファイル: print.c プロジェクト: SatoHiroki/julia
static int lengthestimate(value_t v)
{
    // get the width of an expression if we can do so cheaply
    if (issymbol(v))
        return u8_strwidth(symbol_name(v));
    return -1;
}
コード例 #4
0
ファイル: eval.c プロジェクト: stesla/objection
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));
}
コード例 #5
0
ファイル: bscm.c プロジェクト: bvanslyke/brandonscheme
static bool list_begins_with(object_t *list, object_t *search) {
    if(ispair(list)) {
        object_t *pair_car = car(list);
        return issymbol(pair_car) && (pair_car == search);
    }
    return false;
}
コード例 #6
0
ファイル: hermite.c プロジェクト: AnderainLovelace/Taumath
void
yyhermite(void)
{
	int n;

	N = pop();
	X = pop();

	push(N);
	n = pop_integer();

	if (n < 0) {
		push_symbol(HERMITE);
		push(X);
		push(N);
		list(3);
		return;
	}

	if (issymbol(X))
		yyhermite2(n);
	else {
		Y = X;			// do this when X is an expr
		X = symbol(SECRETX);
		yyhermite2(n);
		X = Y;
		push(symbol(SECRETX));
		push(X);
		subst();
		eval();
	}
}
コード例 #7
0
ファイル: factorpoly.c プロジェクト: AnderainLovelace/Taumath
void
factorpoly(void)
{
	save();

	p2 = pop();
	p1 = pop();

	if (!find(p1, p2)) {
		push(p1);
		restore();
		return;
	}

	if (!ispoly(p1, p2)) {
		push(p1);
		restore();
		return;
	}

	if (!issymbol(p2)) {
		push(p1);
		restore();
		return;
	}

	push(p1);
	push(p2);
	yyfactorpoly();

	restore();
}
コード例 #8
0
ファイル: main.cpp プロジェクト: ComputerNerd/eigenmath
int get_custom_key_handler_state() {
  U* tmp = usr_symbol("prizmUIhandleKeys");
  if (!issymbol(tmp)) return 0;
  tmp = get_binding(tmp);
  if(isnonnegativeinteger(tmp)) {
    return !iszero(tmp);
  } else return 0;
}
コード例 #9
0
ファイル: print.c プロジェクト: SatoHiroki/julia
static inline int tinyp(value_t v)
{
    if (issymbol(v))
        return (u8_strwidth(symbol_name(v)) < SMALL_STR_LEN);
    if (fl_isstring(v))
        return (cv_len((cvalue_t*)ptr(v)) < SMALL_STR_LEN);
    return (isfixnum(v) || isbuiltin(v) || v==FL_F || v==FL_T || v==FL_NIL ||
            v == FL_EOF);
}
コード例 #10
0
ファイル: print.c プロジェクト: ArchRobison/julia
static inline int tinyp(fl_context_t *fl_ctx, value_t v)
{
    if (issymbol(v))
        return (u8_strwidth(symbol_name(fl_ctx, v)) < SMALL_STR_LEN);
    if (fl_isstring(fl_ctx, v))
        return (cv_len((cvalue_t*)ptr(v)) < SMALL_STR_LEN);
    return (isfixnum(v) || isbuiltin(v) || v==fl_ctx->F || v==fl_ctx->T || v==fl_ctx->NIL ||
            v == fl_ctx->FL_EOF);
}
コード例 #11
0
ファイル: julia_extensions.c プロジェクト: JuliaLang/julia
/* check whether arg is a symbol that consists solely of underscores. */
value_t fl_julia_underscore_symbolp(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
{
    argcount(fl_ctx, "underscore-symbol?", nargs, 1);
    if (!issymbol(args[0])) return fl_ctx->F;
    char *op = symbol_name(fl_ctx, args[0]);
    if (*op == '\0') return fl_ctx->F; // return false for empty symbol
    while (*op == '_') ++op;
    return *op ? fl_ctx->F : fl_ctx->T;
}
コード例 #12
0
ファイル: primitives.c プロジェクト: spacemanaki/lisp-in-c
object_t primitive_eq(object_t argl) {
  object_t a1 = car(argl);
  object_t a2 = car(cdr(argl));

  int result;

  if(issymbol(a1) && issymbol(a2))
    result = obj_symbol_cmp(a1, a2);
  else if(isnum(a1) && isnum(a2))
    result = (obj_get_number(a1) == obj_get_number(a2));
  else
    result = 0;

  if(result)
    return obj_new_symbol("#t");
  else
    return obj_new_symbol("#f");
}
コード例 #13
0
ファイル: lex.c プロジェクト: doniexun/compiler-3
static int same_token(int a, int b)
{
    if (isname(a) && isname(b))
        return 1;

    if (isname(a) && isdigit(b))
        return 1;

    if (isdigit(a) && isdigit(b))
        return 1;
    
    if (issymbol(a) && issymbol(b) && a != '(' && a != ')' && b != '(' && b != ')')
        return 1;
    
    if (a == '-' && isdigit(b))
        return 1;

    return 0;
}
コード例 #14
0
ファイル: eval.c プロジェクト: stesla/objection
ref_t lookup(ref_t symbol) {
  assert(issymbol(symbol));
  ref_t binding, closure = C(cont)->closure;
  while (!isnil(closure)) {
    binding = car(closure);
    if (car(binding) == symbol)
      return cdr(binding);
    closure = cdr(closure);
  }
  return get_value(symbol);
}
コード例 #15
0
ファイル: ast.c プロジェクト: RZEWa60/julia
static jl_sym_t *scmsym_to_julia(value_t s)
{
    assert(issymbol(s));
    if (fl_isgensym(s)) {
        static char gsname[16];
        char *n = uint2str(&gsname[1], sizeof(gsname)-1,
                           ((gensym_t*)ptr(s))->id, 10);
        *(--n) = '#';
        return jl_symbol(n);
    }
    return jl_symbol(symbol_name(s));
}
コード例 #16
0
ファイル: builtins.c プロジェクト: LiaoPengyu/femtolisp
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;
}
コード例 #17
0
ファイル: misc.c プロジェクト: funny-falcon/lwc
/*****************************************************************************
	check syntax patterns.
*****************************************************************************/
bool syntax_pattern (NormPtr p, Token first, ...)
{
	va_list ap;
	va_start (ap, first);
	for (;first != -1; first = va_arg (ap, Token))
		switch (first) {
		default: if (CODE [p++] != first) return 0;
		ncase VERIFY_symbol: if (!issymbol (CODE [p++])) return 0;
		ncase VERIFY_string: if (!isvalue (CODE [p++])) return 0;
		}
	va_end (ap);
	return 1;
}
コード例 #18
0
ファイル: ast.c プロジェクト: ararslan/julia
value_t fl_julia_logmsg(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
{
    int kwargs_len = (int)nargs - 6;
    if (nargs < 6 || kwargs_len % 2 != 0) {
        lerror(fl_ctx, fl_ctx->ArgError, "julia-logmsg: bad argument list - expected "
               "level (symbol) group (symbol) id file line msg . kwargs");
    }
    value_t arg_level = args[0];
    value_t arg_group = args[1];
    value_t arg_id    = args[2];
    value_t arg_file  = args[3];
    value_t arg_line  = args[4];
    value_t arg_msg   = args[5];
    value_t *arg_kwargs = args + 6;
    if (!isfixnum(arg_level) || !issymbol(arg_group) || !issymbol(arg_id) ||
        !issymbol(arg_file) || !isfixnum(arg_line) || !fl_isstring(fl_ctx, arg_msg)) {
        lerror(fl_ctx, fl_ctx->ArgError,
               "julia-logmsg: Unexpected type in argument list");
    }

    // Abuse scm_to_julia here to convert arguments.  This is meant for `Expr`s
    // but should be good enough provided we're only passing simple numbers,
    // symbols and strings.
    jl_value_t *group=NULL, *id=NULL, *file=NULL, *line=NULL, *msg=NULL;
    jl_array_t *kwargs=NULL;
    JL_GC_PUSH6(&group, &id, &file, &line, &msg, &kwargs);
    group = scm_to_julia(fl_ctx, arg_group, NULL);
    id    = scm_to_julia(fl_ctx, arg_id, NULL);
    file  = scm_to_julia(fl_ctx, arg_file, NULL);
    line  = scm_to_julia(fl_ctx, arg_line, NULL);
    msg   = scm_to_julia(fl_ctx, arg_msg, NULL);
    kwargs = jl_alloc_vec_any(kwargs_len);
    for (int i = 0; i < kwargs_len; ++i) {
        jl_array_ptr_set(kwargs, i, scm_to_julia(fl_ctx, arg_kwargs[i], NULL));
    }
    jl_log(numval(arg_level), NULL, group, id, file, line, (jl_value_t*)kwargs, msg);
    JL_GC_POP();
    return fl_ctx->T;
}
コード例 #19
0
ファイル: print.c プロジェクト: SatoHiroki/julia
void print_traverse(value_t v)
{
    value_t *bp;
    while (iscons(v)) {
        if (ismarked(v)) {
            bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
            if (*bp == (value_t)HT_NOTFOUND)
                *bp = fixnum(printlabel++);
            return;
        }
        mark_cons(v);
        print_traverse(car_(v));
        v = cdr_(v);
    }
    if (!ismanaged(v) || issymbol(v))
        return;
    if (ismarked(v)) {
        bp = (value_t*)ptrhash_bp(&printconses, (void*)v);
        if (*bp == (value_t)HT_NOTFOUND)
            *bp = fixnum(printlabel++);
        return;
    }
    if (isvector(v)) {
        if (vector_size(v) > 0)
            mark_cons(v);
        unsigned int i;
        for(i=0; i < vector_size(v); i++)
            print_traverse(vector_elt(v,i));
    }
    else if (iscprim(v)) {
        mark_cons(v);
    }
    else if (isclosure(v)) {
        mark_cons(v);
        function_t *f = (function_t*)ptr(v);
        print_traverse(f->bcode);
        print_traverse(f->vals);
        print_traverse(f->env);
    }
    else {
        assert(iscvalue(v));
        cvalue_t *cv = (cvalue_t*)ptr(v);
        // don't consider shared references to ""
        if (!cv_isstr(cv) || cv_len(cv)!=0)
            mark_cons(v);
        fltype_t *t = cv_class(cv);
        if (t->vtable != NULL && t->vtable->print_traverse != NULL)
            t->vtable->print_traverse(v);
    }
}
コード例 #20
0
ファイル: product.c プロジェクト: AnderainLovelace/Taumath
void
eval_product(void)
{
	int i, j, k;

	// 1st arg (quoted)

	X = cadr(p1);
	if (!issymbol(X))
		stop("product: 1st arg?");

	// 2nd arg

	push(caddr(p1));
	eval();
	j = pop_integer();
	if (j == (int) 0x80000000)
		stop("product: 2nd arg?");

	// 3rd arg

	push(cadddr(p1));
	eval();
	k = pop_integer();
	if (k == (int) 0x80000000)
		stop("product: 3rd arg?");

	// 4th arg
	// fix

	p1 = cddddr(p1);
	p1 = car(p1);

	B = get_binding(X);
	A = get_arglist(X);

	push_integer(1);

	for (i = j; i <= k; i++) {
		push_integer(i);
		I = pop();
		set_binding(X, I);
		push(p1);
		eval();
		multiply();
	}

	set_binding_and_arglist(X, B, A);
}
コード例 #21
0
ファイル: main.cpp プロジェクト: ComputerNerd/eigenmath
int get_custom_fkey_label(int fkey) {
  U* tmp;
  if(fkey==2) {
    tmp = usr_symbol("prizmUIfkey3label");
  } else if (fkey==3) {
    tmp = usr_symbol("prizmUIfkey4label");
  } else if (fkey==5) {
    tmp = usr_symbol("prizmUIfkey6label");
  } else return 0;
  if (issymbol(tmp)) {
    tmp = get_binding(tmp);
    if(isnonnegativeinteger(tmp)) {
      return *tmp->u.q.a;
    }
  }
  return 0;
}
コード例 #22
0
ファイル: draw.cpp プロジェクト: ComputerNerd/eigenmath
void
setup_yrange_f(void)
{
	// default range is (-10,10)

	ymin = -10.0;

	ymax = 10.0;

	p1 = usr_symbol("yrange");

	if (!issymbol(p1))
		return;

	p1 = get_binding(p1);

	// must be two element vector

	if (!istensor(p1) || p1->u.tensor->ndim != 1 || p1->u.tensor->nelem != 2)
		return;

	push(p1->u.tensor->elem[0]);
	eval();
	yyfloat();
	eval();
	p2 = pop();

	push(p1->u.tensor->elem[1]);
	eval();
	yyfloat();
	eval();
	p3 = pop();

	if (!isnum(p2) || !isnum(p3))
		return;

	push(p2);
	ymin = pop_double();

	push(p3);
	ymax = pop_double();

	if (ymin == ymax)
		stop("draw: yrange is zero");
}
コード例 #23
0
ファイル: draw.cpp プロジェクト: ComputerNerd/eigenmath
void
setup_trange_f(void)
{
	// default range is (-pi, pi)

	tmin = -M_PI;

	tmax = M_PI;

	p1 = usr_symbol("trange");

	if (!issymbol(p1))
		return;

	p1 = get_binding(p1);

	// must be two element vector

	if (!istensor(p1) || p1->u.tensor->ndim != 1 || p1->u.tensor->nelem != 2)
		return;

	push(p1->u.tensor->elem[0]);
	eval();
	yyfloat();
	eval();
	p2 = pop();

	push(p1->u.tensor->elem[1]);
	eval();
	yyfloat();
	eval();
	p3 = pop();

	if (!isnum(p2) || !isnum(p3))
		return;

	push(p2);
	tmin = pop_double();

	push(p3);
	tmax = pop_double();

	if (tmin == tmax)
		stop("draw: trange is zero");
}
コード例 #24
0
ファイル: derivative.cpp プロジェクト: justloong/ArithMax
void
d_scalar_scalar(void)
{
    if (issymbol(p2))
        d_scalar_scalar_1();
    else {
        // Example: d(sin(cos(x)),cos(x))
        // Replace cos(x) <- X, find derivative, then do X <- cos(x)
        push(p1);		// sin(cos(x))
        push(p2);		// cos(x)
        push(symbol(SECRETX));	// X
        subst();		// sin(cos(x)) -> sin(X)
        push(symbol(SECRETX));	// X
        derivative();
        push(symbol(SECRETX));	// X
        push(p2);		// cos(x)
        subst();		// cos(X) -> cos(cos(x))
    }
}
コード例 #25
0
ファイル: julia_extensions.c プロジェクト: JuliaLang/julia
value_t fl_julia_strip_op_suffix(fl_context_t *fl_ctx, value_t *args, uint32_t nargs)
{
    argcount(fl_ctx, "strip-op-suffix", nargs, 1);
    if (!issymbol(args[0]))
        type_error(fl_ctx, "strip-op-suffix", "symbol", args[0]);
    char *op = symbol_name(fl_ctx, args[0]);
    size_t i = 0;
    while (op[i]) {
        size_t j = i;
        if (jl_op_suffix_char(u8_nextchar(op, &j)))
            break;
        i = j;
    }
    if (!op[i]) return args[0]; // no suffix to strip
    if (!i) return args[0]; // only suffix chars --- might still be a valid identifier
    char *opnew = strncpy((char*)malloc(i+1), op, i);
    opnew[i] = 0;
    value_t opnew_symbol = symbol(fl_ctx, opnew);
    free(opnew);
    return opnew_symbol;
}
コード例 #26
0
ファイル: macro.c プロジェクト: Distrotech/alsa-tools
//defines a new macro, adds it to the macro list
void new_macro(char *symbol, char *line, char *operand)
{
        extern int source_line_num;
        struct sym *sym;

	if (macro_ctn >= MAX_DEF_MACRO)
                as_exit("Parse Error: Too many macros");

        if(isalpha(*symbol)==0)
                as_exit("Parse Error: Symbol must start with an alpha character");
        
        if(ismacro(symbol)!=-1)
                as_exit("Parsed Error: macro is already defined");

        if(issymbol(symbol,&sym)!=-1)
                as_exit("Parse Error: Symbol is already defined");

        macro[macro_ctn].line_num=source_line_num;
        macro[macro_ctn].ptr=line;
        strcpy(macro[macro_ctn].name,symbol); 
        macro[macro_ctn].operands=operand;
        macro_ctn++;
        
}
コード例 #27
0
ファイル: primitives.c プロジェクト: spacemanaki/lisp-in-c
object_t primitive_symbolp(object_t argl) {
  if(issymbol(car(argl)))
    return obj_new_symbol("#t");
  else
    return obj_new_symbol("#f");
}
コード例 #28
0
ファイル: builtins.c プロジェクト: LiaoPengyu/femtolisp
static value_t fl_keywordp(value_t *args, u_int32_t nargs)
{
    argcount("keyword?", nargs, 1);
    return (issymbol(args[0]) &&
            iskeyword((symbol_t*)ptr(args[0]))) ? FL_T : FL_F;
}
コード例 #29
0
ファイル: read.c プロジェクト: GlenHertz/julia
// label is the backreference we'd like to fix up with this read
static value_t do_read_sexpr(value_t label)
{
    value_t v, sym, oldtokval, *head;
    value_t *pv;
    u_int32_t t;
    char c;

    t = peek();
    take();
    switch (t) {
    case TOK_CLOSE:
        lerror(ParseError, "read: unexpected ')'");
    case TOK_CLOSEB:
        lerror(ParseError, "read: unexpected ']'");
    case TOK_DOT:
        lerror(ParseError, "read: unexpected '.'");
    case TOK_SYM:
    case TOK_NUM:
        return tokval;
    case TOK_COMMA:
        head = &COMMA; goto listwith;
    case TOK_COMMAAT:
        head = &COMMAAT; goto listwith;
    case TOK_COMMADOT:
        head = &COMMADOT; goto listwith;
    case TOK_BQ:
        head = &BACKQUOTE; goto listwith;
    case TOK_QUOTE:
        head = &QUOTE;
    listwith:
        v = cons_reserve(2);
        car_(v) = *head;
        cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS);
        car_(cdr_(v)) = cdr_(cdr_(v)) = NIL;
        PUSH(v);
        if (label != UNBOUND)
            ptrhash_put(&readstate->backrefs, (void*)label, (void*)v);
        v = do_read_sexpr(UNBOUND);
        car_(cdr_(Stack[SP-1])) = v;
        return POP();
    case TOK_SHARPQUOTE:
        // femtoLisp doesn't need symbol-function, so #' does nothing
        return do_read_sexpr(label);
    case TOK_OPEN:
        PUSH(NIL);
        read_list(&Stack[SP-1], label);
        return POP();
    case TOK_SHARPSYM:
        sym = tokval;
        if (sym == tsym || sym == Tsym)
            return FL_T;
        else if (sym == fsym || sym == Fsym)
            return FL_F;
        // constructor notation
        c = nextchar();
        if (c != '(') {
            take();
            lerrorf(ParseError, "read: expected argument list for %s",
                    symbol_name(tokval));
        }
        PUSH(NIL);
        read_list(&Stack[SP-1], UNBOUND);
        if (sym == vu8sym) {
            sym = arraysym;
            Stack[SP-1] = fl_cons(uint8sym, Stack[SP-1]);
        }
        else if (sym == fnsym) {
            sym = FUNCTION;
        }
        v = symbol_value(sym);
        if (v == UNBOUND)
            fl_raise(fl_list2(UnboundError, sym));
        return fl_apply(v, POP());
    case TOK_OPENB:
        return read_vector(label, TOK_CLOSEB);
    case TOK_SHARPOPEN:
        return read_vector(label, TOK_CLOSE);
    case TOK_SHARPDOT:
        // eval-when-read
        // evaluated expressions can refer to existing backreferences, but they
        // cannot see pending labels. in other words:
        // (... #2=#.#0# ... )    OK
        // (... #2=#.(#2#) ... )  DO NOT WANT
        sym = do_read_sexpr(UNBOUND);
        if (issymbol(sym)) {
            v = symbol_value(sym);
            if (v == UNBOUND)
                fl_raise(fl_list2(UnboundError, sym));
            return v;
        }
        return fl_toplevel_eval(sym);
    case TOK_LABEL:
        // create backreference label
        if (ptrhash_has(&readstate->backrefs, (void*)tokval))
            lerrorf(ParseError, "read: label %ld redefined", numval(tokval));
        oldtokval = tokval;
        v = do_read_sexpr(tokval);
        ptrhash_put(&readstate->backrefs, (void*)oldtokval, (void*)v);
        return v;
    case TOK_BACKREF:
        // look up backreference
        v = (value_t)ptrhash_get(&readstate->backrefs, (void*)tokval);
        if (v == (value_t)HT_NOTFOUND)
            lerrorf(ParseError, "read: undefined label %ld", numval(tokval));
        return v;
    case TOK_GENSYM:
        pv = (value_t*)ptrhash_bp(&readstate->gensyms, (void*)tokval);
        if (*pv == (value_t)HT_NOTFOUND)
            *pv = fl_gensym(NULL, 0);
        return *pv;
    case TOK_DOUBLEQUOTE:
        return read_string();
    }
    return FL_UNSPECIFIED;
}
コード例 #30
0
ファイル: ast.c プロジェクト: RZEWa60/julia
static jl_value_t *scm_to_julia_(value_t e)
{
    if (fl_isnumber(e)) {
        if (iscprim(e)) {
            numerictype_t nt = cp_numtype((cprim_t*)ptr(e));
            switch (nt) {
            case T_DOUBLE:
                return (jl_value_t*)jl_box_float64(*(double*)cp_data((cprim_t*)ptr(e)));
            case T_FLOAT:
                return (jl_value_t*)jl_box_float32(*(float*)cp_data((cprim_t*)ptr(e)));
            case T_INT64:
                return (jl_value_t*)jl_box_int64(*(int64_t*)cp_data((cprim_t*)ptr(e)));
            case T_UINT8:
                return (jl_value_t*)jl_box_uint8(*(uint8_t*)cp_data((cprim_t*)ptr(e)));
            case T_UINT16:
                return (jl_value_t*)jl_box_uint16(*(uint16_t*)cp_data((cprim_t*)ptr(e)));
            case T_UINT32:
                return (jl_value_t*)jl_box_uint32(*(uint32_t*)cp_data((cprim_t*)ptr(e)));
            case T_UINT64:
                return (jl_value_t*)jl_box_uint64(*(uint64_t*)cp_data((cprim_t*)ptr(e)));
            default:
                ;
            }
        }
        if (isfixnum(e)) {
            int64_t ne = numval(e);
#ifdef __LP64__
            return (jl_value_t*)jl_box_int64(ne);
#else
            if (ne > S32_MAX || ne < S32_MIN)
                return (jl_value_t*)jl_box_int64(ne);
            return (jl_value_t*)jl_box_int32((int32_t)ne);
#endif
        }
        uint64_t n = toulong(e, "scm_to_julia");
#ifdef __LP64__
        return (jl_value_t*)jl_box_int64((int64_t)n);
#else
        if (n > S32_MAX)
            return (jl_value_t*)jl_box_int64((int64_t)n);
        return (jl_value_t*)jl_box_int32((int32_t)n);
#endif
    }
    if (issymbol(e)) {
        if (!fl_isgensym(e)) {
            char *sn = symbol_name(e);
            if (!strcmp(sn, "true"))
                return jl_true;
            else if (!strcmp(sn, "false"))
                return jl_false;
        }
        return (jl_value_t*)scmsym_to_julia(e);
    }
    if (fl_isstring(e)) {
        return jl_pchar_to_string(cvalue_data(e), cvalue_len(e));
    }
    if (e == FL_F) {
        return jl_false;
    }
    if (e == FL_T) {
        return jl_true;
    }
    if (e == FL_NIL) {
        return (jl_value_t*)jl_null;
    }
    if (iscons(e)) {
        value_t hd = car_(e);
        if (issymbol(hd)) {
            jl_sym_t *sym = scmsym_to_julia(hd);
            /* tree node types:
               goto  gotoifnot  label  return
               lambda  call  =  quote
               null  top  method
               body  file new
               line  enter  leave
            */
            size_t n = llength(e)-1;
            size_t i;
            if (sym == lambda_sym) {
                jl_expr_t *ex = jl_exprn(lambda_sym, n);
                e = cdr_(e);
                value_t largs = car_(e);
                jl_cellset(ex->args, 0, full_list(largs));
                e = cdr_(e);
                
                value_t ee = car_(e);
                jl_array_t *vinf = jl_alloc_cell_1d(3);
                jl_cellset(vinf, 0, full_list(car_(ee)));
                ee = cdr_(ee);
                jl_cellset(vinf, 1, full_list_of_lists(car_(ee)));
                ee = cdr_(ee);
                jl_cellset(vinf, 2, full_list_of_lists(car_(ee)));
                assert(!iscons(cdr_(ee)));
                jl_cellset(ex->args, 1, vinf);
                e = cdr_(e);
                
                for(i=2; i < n; i++) {
                    assert(iscons(e));
                    jl_cellset(ex->args, i, scm_to_julia_(car_(e)));
                    e = cdr_(e);
                }
                return
                    (jl_value_t*)jl_new_lambda_info((jl_value_t*)ex, jl_null);
            }

            e = cdr_(e);
            if (sym == line_sym && n==1) {
                return jl_new_struct(jl_linenumbernode_type,
                                     scm_to_julia_(car_(e)));
            }
            if (sym == label_sym) {
                return jl_new_struct(jl_labelnode_type,
                                     scm_to_julia_(car_(e)));
            }
            if (sym == goto_sym) {
                return jl_new_struct(jl_gotonode_type,
                                     scm_to_julia_(car_(e)));
            }
            if (sym == quote_sym) {
                return jl_new_struct(jl_quotenode_type,
                                     scm_to_julia_(car_(e)));
            }
            if (sym == top_sym) {
                return jl_new_struct(jl_topnode_type,
                                     scm_to_julia_(car_(e)));
            }
            jl_expr_t *ex = jl_exprn(sym, n);
            for(i=0; i < n; i++) {
                assert(iscons(e));
                jl_cellset(ex->args, i, scm_to_julia_(car_(e)));
                e = cdr_(e);
            }
            return (jl_value_t*)ex;
        }
        else {
            jl_error("malformed tree");
        }
    }
    if (iscprim(e) && cp_class((cprim_t*)ptr(e))==wchartype) {
        jl_value_t *wc =
            jl_box32(jl_char_type, *(int32_t*)cp_data((cprim_t*)ptr(e)));
        return wc;
    }
    if (iscvalue(e) && cv_class((cvalue_t*)ptr(e)) == jvtype) {
        return *(jl_value_t**)cv_data((cvalue_t*)ptr(e));
    }
    jl_error("malformed tree");
    
    return (jl_value_t*)jl_null;
}