void initialize_intrinsic() { int i; SYMBOL sp; intrinsic_entry *ep; for (i = 0, ep = &intrinsic_table[0]; INTR_OP((ep = &intrinsic_table[i])) != INTR_END; i++){ if ((ep->langSpec & langSpecSet) == 0) { continue; } if (!(isValidString(INTR_NAME(ep)))) { continue; } if (INTR_HAS_KIND_ARG(ep)) { if (((INTR_OP(ep) != INTR_MINLOC) && (INTR_OP(ep) != INTR_MAXLOC)) && INTR_RETURN_TYPE_SAME_AS(ep) != -1) { fatal("%: Invalid intrinsic initialization.", __func__); } } sp = find_symbol((char *)INTR_NAME(ep)); SYM_TYPE(sp) = S_INTR; SYM_VAL(sp) = i; } }
sexpr_t* eval(sexpr_t* sexpr, sexpr_t** env, sexpr_list_t* roots, error_t** error) { if(sexpr == NULL) { return interp.nil_sym; } /* printf("[eval]\n"); */ /* print_sexpr(sexpr); */ /* printf("\n"); */ roots = cons_to_roots_list(roots, sexpr); gc_collect(roots); if(ATOM(sexpr)) { if(SYM(sexpr)) { if(interp.t_sym == sexpr) { return interp.t_sym; } if(interp.nil_sym == sexpr) { return interp.nil_sym; } sexpr_t* val = assoc(sexpr, *env); if(val == NULL) { *error = mk_error("Undefined symbol", SYM_VAL(sexpr)); } return val; } if(INT(sexpr)) { return sexpr; } } else if(ATOM(CAR(sexpr))) { if(SYM(CAR(sexpr))) { // quote if(interp.quote_sym == CAR(sexpr)) { if(CDR(sexpr) == NULL) { *error = mk_error("Missing quote argument", ""); return NULL; } if(CDR(CDR(sexpr)) != NULL) { *error = mk_error("Too many arguments for quote", ""); return NULL; } return CAR(CDR(sexpr)); } // atom if(interp.atom_sym == CAR(sexpr)) { if(ATOM(eval(CAR(CDR(sexpr)), env, roots, error))) { return interp.t_sym; } return interp.nil_sym; } // eq if(interp.eq_sym == CAR(sexpr)) { // TODO check nb args sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error); if(*error != NULL) { return NULL; } roots = cons_to_roots_list(roots, e1); sexpr_t* e2 = eval(CAR(CDR(CDR(sexpr))), env, roots, error); if(*error != NULL) { return NULL; } if(INT(e1) && INT(e2)) { if(INT_VAL(e1) == INT_VAL(e2)) { return interp.t_sym; } return interp.nil_sym; } if(e1 == e2) { return interp.t_sym; } return interp.nil_sym; } // if if(interp.if_sym == CAR(sexpr)) { sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error); if(*error != NULL) { return NULL; } if(e1 == interp.nil_sym) { return eval(CAR(CDR(CDR(CDR(sexpr)))), env, roots, error); } else { return eval(CAR(CDR(CDR(sexpr))), env, roots, error); } } // car if(interp.car_sym == CAR(sexpr)) { sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error); if(*error != NULL) { return NULL; } if(e1 == interp.nil_sym) { return interp.nil_sym; } return CAR(e1); } // cdr if(interp.cdr_sym == CAR(sexpr)) { sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error); if(*error != NULL) { return NULL; } if(e1 == interp.nil_sym) { return interp.nil_sym; } sexpr_t *res = CDR(e1); if(res == NULL) { return interp.nil_sym; } return res; } // + if(interp.plus_sym == CAR(sexpr)) { sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error); if(*error != NULL) { return NULL; } roots = cons_to_roots_list(roots, e1); sexpr_t* e2 = eval(CAR(CDR(CDR(sexpr))), env, roots, error); if(*error != NULL) { return NULL; } if(INT(e1) && INT(e2)) { return mk_int(INT_VAL(e1) + INT_VAL(e2)); } *error = mk_error("Arguments for '+' are not integers", ""); return NULL; } // - if(interp.minus_sym == CAR(sexpr)) { sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error); if(*error != NULL) { return NULL; } roots = cons_to_roots_list(roots, e1); sexpr_t* e2 = eval(CAR(CDR(CDR(sexpr))), env, roots, error); if(*error != NULL) { return NULL; } if(INT(e1) && INT(e2)) { return mk_int(INT_VAL(e1) - INT_VAL(e2)); } *error = mk_error("Arguments for '-' are not integers", ""); return NULL; } if(interp.mul_sym == CAR(sexpr)) { sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error); if(*error != NULL) { return NULL; } roots = cons_to_roots_list(roots, sexpr); sexpr_t* e2 = eval(CAR(CDR(CDR(sexpr))), env, roots, error); if(*error != NULL) { return NULL; } if(INT(e1) && INT(e2)) { return mk_int(INT_VAL(e1) * INT_VAL(e2)); } *error = mk_error("Arguments for '*' are not integers", ""); return NULL; } // cons if(interp.cons_sym == CAR(sexpr)) { sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error); if(*error != NULL) { return NULL; } roots = cons_to_roots_list(roots, e1); sexpr_t* e2 = eval(CAR(CDR(CDR(sexpr))), env, roots, error); if(*error != NULL) { return NULL; } return mk_cons(e1 == interp.nil_sym ? NULL : e1, e2 == interp.nil_sym ? NULL : e2); } // def if(interp.def_sym == CAR(sexpr)) { sexpr_t* arg = CAR(CDR(CDR(sexpr))); roots = cons_to_roots_list(roots, arg); sexpr_t* val = eval(arg, env, roots, error); if(*error != NULL) { return NULL; } *env = mk_cons(mk_cons(intern(SYM_VAL(CAR(CDR(sexpr)))), val), *env); return val; } // print if(interp.print_sym == CAR(sexpr)) { sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error); if(*error != NULL) { return NULL; } print_sexpr(e1); printf("\n"); return e1; } // fn if(interp.fn_sym == CAR(sexpr)) { return mk_fn(sexpr, *env); } // macro if(interp.macro_sym == CAR(sexpr)) { return mk_macro(sexpr); } //eval if(interp.eval_sym == CAR(sexpr)) { sexpr_t* e1 = eval(CAR(CDR(sexpr)), env, roots, error); if(*error != NULL) { return NULL; } roots = cons_to_roots_list(roots, e1); return eval(e1, env, roots, error); } // else resolves first variable sexpr_t* fn = eval(CAR(sexpr), env, roots, error); if(*error != NULL) { return NULL; } // eval fn if(FN(fn)) { sexpr_t* fn_code = CAR(CDR(CDR(CAR(fn)))); sexpr_t* captured_env = CDR(fn); sexpr_t* arguments = eval_list(CDR(sexpr), env, roots, error); if(*error != NULL) { return NULL; } sexpr_t* pairs = pair(CAR(CDR(CAR(fn))), arguments); sexpr_t* eval_env = append(pairs, captured_env); // append the function itself to the env, roots, for recursive calls eval_env = mk_cons(mk_cons(CAR(sexpr), fn), eval_env); /* printf("fn code=\n"); */ /* print_sexpr(fn_code); */ /* printf("\n"); */ roots = cons_to_roots_list(roots, eval_env); return eval(fn_code, &eval_env, roots, error); } // eval macro if(MACRO(fn)) { sexpr_t* macro_code = CAR(CDR(CDR(CAR(fn)))); sexpr_t* pairs = pair(CAR(CDR(CAR(fn))), CDR(sexpr)); sexpr_t* eval_env = append(pairs, *env); roots = cons_to_roots_list(roots, eval_env); sexpr_t* transformed_code = eval(macro_code, &eval_env, roots, error); if(*error != NULL) { return NULL; } return eval(transformed_code, env, roots, error); } // else primitives sexpr_t* arguments = eval_list(CDR(sexpr), env, roots, error); if(*error != NULL) { return NULL; } sexpr_t* to_eval = mk_cons(fn, arguments); return eval(to_eval, env, roots, error); } } else if(CAR(CAR(sexpr)) == interp.fn_sym) { // executes an anonymous function sexpr_t* fn = CAR(sexpr); sexpr_t* fn_code = CAR(CDR(CDR(fn))); sexpr_t* arguments = eval_list(CDR(sexpr), env, roots, error); if(*error != NULL) { return NULL; } sexpr_t* l = pair(CAR(CDR(fn)), arguments); l = append(l, *env); roots = cons_to_roots_list(roots, l); return eval(fn_code, &l, roots, error); } print_sexpr(sexpr); printf("\n"); *error = mk_error("Invalid expression", ""); return NULL; }
expv compile_intrinsic_call(ID id, expv args) { intrinsic_entry *ep = NULL; int found = 0; int nArgs = 0; int nIntrArgs = 0; int i; expv ret = NULL; expv a = NULL; TYPE_DESC tp = NULL, ftp; list lp; INTR_OPS iOps = INTR_END; const char *iName = NULL; expv kindV = NULL; int typeNotMatch = 0; int isVarArgs = 0; EXT_ID extid; if (SYM_TYPE(ID_SYM(id)) != S_INTR) { //fatal("%s: not intrinsic symbol", __func__); // declarea as intrinsic but not defined in the intrinc table SYM_TYPE(ID_SYM(id)) = S_INTR; if (args == NULL) { args = list0(LIST); } if (ID_TYPE(id) == NULL) implicit_declaration(id); tp = ID_TYPE(id); //tp = BASIC_TYPE_DESC(TYPE_SUBR); expv symV = expv_sym_term(F_FUNC, NULL, ID_SYM(id)); ftp = function_type(tp); TYPE_SET_INTRINSIC(ftp); extid = new_external_id_for_external_decl(ID_SYM(id), ftp); ID_TYPE(id) = ftp; PROC_EXT_ID(id) = extid; if (TYPE_IS_EXTERNAL(tp)){ ID_STORAGE(id) = STG_EXT; } else{ EXT_PROC_CLASS(extid) = EP_INTRINSIC; } ret = expv_cons(FUNCTION_CALL, tp, symV, args); return ret; } ep = &(intrinsic_table[SYM_VAL(ID_SYM(id))]); iOps = INTR_OP(ep); iName = ID_NAME(id); /* Count a number of argument, first. */ nArgs = 0; if (args == NULL) { args = list0(LIST); } FOR_ITEMS_IN_LIST(lp, args) { nArgs++; } /* Search an intrinsic by checking argument types. */ found = 0; for (; ((INTR_OP(ep) == iOps) && ((strcasecmp(iName, INTR_NAME(ep)) == 0) || !(isValidString(INTR_NAME(ep))))); ep++) { kindV = NULL; typeNotMatch = 0; isVarArgs = 0; /* Check a number of arguments. */ if (INTR_N_ARGS(ep) < 0 || INTR_N_ARGS(ep) == nArgs) { /* varriable args or no kind arg. */ if (INTR_N_ARGS(ep) < 0) { isVarArgs = 1; } nIntrArgs = nArgs; } else if (INTR_HAS_KIND_ARG(ep) && ((INTR_N_ARGS(ep) + 1) == nArgs)) { /* could be intrinsic call with kind arg. */ expv lastV = expr_list_get_n(args, nArgs - 1); if (lastV == NULL) { return NULL; /* error recovery */ } if (EXPV_KW_IS_KIND(lastV)) { goto gotKind; } tp = EXPV_TYPE(lastV); if (!(isValidType(tp))) { return NULL; /* error recovery */ } if (TYPE_BASIC_TYPE(tp) != TYPE_INT) { /* kind arg must be integer type. */ continue; } gotKind: nIntrArgs = INTR_N_ARGS(ep); kindV = lastV; } else { continue; } /* The number of arguments matchs. Then check types. */ for (i = 0; i < nIntrArgs; i++) { a = expr_list_get_n(args, i); if (a == NULL) { return NULL; /* error recovery */ } tp = EXPV_TYPE(a); if (!(isValidType(tp))) { //return NULL; /* error recovery */ continue; } if (compare_intrinsic_arg_type(a, tp, ((isVarArgs == 0) ? INTR_ARG_TYPE(ep)[i] : INTR_ARG_TYPE(ep)[0])) != 0) { /* Type mismatch. */ typeNotMatch = 1; break; } } if (typeNotMatch == 1) { continue; } else { found = 1; break; } } if (found == 1) { /* Yes we found an intrinsic to use. */ SYMBOL sp = NULL; expv symV = NULL; /* Then we have to determine return type. */ if (INTR_RETURN_TYPE(ep) != INTR_TYPE_NONE) { tp = get_intrinsic_return_type(ep, args, kindV); if (!(isValidType(tp))) { //fatal("%s: can't determine return type.", __func__); //return NULL; tp = BASIC_TYPE_DESC(TYPE_GNUMERIC_ALL); } } else { tp = BASIC_TYPE_DESC(TYPE_SUBR); } /* Finally find symbol for the intrinsic and make it expv. */ sp = find_symbol((char *)iName); if (sp == NULL) { fatal("%s: symbol '%s' is not created??", __func__, INTR_NAME(ep)); /* not reached */ return NULL; } symV = expv_sym_term(F_FUNC, NULL, sp); if (symV == NULL) { fatal("%s: symbol expv creation failure.", __func__); /* not reached */ return NULL; } ftp = function_type(tp); TYPE_SET_INTRINSIC(ftp); /* set external id for functionType's type ID. * dont call declare_external_id() */ extid = new_external_id_for_external_decl(ID_SYM(id), ftp); ID_TYPE(id) = ftp; PROC_EXT_ID(id) = extid; if(TYPE_IS_EXTERNAL(tp)){ ID_STORAGE(id) = STG_EXT; }else{ EXT_PROC_CLASS(extid) = EP_INTRINSIC; } ret = expv_cons(FUNCTION_CALL, tp, symV, args); } if (ret == NULL) { error_at_node((expr)args, "argument(s) mismatch for an intrinsic '%s()'.", iName); } return ret; }