item setup_environment(){ item initial_env = extend_environment(primitive_procedure_names(), primitive_procedure_objects(), the_empty_environment()); item t, f; t.type = f.type = t_number; t.content.number = 1; f.content.number = 0; define_variable(make_item("true"), t, initial_env); define_variable(make_item("false"), f, initial_env); return initial_env; }
static object *eval_definition(object *exp, object *env) { define_variable(definition_variable(exp), bs_eval(definition_value(exp), env), env); return lookup_symbol("ok"); }
void set_default_suffixes (void) { suffix_file = enter_file (".SUFFIXES"); if (no_builtin_rules_flag) (void) define_variable ("SUFFIXES", 8, "", o_default, 0); else { char *p = default_suffixes; suffix_file->deps = (struct dep *) multi_glob (parse_file_seq (&p, '\0', sizeof (struct dep), 1), sizeof (struct dep)); (void) define_variable ("SUFFIXES", 8, default_suffixes, o_default, 0); } }
int for_input::get() { if (p == 0) return EOF; for (;;) { if (*p != '\0') return (unsigned char)*p++; if (!done_newline) { done_newline = 1; return '\n'; } double val; if (!lookup_variable(var, &val)) { lex_error("body of `for' terminated enclosing block"); return EOF; } if (by_is_multiplicative) val *= by; else val += by; define_variable(var, val); if ((from <= to && val > to) || (from >= to && val < to)) { p = 0; return EOF; } p = body; done_newline = 0; } }
void do_for(char *var, double from, double to, int by_is_multiplicative, double by, char *body) { define_variable(var, from); if ((by_is_multiplicative && by <= 0) || (by > 0 && from > to) || (by < 0 && from < to)) return; input_stack::push(new for_input(var, from, to, by_is_multiplicative, by, body)); }
void define_default_variables (void) { register char **s; if (no_builtin_variables_flag) return; for (s = default_variables; *s != 0; s += 2) (void) define_variable (s[0], strlen (s[0]), s[1], o_default, 1); }
object_t init_global() { object_t env = NIL; object_t primitives[] = { obj_new_symbol("+"), obj_new_primitive(&primitive_add), obj_new_symbol("*"), obj_new_primitive(&primitive_multiply), obj_new_symbol("-"), obj_new_primitive(&primitive_subtract), obj_new_symbol("/"), obj_new_primitive(&primitive_divide), obj_new_symbol("<"), obj_new_primitive(&primitive_lessthan), obj_new_symbol(">"), obj_new_primitive(&primitive_greaterthan), obj_new_symbol("="), obj_new_primitive(&primitive_equals), obj_new_symbol("cons"), obj_new_primitive(&primitive_cons), obj_new_symbol("car"), obj_new_primitive(&primitive_car), obj_new_symbol("cdr"), obj_new_primitive(&primitive_cdr), obj_new_symbol("null?"), obj_new_primitive(&primitive_isnull), obj_new_symbol("eq?"), obj_new_primitive(&primitive_eq), obj_new_symbol("set-cdr!"), obj_new_primitive(&primitive_set_cdr), obj_new_symbol("set-car!"), obj_new_primitive(&primitive_set_car), obj_new_symbol("symbol?"), obj_new_primitive(&primitive_symbolp), obj_new_symbol("cons?"), obj_new_primitive(&primitive_consp), obj_new_symbol("load"), obj_new_primitive(&primitive_load), obj_new_symbol("print"), obj_new_primitive(&primitive_print), obj_new_symbol("eval"), obj_new_primitive(&primitive_eval), obj_new_symbol("apply"), obj_new_primitive(&primitive_apply), obj_new_symbol("read"), obj_new_primitive(&primitive_read), obj_new_symbol("read-file"), obj_new_primitive(&primitive_read_file), obj_new_symbol("quit"), obj_new_primitive(&primitive_quit), obj_new_symbol("error"), obj_new_primitive(&primitive_error), obj_new_symbol("string?"), obj_new_primitive(&primitive_stringp), obj_new_symbol("number?"), obj_new_primitive(&primitive_numberp), obj_new_symbol("file-append"), obj_new_primitive(&primitive_file_append), obj_new_symbol("symbol->string"), obj_new_primitive(&primitive_symbol2string), obj_new_symbol("string->symbol"), obj_new_primitive(&primitive_string2symbol), obj_new_symbol("string-append"), obj_new_primitive(&primitive_string_append), obj_new_symbol("number->string"), obj_new_primitive(&primitive_number2string), obj_new_symbol("read-char"), obj_new_primitive(&primitive_read_char), obj_new_symbol("string-length"), obj_new_primitive(&primitive_string_length), obj_new_symbol("string="), obj_new_primitive(&primitive_string_equals), obj_new_symbol("string-ref"), obj_new_primitive(&primitive_string_ref) }; int i; for(i = 0; i < 70; i+=2) env = define_variable(primitives[i], primitives[i+1], env); return env; }
int main (int argc, String* argv) { memory_current_free_address = MEMORY_CURRENT_FREE_ADDRESS; create_primitive_function(PRIM_primitive_function_explainer); create_primitive_function(PRIM_function_explainer); create_primitive_function(PRIM_variable_explainer); define_primitive_function("end", PRIM_end); define_primitive_function("bye", PRIM_bye); define_primitive_function("dup", PRIM_dup); define_primitive_function("mul", PRIM_mul); define_primitive_function("simple-wirte", PRIM_simple_wirte); define_variable("little-test-number", 4); String PRIM_square[] = { "dup", "mul", "end" }; define_function("square", 3, PRIM_square); String PRIM_little_test[] = { "little-test-number", "square", "simple-wirte", "bye" }; define_function("little-test", 4, PRIM_little_test); String PRIM_first_function[] = { "little-test", "end" }; define_function("first-function", 2, PRIM_first_function); return_stack_push (in_host_tag_record_get("first-function") + cell); interpreter(); return 0; }
pSlip slip_init(void) { pSlip s; pSlipEnvironment env; s = calloc(1, sizeof(uSlip)); assert(s != NULL); s->lstObjects = NewDList(NULL); s->lstSymbols = NewDList(NULL); s->lstStrings = NewDList(NULL); s->lstGlobalEnvironment = NewDList(FreeEnvironment); env = setup_environment(s, NULL, s->singleton_EmptyList, s->singleton_EmptyList); s->singleton_False = s_NewBool(s, S_FALSE); s->singleton_True = s_NewBool(s, S_TRUE); s->singleton_EmptyList = s_NewObject(s); s->singleton_EmptyList->type = eType_EMPTY_LIST; s->singleton_QuoteSymbol = s_NewSymbol(s, "quote"); s->singleton_DefineSymbol = s_NewSymbol(s, "define"); s->singleton_OKSymbol = s_NewSymbol(s, "ok"); s->singleton_SetSymbol = s_NewSymbol(s, "set!"); s->singleton_IFSymbol = s_NewSymbol(s, "if"); s->singleton_Nil = s_NewSymbol(s, "nil"); define_variable(s, s->singleton_Nil, s_NewObject(s), env); s->singleton_Lambda = s_NewSymbol(s, "lambda"); s->singleton_Begin = s_NewSymbol(s, "begin"); s->singleton_Cond = s_NewSymbol(s, "cond"); s->singleton_Else = s_NewSymbol(s, "else"); s->singleton_Let = s_NewSymbol(s, "let"); s->obj_id = USER_OBJECT_ID_START; s->running = SLIP_RUNNING; s->parse_data.lstTokens = NewDList(FreeToken); slip_install_primitives(s, env); return s; }
int main(int argc, char *argv[] ){ parse_args(argv, argc); logd("Running from %s\n", exec_path); if(run_test){ log("Running tests...\n"); lisp_current_compiler = lisp_make_compiler(); set_compile_out(lisp_current_compiler, c_compile_out); TEST(test_intern_expr); TEST(test_symbols); //TEST(test_lisp_parser); TEST(test_type_pool); //TEST(test_lisp2c); return 0; } if(file_to_run != NULL){ char * filename = argv[1]; if(access(filename, F_OK) == -1){ loge("Error: File '%s' does not exist\n", filename); return 1; } lisp_current_compiler = lisp_make_compiler(); set_compile_out(lisp_current_compiler, c_compile_out); lisp_load_base(exec_path); define_variable(get_symbol("break-on-errors"),str2type("bool"),&break_on_errors, true); compile_status status = lisp_run_script_file(argv[1]); if(status == COMPILE_ERROR){ return -1; } return 0; } log("Unable to handle arguments: "); for(int i = 1; i < argc; i++){ log("%s ", argv[i]); } log("\n"); logd("Add the name of an existing file like this: './foton growth.lisp'\n"); return 0; }
static pSlipEnvironment setup_environment(pSlip gd, pSlipEnvironment parent, pSlipObject params, pSlipObject args) { pSlipEnvironment env; env = NewEnvironment(); dlist_ins(gd->lstGlobalEnvironment, env); env->parent = parent; // propagate args+params across time and space! while (args != gd->singleton_EmptyList && params != gd->singleton_EmptyList) { define_variable(gd, car(params), car(args), env); args = cdr(args); params = cdr(params); } return env; }
environment* extend_environment(object* vars, object* vals, environment* enclosing_environment) { environment* env = make_environment(enclosing_environment); object* var, *val; while (!is_empty_list(vars)) { if(is_empty_list(vals)){ fprintf(stderr, "too much arguments\n"); exit(1); } var = car(vars); val = car(vals); define_variable(var, val, env); vars = cdr(vars); vals = cdr(vals); } return env; }
__bool CRegRequirementList::Alloc(struct blk_var_t * v) { var_item item; if(m_vlist.find(v->uuid) != m_vlist.end()){ m_errcode = F8_NAME_DUPLICATE; return __false; } m_errcode = define_variable(v, &v); if(F8_FAILED(m_errcode)){ return __false; } item.blk_id = v->blk->uuid; item.var = v; item.ref_count = 0; m_vlist[v->uuid] = item; return __true; }
pSlipObject eval_definition(pSlip gd, pSlipObject exp, pSlipEnvironment env) { pSlipObject a2; pSlipObject x1; pSlipObject x2; x1 = definition_value(gd, exp, env); assert(x1 != NULL); a2 = slip_eval(gd, x1, env); assert(a2 != NULL); x2 = definition_variable(exp); assert(x2 != NULL); define_variable(gd, x2, a2, env); if (gd->running == SLIP_RUNNING) return gd->singleton_OKSymbol; else return gd->singleton_False; }
void slip_add_procedure(pSlip gd, pSlipEnvironment env, char *sym, pSlipObject (*func)(pSlip gd, pSlipObject args)) { define_variable(gd, s_NewSymbol(gd, sym), make_primitive_proc(gd, func), env); }
void Interpret (int pop_return_p) { long dispatch_code; struct interpreter_state_s new_state; /* Primitives jump back here for errors, requests to evaluate an expression, apply a function, or handle an interrupt request. On errors or interrupts they leave their arguments on the stack, the primitive itself in GET_EXP. The code should do a primitive backout in these cases, but not in others (apply, eval, etc.), since the primitive itself will have left the state of the interpreter ready for operation. */ bind_interpreter_state (&new_state); dispatch_code = (setjmp (interpreter_catch_env)); preserve_signal_mask (); fixup_float_environment (); switch (dispatch_code) { case 0: /* first time */ if (pop_return_p) goto pop_return; /* continue */ else break; /* fall into eval */ case PRIM_APPLY: PROCEED_AFTER_PRIMITIVE (); goto internal_apply; case PRIM_NO_TRAP_APPLY: PROCEED_AFTER_PRIMITIVE (); goto Apply_Non_Trapping; case PRIM_APPLY_INTERRUPT: PROCEED_AFTER_PRIMITIVE (); PREPARE_APPLY_INTERRUPT (); SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); case PRIM_APPLY_ERROR: PROCEED_AFTER_PRIMITIVE (); APPLICATION_ERROR (prim_apply_error_code); case PRIM_DO_EXPRESSION: SET_VAL (GET_EXP); PROCEED_AFTER_PRIMITIVE (); REDUCES_TO (GET_VAL); case PRIM_NO_TRAP_EVAL: SET_VAL (GET_EXP); PROCEED_AFTER_PRIMITIVE (); NEW_REDUCTION (GET_VAL, GET_ENV); goto eval_non_trapping; case PRIM_POP_RETURN: PROCEED_AFTER_PRIMITIVE (); goto pop_return; case PRIM_RETURN_TO_C: PROCEED_AFTER_PRIMITIVE (); unbind_interpreter_state (interpreter_state); return; case PRIM_NO_TRAP_POP_RETURN: PROCEED_AFTER_PRIMITIVE (); goto pop_return_non_trapping; case PRIM_INTERRUPT: back_out_of_primitive (); SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); case PRIM_ABORT_TO_C: back_out_of_primitive (); unbind_interpreter_state (interpreter_state); return; case ERR_ARG_1_WRONG_TYPE: back_out_of_primitive (); Do_Micro_Error (ERR_ARG_1_WRONG_TYPE, true); goto internal_apply; case ERR_ARG_2_WRONG_TYPE: back_out_of_primitive (); Do_Micro_Error (ERR_ARG_2_WRONG_TYPE, true); goto internal_apply; case ERR_ARG_3_WRONG_TYPE: back_out_of_primitive (); Do_Micro_Error (ERR_ARG_3_WRONG_TYPE, true); goto internal_apply; default: back_out_of_primitive (); Do_Micro_Error (dispatch_code, true); goto internal_apply; } do_expression: /* GET_EXP has an Scode item in it that should be evaluated and the result left in GET_VAL. A "break" after the code for any operation indicates that all processing for this operation has been completed, and the next step will be to pop a return code off the stack and proceed at pop_return. This is sometimes called "executing the continuation" since the return code can be considered the continuation to be performed after the operation. An operation can terminate with a REDUCES_TO or REDUCES_TO_NTH macro. This indicates that the value of the current Scode item is the value returned when the new expression is evaluated. Therefore no new continuation is created and processing continues at do_expression with the new expression in GET_EXP. Finally, an operation can terminate with a DO_NTH_THEN macro. This indicates that another expression must be evaluated and them some additional processing will be performed before the value of this S-Code item available. Thus a new continuation is created and placed on the stack (using SAVE_CONT), the new expression is placed in the GET_EXP, and processing continues at do_expression. */ /* Handling of Eval Trapping. If we are handling traps and there is an Eval Trap set, turn off all trapping and then go to internal_apply to call the user supplied eval hook with the expression to be evaluated and the environment. */ #ifdef COMPILE_STEPPER if (trapping && (!WITHIN_CRITICAL_SECTION_P ()) && ((FETCH_EVAL_TRAPPER ()) != SHARP_F)) { trapping = false; Will_Push (4); PUSH_ENV (); PUSH_EXP (); STACK_PUSH (FETCH_EVAL_TRAPPER ()); PUSH_APPLY_FRAME_HEADER (2); Pushed (); goto Apply_Non_Trapping; } #endif /* COMPILE_STEPPER */ eval_non_trapping: #ifdef EVAL_UCODE_HOOK EVAL_UCODE_HOOK (); #endif switch (OBJECT_TYPE (GET_EXP)) { case TC_BIG_FIXNUM: /* The self evaluating items */ case TC_BIG_FLONUM: case TC_CHARACTER_STRING: case TC_CHARACTER: case TC_COMPILED_CODE_BLOCK: case TC_COMPLEX: case TC_CONTROL_POINT: case TC_DELAYED: case TC_ENTITY: case TC_ENVIRONMENT: case TC_EXTENDED_PROCEDURE: case TC_FIXNUM: case TC_HUNK3_A: case TC_HUNK3_B: case TC_INTERNED_SYMBOL: case TC_LIST: case TC_NON_MARKED_VECTOR: case TC_NULL: case TC_PRIMITIVE: case TC_PROCEDURE: case TC_QUAD: case TC_RATNUM: case TC_REFERENCE_TRAP: case TC_RETURN_CODE: case TC_UNINTERNED_SYMBOL: case TC_CONSTANT: case TC_VECTOR: case TC_VECTOR_16B: case TC_VECTOR_1B: default: SET_VAL (GET_EXP); break; case TC_ACCESS: Will_Push (CONTINUATION_SIZE); PUSH_NTH_THEN (RC_EXECUTE_ACCESS_FINISH, ACCESS_ENVIRONMENT); case TC_ASSIGNMENT: Will_Push (CONTINUATION_SIZE + 1); PUSH_ENV (); PUSH_NTH_THEN (RC_EXECUTE_ASSIGNMENT_FINISH, ASSIGN_VALUE); case TC_BROKEN_HEART: Microcode_Termination (TERM_BROKEN_HEART); case TC_COMBINATION: { long length = ((VECTOR_LENGTH (GET_EXP)) - 1); Will_Push (length + 2 + CONTINUATION_SIZE); stack_pointer = (STACK_LOC (-length)); STACK_PUSH (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, length)); /* The finger: last argument number */ Pushed (); if (length == 0) { PUSH_APPLY_FRAME_HEADER (0); /* Frame size */ DO_NTH_THEN (RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT); } PUSH_ENV (); DO_NTH_THEN (RC_COMB_SAVE_VALUE, (length + 1)); } case TC_COMBINATION_1: Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1); PUSH_ENV (); DO_NTH_THEN (RC_COMB_1_PROCEDURE, COMB_1_ARG_1); case TC_COMBINATION_2: Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2); PUSH_ENV (); DO_NTH_THEN (RC_COMB_2_FIRST_OPERAND, COMB_2_ARG_2); case TC_COMMENT: REDUCES_TO_NTH (COMMENT_EXPRESSION); case TC_CONDITIONAL: Will_Push (CONTINUATION_SIZE + 1); PUSH_ENV (); PUSH_NTH_THEN (RC_CONDITIONAL_DECIDE, COND_PREDICATE); #ifdef CC_SUPPORT_P case TC_COMPILED_ENTRY: dispatch_code = (enter_compiled_expression ()); goto return_from_compiled_code; #endif case TC_DEFINITION: Will_Push (CONTINUATION_SIZE + 1); PUSH_ENV (); PUSH_NTH_THEN (RC_EXECUTE_DEFINITION_FINISH, DEFINE_VALUE); case TC_DELAY: /* Deliberately omitted: EVAL_GC_CHECK (2); */ SET_VAL (MAKE_POINTER_OBJECT (TC_DELAYED, Free)); (Free[THUNK_ENVIRONMENT]) = GET_ENV; (Free[THUNK_PROCEDURE]) = (MEMORY_REF (GET_EXP, DELAY_OBJECT)); Free += 2; break; case TC_DISJUNCTION: Will_Push (CONTINUATION_SIZE + 1); PUSH_ENV (); PUSH_NTH_THEN (RC_DISJUNCTION_DECIDE, OR_PREDICATE); case TC_EXTENDED_LAMBDA: /* Deliberately omitted: EVAL_GC_CHECK (2); */ SET_VAL (MAKE_POINTER_OBJECT (TC_EXTENDED_PROCEDURE, Free)); (Free[PROCEDURE_LAMBDA_EXPR]) = GET_EXP; (Free[PROCEDURE_ENVIRONMENT]) = GET_ENV; Free += 2; break; case TC_IN_PACKAGE: Will_Push (CONTINUATION_SIZE); PUSH_NTH_THEN (RC_EXECUTE_IN_PACKAGE_CONTINUE, IN_PACKAGE_ENVIRONMENT); case TC_LAMBDA: case TC_LEXPR: /* Deliberately omitted: EVAL_GC_CHECK (2); */ SET_VAL (MAKE_POINTER_OBJECT (TC_PROCEDURE, Free)); (Free[PROCEDURE_LAMBDA_EXPR]) = GET_EXP; (Free[PROCEDURE_ENVIRONMENT]) = GET_ENV; Free += 2; break; case TC_MANIFEST_NM_VECTOR: EVAL_ERROR (ERR_EXECUTE_MANIFEST_VECTOR); case TC_PCOMB0: /* The argument to Will_Eventually_Push is determined by how much will be on the stack if we back out of the primitive. */ Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); SET_EXP (OBJECT_NEW_TYPE (TC_PRIMITIVE, GET_EXP)); goto primitive_internal_apply; case TC_PCOMB1: Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 1); DO_NTH_THEN (RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT); case TC_PCOMB2: Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 2); PUSH_ENV (); DO_NTH_THEN (RC_PCOMB2_DO_1, PCOMB2_ARG_2_SLOT); case TC_PCOMB3: Will_Eventually_Push (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG + 3); PUSH_ENV (); DO_NTH_THEN (RC_PCOMB3_DO_2, PCOMB3_ARG_3_SLOT); case TC_SCODE_QUOTE: SET_VAL (MEMORY_REF (GET_EXP, SCODE_QUOTE_OBJECT)); break; case TC_SEQUENCE_2: Will_Push (CONTINUATION_SIZE + 1); PUSH_ENV (); PUSH_NTH_THEN (RC_SEQ_2_DO_2, SEQUENCE_1); case TC_SEQUENCE_3: Will_Push (CONTINUATION_SIZE + 1); PUSH_ENV (); PUSH_NTH_THEN (RC_SEQ_3_DO_2, SEQUENCE_1); case TC_SYNTAX_ERROR: EVAL_ERROR (ERR_SYNTAX_ERROR); case TC_THE_ENVIRONMENT: SET_VAL (GET_ENV); break; case TC_VARIABLE: { SCHEME_OBJECT val = GET_VAL; SCHEME_OBJECT name = (GET_VARIABLE_SYMBOL (GET_EXP)); long temp = (lookup_variable (GET_ENV, name, (&val))); if (temp != PRIM_DONE) { /* Back out of the evaluation. */ if (temp == PRIM_INTERRUPT) { PREPARE_EVAL_REPEAT (); SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); } EVAL_ERROR (temp); } SET_VAL (val); } } /* Now restore the continuation saved during an earlier part of the EVAL cycle and continue as directed. */ pop_return: #ifdef COMPILE_STEPPER if (trapping && (!WITHIN_CRITICAL_SECTION_P ()) && ((FETCH_RETURN_TRAPPER ()) != SHARP_F)) { Will_Push (3); trapping = false; PUSH_VAL (); STACK_PUSH (FETCH_RETURN_TRAPPER ()); PUSH_APPLY_FRAME_HEADER (1); Pushed (); goto Apply_Non_Trapping; } #endif /* COMPILE_STEPPER */ pop_return_non_trapping: #ifdef POP_RETURN_UCODE_HOOK POP_RETURN_UCODE_HOOK (); #endif RESTORE_CONT (); #ifdef ENABLE_DEBUGGING_TOOLS if (!RETURN_CODE_P (GET_RET)) { PUSH_VAL (); /* For possible stack trace */ SAVE_CONT (); Microcode_Termination (TERM_BAD_STACK); } #endif /* Dispatch on the return code. A BREAK here will cause a "goto pop_return" to occur, since this is the most common occurrence. */ switch (OBJECT_DATUM (GET_RET)) { case RC_COMB_1_PROCEDURE: POP_ENV (); PUSH_VAL (); /* Arg. 1 */ STACK_PUSH (SHARP_F); /* Operator */ PUSH_APPLY_FRAME_HEADER (1); Finished_Eventual_Pushing (CONTINUATION_SIZE); DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_1_FN); case RC_COMB_2_FIRST_OPERAND: POP_ENV (); PUSH_VAL (); PUSH_ENV (); DO_ANOTHER_THEN (RC_COMB_2_PROCEDURE, COMB_2_ARG_1); case RC_COMB_2_PROCEDURE: POP_ENV (); PUSH_VAL (); /* Arg 1, just calculated */ STACK_PUSH (SHARP_F); /* Function */ PUSH_APPLY_FRAME_HEADER (2); Finished_Eventual_Pushing (CONTINUATION_SIZE); DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_2_FN); case RC_COMB_APPLY_FUNCTION: END_SUBPROBLEM (); goto internal_apply_val; case RC_COMB_SAVE_VALUE: { long Arg_Number; POP_ENV (); Arg_Number = ((OBJECT_DATUM (STACK_REF (STACK_COMB_FINGER))) - 1); (STACK_REF (STACK_COMB_FIRST_ARG + Arg_Number)) = GET_VAL; (STACK_REF (STACK_COMB_FINGER)) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Arg_Number)); /* DO NOT count on the type code being NMVector here, since the stack parser may create them with #F here! */ if (Arg_Number > 0) { PUSH_ENV (); DO_ANOTHER_THEN (RC_COMB_SAVE_VALUE, ((COMB_ARG_1_SLOT - 1) + Arg_Number)); } /* Frame Size */ STACK_PUSH (MEMORY_REF (GET_EXP, 0)); DO_ANOTHER_THEN (RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT); } #ifdef CC_SUPPORT_P #define DEFINE_COMPILER_RESTART(return_code, entry) \ case return_code: \ { \ dispatch_code = (entry ()); \ goto return_from_compiled_code; \ } DEFINE_COMPILER_RESTART (RC_COMP_INTERRUPT_RESTART, comp_interrupt_restart); DEFINE_COMPILER_RESTART (RC_COMP_LOOKUP_TRAP_RESTART, comp_lookup_trap_restart); DEFINE_COMPILER_RESTART (RC_COMP_ASSIGNMENT_TRAP_RESTART, comp_assignment_trap_restart); DEFINE_COMPILER_RESTART (RC_COMP_OP_REF_TRAP_RESTART, comp_op_lookup_trap_restart); DEFINE_COMPILER_RESTART (RC_COMP_CACHE_REF_APPLY_RESTART, comp_cache_lookup_apply_restart); DEFINE_COMPILER_RESTART (RC_COMP_SAFE_REF_TRAP_RESTART, comp_safe_lookup_trap_restart); DEFINE_COMPILER_RESTART (RC_COMP_UNASSIGNED_TRAP_RESTART, comp_unassigned_p_trap_restart); DEFINE_COMPILER_RESTART (RC_COMP_LINK_CACHES_RESTART, comp_link_caches_restart); DEFINE_COMPILER_RESTART (RC_COMP_ERROR_RESTART, comp_error_restart); case RC_REENTER_COMPILED_CODE: dispatch_code = (return_to_compiled_code ()); goto return_from_compiled_code; #endif case RC_CONDITIONAL_DECIDE: END_SUBPROBLEM (); POP_ENV (); REDUCES_TO_NTH ((GET_VAL == SHARP_F) ? COND_ALTERNATIVE : COND_CONSEQUENT); case RC_DISJUNCTION_DECIDE: /* Return predicate if it isn't #F; else do ALTERNATIVE */ END_SUBPROBLEM (); POP_ENV (); if (GET_VAL != SHARP_F) goto pop_return; REDUCES_TO_NTH (OR_ALTERNATIVE); case RC_END_OF_COMPUTATION: { /* Signals bottom of stack */ interpreter_state_t previous_state; previous_state = (interpreter_state -> previous_state); if (previous_state == NULL_INTERPRETER_STATE) { termination_end_of_computation (); /*NOTREACHED*/ } else { dstack_position = interpreter_catch_dstack_position; interpreter_state = previous_state; return; } } case RC_EVAL_ERROR: /* Should be called RC_REDO_EVALUATION. */ POP_ENV (); REDUCES_TO (GET_EXP); case RC_EXECUTE_ACCESS_FINISH: { SCHEME_OBJECT val; long code; code = (lookup_variable (GET_VAL, (MEMORY_REF (GET_EXP, ACCESS_NAME)), (&val))); if (code == PRIM_DONE) SET_VAL (val); else if (code == PRIM_INTERRUPT) { PREPARE_POP_RETURN_INTERRUPT (RC_EXECUTE_ACCESS_FINISH, GET_VAL); SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); } else POP_RETURN_ERROR (code); } END_SUBPROBLEM (); break; case RC_EXECUTE_ASSIGNMENT_FINISH: { SCHEME_OBJECT variable = (MEMORY_REF (GET_EXP, ASSIGN_NAME)); SCHEME_OBJECT old_val; long code; POP_ENV (); if (TC_VARIABLE == (OBJECT_TYPE (variable))) code = (assign_variable (GET_ENV, (GET_VARIABLE_SYMBOL (variable)), GET_VAL, (&old_val))); else code = ERR_BAD_FRAME; if (code == PRIM_DONE) SET_VAL (old_val); else { PUSH_ENV (); if (code == PRIM_INTERRUPT) { PREPARE_POP_RETURN_INTERRUPT (RC_EXECUTE_ASSIGNMENT_FINISH, GET_VAL); SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); } else POP_RETURN_ERROR (code); } } END_SUBPROBLEM (); break; case RC_EXECUTE_DEFINITION_FINISH: { SCHEME_OBJECT name = (MEMORY_REF (GET_EXP, DEFINE_NAME)); SCHEME_OBJECT value = GET_VAL; long result; POP_ENV (); result = (define_variable (GET_ENV, name, value)); if (result == PRIM_DONE) { END_SUBPROBLEM (); SET_VAL (name); break; } PUSH_ENV (); if (result == PRIM_INTERRUPT) { PREPARE_POP_RETURN_INTERRUPT (RC_EXECUTE_DEFINITION_FINISH, value); SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); } SET_VAL (value); POP_RETURN_ERROR (result); } case RC_EXECUTE_IN_PACKAGE_CONTINUE: if (ENVIRONMENT_P (GET_VAL)) { END_SUBPROBLEM (); SET_ENV (GET_VAL); REDUCES_TO_NTH (IN_PACKAGE_EXPRESSION); } POP_RETURN_ERROR (ERR_BAD_FRAME); case RC_HALT: Microcode_Termination (TERM_TERM_HANDLER); case RC_HARDWARE_TRAP: { /* This just reinvokes the handler */ SCHEME_OBJECT info = (STACK_REF (0)); SCHEME_OBJECT handler = SHARP_F; SAVE_CONT (); if (VECTOR_P (fixed_objects)) handler = (VECTOR_REF (fixed_objects, TRAP_HANDLER)); if (handler == SHARP_F) { outf_fatal ("There is no trap handler for recovery!\n"); termination_trap (); /*NOTREACHED*/ } Will_Push (STACK_ENV_EXTRA_SLOTS + 2); STACK_PUSH (info); STACK_PUSH (handler); PUSH_APPLY_FRAME_HEADER (1); Pushed (); } goto internal_apply; /* internal_apply, the core of the application mechanism. Branch here to perform a function application. At this point the top of the stack contains an application frame which consists of the following elements (see sdata.h): - A header specifying the frame length. - A procedure. - The actual (evaluated) arguments. No registers (except the stack pointer) are meaning full at this point. Before interrupts or errors are processed, some registers are cleared to avoid holding onto garbage if a garbage collection occurs. */ case RC_INTERNAL_APPLY_VAL: internal_apply_val: (APPLY_FRAME_PROCEDURE ()) = GET_VAL; case RC_INTERNAL_APPLY: internal_apply: #ifdef COMPILE_STEPPER if (trapping && (!WITHIN_CRITICAL_SECTION_P ()) && ((FETCH_APPLY_TRAPPER ()) != SHARP_F)) { unsigned long frame_size = (APPLY_FRAME_SIZE ()); (* (STACK_LOC (0))) = (FETCH_APPLY_TRAPPER ()); PUSH_APPLY_FRAME_HEADER (frame_size); trapping = false; } #endif /* COMPILE_STEPPER */ Apply_Non_Trapping: if (PENDING_INTERRUPTS_P) { unsigned long interrupts = (PENDING_INTERRUPTS ()); PREPARE_APPLY_INTERRUPT (); SIGNAL_INTERRUPT (interrupts); } perform_application: #ifdef APPLY_UCODE_HOOK APPLY_UCODE_HOOK (); #endif { SCHEME_OBJECT Function = (APPLY_FRAME_PROCEDURE ()); apply_dispatch: switch (OBJECT_TYPE (Function)) { case TC_ENTITY: { unsigned long frame_size = (APPLY_FRAME_SIZE ()); SCHEME_OBJECT data = (MEMORY_REF (Function, ENTITY_DATA)); if ((VECTOR_P (data)) && (frame_size < (VECTOR_LENGTH (data))) && ((VECTOR_REF (data, frame_size)) != SHARP_F) && ((VECTOR_REF (data, 0)) == (VECTOR_REF (fixed_objects, ARITY_DISPATCHER_TAG)))) { Function = (VECTOR_REF (data, frame_size)); (APPLY_FRAME_PROCEDURE ()) = Function; goto apply_dispatch; } (STACK_REF (0)) = (MEMORY_REF (Function, ENTITY_OPERATOR)); PUSH_APPLY_FRAME_HEADER (frame_size); /* This must be done to prevent an infinite push loop by an entity whose handler is the entity itself or some other such loop. Of course, it will die if stack overflow interrupts are disabled. */ STACK_CHECK (0); goto internal_apply; } case TC_PROCEDURE: { unsigned long frame_size = (APPLY_FRAME_SIZE ()); Function = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR)); { SCHEME_OBJECT formals = (MEMORY_REF (Function, LAMBDA_FORMALS)); if ((frame_size != (VECTOR_LENGTH (formals))) && (((OBJECT_TYPE (Function)) != TC_LEXPR) || (frame_size < (VECTOR_LENGTH (formals))))) APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS); } if (GC_NEEDED_P (frame_size + 1)) { PREPARE_APPLY_INTERRUPT (); IMMEDIATE_GC (frame_size + 1); } { SCHEME_OBJECT * end = (Free + 1 + frame_size); SCHEME_OBJECT env = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, Free)); (*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, frame_size)); (void) STACK_POP (); while (Free < end) (*Free++) = (STACK_POP ()); SET_ENV (env); REDUCES_TO (MEMORY_REF (Function, LAMBDA_SCODE)); } } case TC_CONTROL_POINT: if ((APPLY_FRAME_SIZE ()) != 2) APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS); SET_VAL (* (APPLY_FRAME_ARGS ())); unpack_control_point (Function); RESET_HISTORY (); goto pop_return; /* After checking the number of arguments, remove the frame header since primitives do not expect it. NOTE: This code must match the application code which follows primitive_internal_apply. */ case TC_PRIMITIVE: if (!IMPLEMENTED_PRIMITIVE_P (Function)) APPLICATION_ERROR (ERR_UNIMPLEMENTED_PRIMITIVE); { unsigned long n_args = (APPLY_FRAME_N_ARGS ()); /* Note that the first test below will fail for lexpr primitives. */ if (n_args != (PRIMITIVE_ARITY (Function))) { if ((PRIMITIVE_ARITY (Function)) != LEXPR_PRIMITIVE_ARITY) APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS); SET_LEXPR_ACTUALS (n_args); } stack_pointer = (APPLY_FRAME_ARGS ()); SET_EXP (Function); APPLY_PRIMITIVE_FROM_INTERPRETER (Function); POP_PRIMITIVE_FRAME (n_args); goto pop_return; } case TC_EXTENDED_PROCEDURE: { SCHEME_OBJECT lambda; SCHEME_OBJECT temp; unsigned long nargs; unsigned long nparams; unsigned long formals; unsigned long params; unsigned long auxes; long rest_flag; long size; long i; SCHEME_OBJECT * scan; nargs = (POP_APPLY_FRAME_HEADER ()); lambda = (MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR)); Function = (MEMORY_REF (lambda, ELAMBDA_NAMES)); nparams = ((VECTOR_LENGTH (Function)) - 1); Function = (Get_Count_Elambda (lambda)); formals = (Elambda_Formals_Count (Function)); params = ((Elambda_Opts_Count (Function)) + formals); rest_flag = (Elambda_Rest_Flag (Function)); auxes = (nparams - (params + rest_flag)); if ((nargs < formals) || (!rest_flag && (nargs > params))) { PUSH_APPLY_FRAME_HEADER (nargs); APPLICATION_ERROR (ERR_WRONG_NUMBER_OF_ARGUMENTS); } /* size includes the procedure slot, but not the header. */ size = (params + rest_flag + auxes + 1); if (GC_NEEDED_P (size + 1 + ((nargs > params) ? (2 * (nargs - params)) : 0))) { PUSH_APPLY_FRAME_HEADER (nargs); PREPARE_APPLY_INTERRUPT (); IMMEDIATE_GC (size + 1 + ((nargs > params) ? (2 * (nargs - params)) : 0)); } scan = Free; temp = (MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan)); (*scan++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, size)); if (nargs <= params) { for (i = (nargs + 1); (--i) >= 0; ) (*scan++) = (STACK_POP ()); for (i = (params - nargs); (--i) >= 0; ) (*scan++) = DEFAULT_OBJECT; if (rest_flag) (*scan++) = EMPTY_LIST; for (i = auxes; (--i) >= 0; ) (*scan++) = UNASSIGNED_OBJECT; } else { /* rest_flag must be true. */ SCHEME_OBJECT list = (MAKE_POINTER_OBJECT (TC_LIST, (scan + size))); for (i = (params + 1); (--i) >= 0; ) (*scan++) = (STACK_POP ()); (*scan++) = list; for (i = auxes; (--i) >= 0; ) (*scan++) = UNASSIGNED_OBJECT; /* Now scan == OBJECT_ADDRESS (list) */ for (i = (nargs - params); (--i) >= 0; ) { (*scan++) = (STACK_POP ()); (*scan) = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1)); scan += 1; } (scan[-1]) = EMPTY_LIST; } Free = scan; SET_ENV (temp); REDUCES_TO (Get_Body_Elambda (lambda)); } #ifdef CC_SUPPORT_P case TC_COMPILED_ENTRY: { guarantee_cc_return (1 + (APPLY_FRAME_SIZE ())); dispatch_code = (apply_compiled_procedure ()); return_from_compiled_code: switch (dispatch_code) { case PRIM_DONE: goto pop_return; case PRIM_APPLY: goto internal_apply; case PRIM_INTERRUPT: SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); case PRIM_APPLY_INTERRUPT: PREPARE_APPLY_INTERRUPT (); SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); case ERR_INAPPLICABLE_OBJECT: case ERR_WRONG_NUMBER_OF_ARGUMENTS: APPLICATION_ERROR (dispatch_code); default: Do_Micro_Error (dispatch_code, true); goto internal_apply; } } #endif default: APPLICATION_ERROR (ERR_INAPPLICABLE_OBJECT); } } case RC_JOIN_STACKLETS: unpack_control_point (GET_EXP); break; case RC_NORMAL_GC_DONE: SET_VAL (GET_EXP); /* Paranoia */ if (GC_NEEDED_P (gc_space_needed)) termination_gc_out_of_space (); gc_space_needed = 0; EXIT_CRITICAL_SECTION ({ SAVE_CONT (); }); break; case RC_PCOMB1_APPLY: END_SUBPROBLEM (); PUSH_VAL (); /* Argument value */ Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); SET_EXP (MEMORY_REF (GET_EXP, PCOMB1_FN_SLOT)); primitive_internal_apply: #ifdef COMPILE_STEPPER if (trapping && (!WITHIN_CRITICAL_SECTION_P ()) && ((FETCH_APPLY_TRAPPER ()) != SHARP_F)) { Will_Push (3); PUSH_EXP (); STACK_PUSH (FETCH_APPLY_TRAPPER ()); PUSH_APPLY_FRAME_HEADER (1 + (PRIMITIVE_N_PARAMETERS (GET_EXP))); Pushed (); trapping = false; goto Apply_Non_Trapping; } #endif /* COMPILE_STEPPER */ /* NOTE: This code must match the code in the TC_PRIMITIVE case of internal_apply. This code is simpler because: 1) The arity was checked at syntax time. 2) We don't have to deal with "lexpr" primitives. 3) We don't need to worry about unimplemented primitives because unimplemented primitives will cause an error at invocation. */ { SCHEME_OBJECT primitive = GET_EXP; APPLY_PRIMITIVE_FROM_INTERPRETER (primitive); POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive)); break; } case RC_PCOMB2_APPLY: END_SUBPROBLEM (); PUSH_VAL (); /* Value of arg. 1 */ Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); SET_EXP (MEMORY_REF (GET_EXP, PCOMB2_FN_SLOT)); goto primitive_internal_apply; case RC_PCOMB2_DO_1: POP_ENV (); PUSH_VAL (); /* Save value of arg. 2 */ DO_ANOTHER_THEN (RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT); case RC_PCOMB3_APPLY: END_SUBPROBLEM (); PUSH_VAL (); /* Save value of arg. 1 */ Finished_Eventual_Pushing (CONTINUATION_SIZE + STACK_ENV_FIRST_ARG); SET_EXP (MEMORY_REF (GET_EXP, PCOMB3_FN_SLOT)); goto primitive_internal_apply; case RC_PCOMB3_DO_1: { SCHEME_OBJECT Temp = (STACK_POP ()); /* Value of arg. 3 */ POP_ENV (); STACK_PUSH (Temp); /* Save arg. 3 again */ PUSH_VAL (); /* Save arg. 2 */ DO_ANOTHER_THEN (RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT); } case RC_PCOMB3_DO_2: SET_ENV (STACK_REF (0)); PUSH_VAL (); /* Save value of arg. 3 */ DO_ANOTHER_THEN (RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT); case RC_POP_RETURN_ERROR: case RC_RESTORE_VALUE: SET_VAL (GET_EXP); break; /* The following two return codes are both used to restore a saved history object. The difference is that the first does not copy the history object while the second does. In both cases, the GET_EXP contains the history object and the next item to be popped off the stack contains the offset back to the previous restore history return code. */ case RC_RESTORE_DONT_COPY_HISTORY: { prev_restore_history_offset = (OBJECT_DATUM (STACK_POP ())); (void) STACK_POP (); history_register = (OBJECT_ADDRESS (GET_EXP)); break; } case RC_RESTORE_HISTORY: { if (!restore_history (GET_EXP)) { SAVE_CONT (); Will_Push (CONTINUATION_SIZE); SET_EXP (GET_VAL); SET_RC (RC_RESTORE_VALUE); SAVE_CONT (); Pushed (); IMMEDIATE_GC (HEAP_AVAILABLE); } prev_restore_history_offset = (OBJECT_DATUM (STACK_POP ())); (void) STACK_POP (); if (prev_restore_history_offset > 0) (STACK_LOCATIVE_REFERENCE (STACK_BOTTOM, (-prev_restore_history_offset))) = (MAKE_RETURN_CODE (RC_RESTORE_HISTORY)); break; } case RC_RESTORE_INT_MASK: SET_INTERRUPT_MASK (UNSIGNED_FIXNUM_TO_LONG (GET_EXP)); if (GC_NEEDED_P (0)) REQUEST_GC (0); if (PENDING_INTERRUPTS_P) { SET_RC (RC_RESTORE_VALUE); SET_EXP (GET_VAL); SAVE_CONT (); SIGNAL_INTERRUPT (PENDING_INTERRUPTS ()); } break; case RC_STACK_MARKER: /* Frame consists of the return code followed by two objects. The first object has already been popped into GET_EXP, so just pop the second argument. */ stack_pointer = (STACK_LOCATIVE_OFFSET (stack_pointer, 1)); break; case RC_SEQ_2_DO_2: END_SUBPROBLEM (); POP_ENV (); REDUCES_TO_NTH (SEQUENCE_2); case RC_SEQ_3_DO_2: SET_ENV (STACK_REF (0)); DO_ANOTHER_THEN (RC_SEQ_3_DO_3, SEQUENCE_2); case RC_SEQ_3_DO_3: END_SUBPROBLEM (); POP_ENV (); REDUCES_TO_NTH (SEQUENCE_3); case RC_SNAP_NEED_THUNK: /* Don't snap thunk twice; evaluation of the thunk's body might have snapped it already. */ if ((MEMORY_REF (GET_EXP, THUNK_SNAPPED)) == SHARP_T) SET_VAL (MEMORY_REF (GET_EXP, THUNK_VALUE)); else { MEMORY_SET (GET_EXP, THUNK_SNAPPED, SHARP_T); MEMORY_SET (GET_EXP, THUNK_VALUE, GET_VAL); } break; default: POP_RETURN_ERROR (ERR_INAPPLICABLE_CONTINUATION); }
void mobprog (CHAR_DATA * ch, CHAR_DATA * mob, MOBPROG_DATA * program, int trigger, char *argument, int *ret) { char line[MAX_STRING_LENGTH]; char command[MAX_STRING_LENGTH]; char *line_ptr; char *prog_ptr; char *prog; char token[MAX_STRING_LENGTH]; int levels[MAX_PROG_LINES]; char *level_ptrs[MAX_PROG_LINES]; int level_ifs[MAX_DEPTH]; int lines; int level; int cur_level; int line_no; int i; *ret = 0; // temporary lockout if (1 || !engine.in_test_mode ()) { return; } if (ch->desc) { return; } // don't want progs active on bp if (engine.in_build_mode ()) return; prog = program->prog; for (lines = 0; lines < MAX_PROG_LINES; lines++) { levels[lines] = 0; level_ptrs[lines] = NULL; } setvar (mob, "mob", (long int) mob, MP_TYPE_CHAR_DATA); setvar (mob, "ch", (long int) ch, MP_TYPE_CHAR_DATA); setvar (mob, "room", (long int) vtor (mob->in_room), MP_TYPE_ROOM_DATA); prog_ptr = prog; level = 0; lines = 0; while ((level_ptrs[lines] = get_line (&prog_ptr, line))) { line_ptr = line; get_prog_token (&line_ptr, token); if (!str_cmp (token, "if") || !str_cmp (token, "while")) levels[lines] = level++; else if (!str_cmp (token, "elseif") || !str_cmp (token, "else")) levels[lines] = level - 1; else if (!str_cmp (token, "endif") || !str_cmp (token, "endwhile")) levels[lines] = --level; else levels[lines] = level; lines++; } line_no = 0; /* Re-entry for a delayed trigger */ if (ch->trigger_id == trigger) { /* Reset delayed trigger if trigger re-activated (vs the delay timer expired) */ if (!ch->trigger_delay) { /* Make it so all ifs (elseifs..) appear executed */ for (i = 0; i < MAX_DEPTH; i++) level_ifs[i] = 1; line_no = ch->trigger_line; } ch->trigger_id = 0; ch->trigger_delay = 0; } prog_ptr = level_ptrs[line_no]; while (get_line (&prog_ptr, line)) { strcpy (current_line, line); if (GET_POS (ch) == POSITION_DEAD) { *ret = 0; return; } line_ptr = line; get_prog_token (&line_ptr, token); if (*token == '!') ; else if (!*token || *token == '\n' || *token == '\r' || *token == ' ') ; else if (!str_cmp (token, "ci")) { mob_string (mob, &line_ptr, command); if (*command) command_interpreter (mob, command); if (mob->deleted) return; if (mob->delay || GET_FLAG (mob, FLAG_ENTERING) || GET_FLAG (mob, FLAG_LEAVING)) { mob->flags |= FLAG_INHIBITTED; mob->trigger_delay = 1; mob->trigger_line = line_no + 1; mob->trigger_id = trigger; return; } } else if (!str_cmp (token, "global") || !str_cmp (token, "var")) define_variable (mob, program, line_ptr); else if (!str_cmp (token, "while")) { require_open_paren (&line_ptr); cur_level = levels[line_no]; if (!mp_eval_eq (mob, &line_ptr)) { line_no++; while (levels[line_no] != cur_level) line_no++; } } else if (!str_cmp (token, "if") || !str_cmp (token, "elseif")) { cur_level = levels[line_no]; if (!str_cmp (token, "if")) level_ifs[cur_level] = 0; if (!level_ifs[cur_level]) require_open_paren (&line_ptr); if (level_ifs[cur_level] || !mp_eval_eq (mob, &line_ptr)) { while (levels[line_no + 1] != cur_level) line_no++; } else level_ifs[cur_level] = 1; } else if (!str_cmp (token, "else")) { cur_level = levels[line_no]; if (level_ifs[cur_level]) { while (levels[line_no + 1] != cur_level) line_no++; } } else if (!str_cmp (token, "reject_command")) { *ret = 0; return; } else if (!str_cmp (token, "endwhile")) { cur_level = levels[line_no]; if (line_no > 0) /* If there is an endwhile on the first line */ line_no--; while (line_no && levels[line_no] != cur_level) line_no--; line_no--; /* Gets incremented at the end of the while */ } else if (!str_cmp (token, "endif")); else if (!str_cmp (token, "delay")) { /* A previously delayed trigger is forgotten */ mob->trigger_delay = mp_eval_eq (mob, &line_ptr); mob->trigger_line = line_no + 1; mob->trigger_id = trigger; return; } else if (!str_cmp (token, "alarm")) mob->alarm = mp_eval_eq (mob, &line_ptr); else if (!str_cmp (token, "return")) return; else assignment (mob, program, token, &line_ptr); prog_ptr = level_ptrs[++line_no]; } }
int wr_dpi(Dpi *d, char *filename, int verbosity) { int err = 0; int status = 0; int u = 0; /* short hand for unit... */ struct Shadow_Identifiers si; memset(&si, 0, sizeof(struct Shadow_Identifiers)); /* * From the C interface guide the basic calling sequence is given * for the case of adding new dimensions, variables and attributes to * an existing netCDF dataset. * * nc_open(); * nc_redef(); * nc_def_dim(); * nc_def_var(); * nc_put_att(); * nc_enddef(); * nc_put_var(); * nc_close(); * */ /* * Open the file. */ #ifdef NETCDF_3 err = nc_open(filename, NC_WRITE, &u); if ( err != NC_NOERR ) { EH(-1, "nc_open() problem."); } #endif #ifdef NETCDF_2 err = ncopen(filename, NC_WRITE); EH(err, "ncopen() problem."); u = err; #endif /* * Go into define mode. */ #ifdef NETCDF_3 err = nc_redef(u); if ( err != NC_NOERR ) { EH(-1, "nc_redef() problem."); } #endif #ifdef NETCDF_2 err = ncredef(u); EH(err, "ncredef() problem."); #endif /* * Define each of the netCDF dimensions that will be needed to describe * the extent of netCDF variables that are arrays. */ define_dimension(u, DIM_LEN_EB_NUM_PRIVATE_ELEMS, d->len_eb_num_private_elems, &si.len_eb_num_private_elems); define_dimension(u, DIM_LEN_ELEM_VAR_TAB_GLOBAL, d->len_elem_var_tab_global, &si.len_elem_var_tab_global); define_dimension(u, DIM_LEN_ELEM_ELEM_LIST, /* new e-e */ d->len_elem_elem_list, &si.len_elem_elem_list); define_dimension(u, DIM_LEN_NODE_DESCRIPTION, d->len_node_description, &si.len_node_description); define_dimension(u, DIM_LEN_NS_NODE_LIST, d->len_ns_node_list, &si.len_ns_node_list); define_dimension(u, DIM_LEN_NS_DISTFACT_LIST, d->len_ns_distfact_list, &si.len_ns_distfact_list); define_dimension(u, DIM_LEN_SS_ELEM_LIST, d->len_ss_elem_list, &si.len_ss_elem_list); define_dimension(u, DIM_LEN_SS_DISTFACT_LIST, d->len_ss_distfact_list, &si.len_ss_distfact_list); define_dimension(u, DIM_LEN_STRING, d->len_string, &si.len_string); define_dimension(u, DIM_LEN_PTR_SET_MEMBERSHIP, d->len_ptr_set_membership, &si.len_ptr_set_membership); define_dimension(u, DIM_LEN_SET_MEMBERSHIP, d->len_set_membership, &si.len_set_membership); define_dimension(u, DIM_NUM_ELEM_BLOCKS, d->num_elem_blocks, &si.num_elem_blocks); define_dimension(u, DIM_NUM_ELEM_BLOCKS_GLOBAL, d->num_elem_blocks_global, &si.num_elem_blocks_global); define_dimension(u, DIM_NUM_ELEMS, d->num_elems, &si.num_elems); define_dimension(u, DIM_NUM_GLOBAL_NODE_DESCRIPTIONS, d->num_global_node_descriptions, &si.num_global_node_descriptions); define_dimension(u, DIM_NUM_NEIGHBORS, d->num_neighbors, &si.num_neighbors); define_dimension(u, DIM_NUM_NODE_SETS, d->num_node_sets, &si.num_node_sets); define_dimension(u, DIM_NUM_NODE_SETS_GLOBAL, d->num_node_sets_global, &si.num_node_sets_global); define_dimension(u, DIM_NUM_NODES, d->num_nodes, &si.num_nodes); define_dimension(u, DIM_NUM_PROPS_EB, d->num_props_eb, &si.num_props_eb); define_dimension(u, DIM_NUM_PROPS_NS, d->num_props_ns, &si.num_props_ns); define_dimension(u, DIM_NUM_PROPS_SS, d->num_props_ss, &si.num_props_ss); define_dimension(u, DIM_NUM_SIDE_SETS, d->num_side_sets, &si.num_side_sets); define_dimension(u, DIM_NUM_SIDE_SETS_GLOBAL, d->num_side_sets_global, &si.num_side_sets_global); define_dimension(u, DIM_NUM_UNIVERSE_NODES, d->num_universe_nodes, &si.num_universe_nodes); if (d->num_side_sets_global > 0) { define_dimension(u, DIM_LEN_SS_BLOCK_INDEX_GLOBAL, d->num_side_sets_global + 1, &si.len_ss_block_index_global); define_dimension(u, DIM_LEN_SS_BLOCK_LIST_GLOBAL, d->ss_block_index_global[d->num_side_sets_global], &si.len_ss_block_list_global); } else { define_dimension(u, DIM_LEN_SS_BLOCK_INDEX_GLOBAL, 0, &si.len_ss_block_index_global); define_dimension(u, DIM_LEN_SS_BLOCK_LIST_GLOBAL, 0, &si.len_ss_block_list_global); } /* * Define variables. Arrays only get defined if their respective dimensions * are greater than zero. * * Also, this handy routine uses two arguments for the possibility of * up to 2D arrays. Dummy arguments of "-1" are inserted for 1D arrays * or for scalar variables ( zero dimensional arrays). */ define_variable(u, VAR_DPI_VERSION_STRING, NC_CHAR, 1, si.len_string, -1, d->len_string, -1, &si.dpi_version_string); define_variable(u, VAR_EB_ELEM_TYPE_GLOBAL, NC_CHAR, 2, si.num_elem_blocks_global, si.len_string, d->num_elem_blocks_global, d->len_string, &si.eb_elem_type_global); define_variable(u, VAR_EB_ID_GLOBAL, NC_INT, 1, si.num_elem_blocks_global, -1, d->num_elem_blocks_global, -1, &si.eb_id_global); define_variable(u, VAR_EB_INDEX_GLOBAL, NC_INT, 1, si.num_elem_blocks, -1, d->num_elem_blocks, -1, &si.eb_index_global); define_variable(u, VAR_EB_NUM_ATTR_GLOBAL, NC_INT, 1, si.num_elem_blocks_global, -1, d->num_elem_blocks_global, -1, &si.eb_num_attr_global); define_variable(u, VAR_EB_NUM_ELEMS_GLOBAL, NC_INT, 1, si.num_elem_blocks_global, -1, d->num_elem_blocks_global, -1, &si.eb_num_elems_global); define_variable(u, VAR_EB_NUM_NODES_PER_ELEM_GLOBAL, NC_INT, 1, si.num_elem_blocks_global, -1, d->num_elem_blocks_global, -1, &si.eb_num_nodes_per_elem_global); define_variable(u, VAR_EB_NUM_PRIVATE_ELEMS, NC_INT, 1, si.num_elem_blocks, -1, d->num_elem_blocks, -1, &si.eb_num_private_elems); if ( d->num_props_eb > 1 ) /* Properties are weird, recall. */ { define_variable(u, VAR_EB_PROP_GLOBAL, NC_INT, 2, si.num_props_eb, si.num_elem_blocks_global, d->num_props_eb, d->num_elem_blocks_global, &si.eb_prop_global); } if ( d->num_elems > 0 ) { define_variable(u, VAR_ELEM_INDEX_GLOBAL, NC_INT, 1, si.num_elems, -1, d->num_elems, -1, &si.elem_index_global); } if ( d->len_elem_var_tab_global > 0 ) { define_variable(u, VAR_ELEM_VAR_TAB_GLOBAL, NC_INT, 1, si.len_elem_var_tab_global, -1, d->len_elem_var_tab_global, -1, &si.elem_var_tab_global); } if ( d->len_elem_elem_list > 0 ) { define_variable(u, VAR_ELEM_OWNER, NC_INT, 1, si.num_elems, -1, d->num_elems, -1, &si.elem_owner); define_variable(u, VAR_ELEM_ELEM_LIST_GLOBAL, NC_INT, 1, si.len_elem_elem_list, -1, d->len_elem_elem_list, -1, &si.elem_elem_list_global); define_variable(u, VAR_ELEM_ELEM_TWST_GLOBAL, NC_INT, 1, si.len_elem_elem_list, -1, d->len_elem_elem_list, -1, &si.elem_elem_twst_global); define_variable(u, VAR_ELEM_ELEM_FACE_GLOBAL, NC_INT, 1, si.len_elem_elem_list, -1, d->len_elem_elem_list, -1, &si.elem_elem_face_global); define_variable(u, VAR_ELEM_ELEM_PROC_GLOBAL, NC_INT, 1, si.len_elem_elem_list, -1, d->len_elem_elem_list, -1, &si.elem_elem_proc_global); } define_variable(u, VAR_GLOBAL_NODE_DESCRIPTION, NC_INT, 2, si.num_global_node_descriptions, si.len_node_description, d->num_global_node_descriptions, d->len_node_description, &si.global_node_description); define_variable(u, VAR_MY_NAME, NC_INT, 0, -1, -1, -1, -1, &si.my_name); define_variable(u, VAR_NEIGHBOR, NC_INT, 1, si.num_neighbors, -1, d->num_neighbors, -1, &si.neighbor); if ( d->num_nodes > 0 ) { define_variable(u, VAR_NODE_INDEX_GLOBAL, NC_INT, 1, si.num_nodes, -1, d->num_nodes, -1, &si.node_index_global); } define_variable(u, VAR_NS_DISTFACT_INDEX_GLOBAL, NC_INT, 1, si.num_node_sets_global, -1, d->num_node_sets_global, -1, &si.ns_distfact_index_global); define_variable(u, VAR_NS_DISTFACT_LEN_GLOBAL, NC_INT, 0, -1, -1, -1, -1, &si.ns_distfact_len_global); define_variable(u, VAR_NS_DISTFACT_LIST_INDEX_GLOBAL, NC_INT, 1, si.len_ns_distfact_list, -1, d->len_ns_distfact_list, -1, &si.ns_distfact_list_index_global); define_variable(u, VAR_NS_ID_GLOBAL, NC_INT, 1, si.num_node_sets_global, -1, d->num_node_sets_global, -1, &si.ns_id_global); define_variable(u, VAR_NS_INDEX_GLOBAL, NC_INT, 1, si.num_node_sets, -1, d->num_node_sets, -1, &si.ns_index_global); define_variable(u, VAR_NS_NODE_INDEX_GLOBAL, NC_INT, 1, si.num_node_sets_global, -1, d->num_node_sets_global, -1, &si.ns_node_index_global); define_variable(u, VAR_NS_NODE_LEN_GLOBAL, NC_INT, 0, -1, -1, -1, -1, &si.ns_node_len_global); define_variable(u, VAR_NS_NODE_LIST_INDEX_GLOBAL, NC_INT, 1, si.len_ns_node_list, -1, d->len_ns_node_list, -1, &si.ns_node_list_index_global); define_variable(u, VAR_NS_NUM_DISTFACTS_GLOBAL, NC_INT, 1, si.num_node_sets_global, -1, d->num_node_sets_global, -1, &si.ns_num_distfacts_global); define_variable(u, VAR_NS_NUM_NODES_GLOBAL, NC_INT, 1, si.num_node_sets_global, -1, d->num_node_sets_global, -1, &si.ns_num_nodes_global); if ( d->num_props_ns > 1 ) { define_variable(u, VAR_NS_PROP_GLOBAL, NC_INT, 2, si.num_props_ns, si.num_node_sets_global, d->num_props_ns, d->num_node_sets_global, &si.ns_prop_global); } define_variable(u, VAR_NUM_BOUNDARY_NODES, NC_INT, 0, -1, -1, -1, -1, &si.num_boundary_nodes); define_variable(u, VAR_NUM_DOFS_GLOBAL, NC_INT, 0, -1, -1, -1, -1, &si.num_dofs_global); define_variable(u, VAR_NUM_ELEMS_GLOBAL, NC_INT, 0, -1, -1, -1, -1, &si.num_elems_global); define_variable(u, VAR_NUM_EXTERNAL_NODES, NC_INT, 0, -1, -1, -1, -1, &si.num_external_nodes); define_variable(u, VAR_NUM_INTERNAL_NODES, NC_INT, 0, -1, -1, -1, -1, &si.num_internal_nodes); define_variable(u, VAR_NUM_NODES_GLOBAL, NC_INT, 0, -1, -1, -1, -1, &si.num_nodes_global); define_variable(u, VAR_PTR_SET_MEMBERSHIP, NC_INT, 1, si.len_ptr_set_membership, -1, d->len_ptr_set_membership, -1, &si.ptr_set_membership); define_variable(u, VAR_SET_MEMBERSHIP, NC_INT, 1, si.len_set_membership, -1, d->len_set_membership, -1, &si.set_membership); define_variable(u, VAR_SS_DISTFACT_INDEX_GLOBAL, NC_INT, 1, si.num_side_sets_global, -1, d->num_side_sets_global, -1, &si.ss_distfact_index_global); define_variable(u, VAR_SS_DISTFACT_LIST_INDEX_GLOBAL, NC_INT, 1, si.len_ss_distfact_list, -1, d->len_ss_distfact_list, -1, &si.ss_distfact_list_index_global); define_variable(u, VAR_SS_DISTFACT_LEN_GLOBAL, NC_INT, 0, -1, -1, -1, -1, &si.ss_distfact_len_global); define_variable(u, VAR_SS_ELEM_INDEX_GLOBAL, NC_INT, 1, si.num_side_sets_global, -1, d->num_side_sets_global, -1, &si.ss_elem_index_global); define_variable(u, VAR_SS_ELEM_LEN_GLOBAL, NC_INT, 0, -1, -1, -1, -1, &si.ss_elem_len_global); define_variable(u, VAR_SS_ELEM_LIST_INDEX_GLOBAL, NC_INT, 1, si.len_ss_elem_list, -1, d->len_ss_elem_list, -1, &si.ss_elem_list_index_global); define_variable(u, VAR_SS_ID_GLOBAL, NC_INT, 1, si.num_side_sets_global, -1, d->num_side_sets_global, -1, &si.ss_id_global); define_variable(u, VAR_SS_INDEX_GLOBAL, NC_INT, 1, si.num_side_sets, -1, d->num_side_sets, -1, &si.ss_index_global); define_variable(u, VAR_SS_NUM_DISTFACTS_GLOBAL, NC_INT, 1, si.num_side_sets_global, -1, d->num_side_sets_global, -1, &si.ss_num_distfacts_global); define_variable(u, VAR_SS_NUM_SIDES_GLOBAL, NC_INT, 1, si.num_side_sets_global, -1, d->num_side_sets_global, -1, &si.ss_num_sides_global); if ( d->num_props_ss > 1 ) { define_variable(u, VAR_SS_PROP_GLOBAL, NC_INT, 2, si.num_props_ss, si.num_side_sets_global, d->num_props_ss, d->num_side_sets_global, &si.ss_prop_global); } if ( d->num_side_sets_global > 0 ) { define_variable(u, VAR_SS_INTERNAL_GLOBAL, NC_INT, 1, si.num_side_sets_global, -1, d->num_side_sets_global, -1, &si.ss_internal_global); define_variable(u, VAR_SS_BLOCK_INDEX_GLOBAL, NC_INT, 1, si.len_ss_block_index_global, -1, d->num_side_sets_global + 1, -1, &si.ss_block_index_global); define_variable(u, VAR_SS_BLOCK_LIST_GLOBAL, NC_INT, 1, si.len_ss_block_list_global, -1, d->ss_block_index_global[d->num_side_sets_global], -1, &si.ss_block_list_global); } define_variable(u, VAR_UNDEFINED_BASIC_EQNVAR_ID, NC_INT, 0, -1, -1, -1, -1, &si.undefined_basic_eqnvar_id); /* * Leave define mode. */ #ifdef NETCDF_3 err = nc_enddef(u); if ( err != NC_NOERR ) { EH(-1, "nc_enddef() problem."); } #endif #ifdef NETCDF_2 err = ncendef(u); EH(err, "ncendef() problem."); #endif /* * Put variable values. * * This form is good for scalars, 1d arrays and 2d arrays. Any more and * you'll need to add another argument to the list for the backward * compatible to netCDF implementation to work properly. We'll assume * that start[] arrays that ncvarput() uses will be full of zeroes. * If not, then you'll need to do that case by hand. */ put_variable(u, NC_CHAR, 1, d->len_string, -1, si.dpi_version_string, d->dpi_version_string); put_variable(u, NC_CHAR, 2, d->num_elem_blocks_global, d->len_string, si.eb_elem_type_global, &(d->eb_elem_type_global[0][0])); put_variable(u, NC_INT, 1, d->num_elem_blocks_global, -1, si.eb_id_global, d->eb_id_global); put_variable(u, NC_INT, 1, d->num_elem_blocks, -1, si.eb_index_global, d->eb_index_global); put_variable(u, NC_INT, 1, d->num_elem_blocks_global, -1, si.eb_num_attr_global, d->eb_num_attr_global); put_variable(u, NC_INT, 1, d->num_elem_blocks_global, -1, si.eb_num_elems_global, d->eb_num_elems_global); put_variable(u, NC_INT, 1, d->num_elem_blocks_global, -1, si.eb_num_nodes_per_elem_global, d->eb_num_nodes_per_elem_global); put_variable(u, NC_INT, 1, d->num_elem_blocks, -1, si.eb_num_private_elems, d->eb_num_private_elems); if ( d->num_props_eb > 1 ) { put_variable(u, NC_INT, 2, d->num_props_eb, d->num_elem_blocks_global, si.eb_prop_global, &(d->eb_prop_global[0][0])); } if ( d->num_elems > 0 ) { put_variable(u, NC_INT, 1, d->num_elems, -1, si.elem_index_global, d->elem_index_global); put_variable(u, NC_INT, 1, d->num_elems, -1, si.elem_owner, d->elem_owner); } if ( d->len_elem_var_tab_global > 0 ) { put_variable(u, NC_INT, 1, d->len_elem_var_tab_global, -1, si.elem_var_tab_global, d->elem_var_tab_global); } if ( d->len_elem_elem_list > 0 ) { put_variable(u, NC_INT, 1, d->len_elem_elem_list, -1, si.elem_elem_list_global, d->elem_elem_list_global); put_variable(u, NC_INT, 1, d->len_elem_elem_list, -1, si.elem_elem_face_global, d->elem_elem_face_global); put_variable(u, NC_INT, 1, d->len_elem_elem_list, -1, si.elem_elem_twst_global, d->elem_elem_twst_global); put_variable(u, NC_INT, 1, d->len_elem_elem_list, -1, si.elem_elem_proc_global, d->elem_elem_proc_global); } put_variable(u, NC_INT, 2, d->num_global_node_descriptions, d->len_node_description, si.global_node_description,&(d->global_node_description[0][0])); put_variable(u, NC_INT, 0, -1, -1, si.my_name, &(d->my_name)); put_variable(u, NC_INT, 1, d->num_neighbors, -1, si.neighbor, d->neighbor); if ( d->num_nodes > 0 ) { put_variable(u, NC_INT, 1, d->num_nodes, -1, si.node_index_global, d->node_index_global); } put_variable(u, NC_INT, 0, -1, -1, si.ns_distfact_len_global, &(d->ns_distfact_len_global)); put_variable(u, NC_INT, 0, -1, -1, si.ns_node_len_global, &(d->ns_node_len_global)); put_variable(u, NC_INT, 1, d->num_node_sets_global, -1, si.ns_id_global, d->ns_id_global); put_variable(u, NC_INT, 1, d->num_node_sets, -1, si.ns_index_global, d->ns_index_global); put_variable(u, NC_INT, 1, d->len_ns_distfact_list, -1, si.ns_distfact_list_index_global, d->ns_distfact_list_index_global); put_variable(u, NC_INT, 1, d->num_node_sets_global, -1, si.ns_distfact_index_global, d->ns_distfact_index_global); put_variable(u, NC_INT, 1, d->num_node_sets_global, -1, si.ns_node_index_global, d->ns_node_index_global); put_variable(u, NC_INT, 1, d->len_ns_node_list, -1, si.ns_node_list_index_global, d->ns_node_list_index_global); put_variable(u, NC_INT, 1, d->num_node_sets_global, -1, si.ns_num_distfacts_global, d->ns_num_distfacts_global); put_variable(u, NC_INT, 1, d->num_node_sets_global, -1, si.ns_num_nodes_global, d->ns_num_nodes_global); if ( d->num_props_ns > 1 ) { put_variable(u, NC_INT, 2, d->num_props_ns, d->num_node_sets_global, si.ns_prop_global, &(d->ns_prop_global[0][0])); } put_variable(u, NC_INT, 0, -1, -1, si.num_boundary_nodes, &(d->num_boundary_nodes)); put_variable(u, NC_INT, 0, -1, -1, si.num_dofs_global, &(d->num_dofs_global)); put_variable(u, NC_INT, 0, -1, -1, si.num_elems_global, &(d->num_elems_global)); put_variable(u, NC_INT, 0, -1, -1, si.num_external_nodes, &(d->num_external_nodes)); put_variable(u, NC_INT, 0, -1, -1, si.num_internal_nodes, &(d->num_internal_nodes)); put_variable(u, NC_INT, 0, -1, -1, si.num_nodes_global, &(d->num_nodes_global)); put_variable(u, NC_INT, 1, d->len_ptr_set_membership, -1, si.ptr_set_membership, d->ptr_set_membership); put_variable(u, NC_INT, 1, d->len_set_membership, -1, si.set_membership, d->set_membership); put_variable(u, NC_INT, 1, d->num_side_sets_global, -1, si.ss_distfact_index_global, d->ss_distfact_index_global); put_variable(u, NC_INT, 0, -1, -1, si.ss_distfact_len_global, &(d->ss_distfact_len_global)); if ( d->len_ss_distfact_list > 0 ) { put_variable(u, NC_INT, 1, d->len_ss_distfact_list, -1, si.ss_distfact_list_index_global, d->ss_distfact_list_index_global); } put_variable(u, NC_INT, 1, d->num_side_sets_global, -1, si.ss_elem_index_global, d->ss_elem_index_global); put_variable(u, NC_INT, 0, -1, -1, si.ss_elem_len_global, &(d->ss_elem_len_global)); if ( d->len_ss_elem_list > 0 ) { put_variable(u, NC_INT, 1, d->len_ss_elem_list, -1, si.ss_elem_list_index_global, d->ss_elem_list_index_global); } put_variable(u, NC_INT, 1, d->num_side_sets_global, -1, si.ss_id_global, d->ss_id_global); if ( d->num_side_sets > 0 ) { put_variable(u, NC_INT, 1, d->num_side_sets, -1, si.ss_index_global, d->ss_index_global); } put_variable(u, NC_INT, 1, d->num_side_sets_global, -1, si.ss_num_distfacts_global, d->ss_num_distfacts_global); put_variable(u, NC_INT, 1, d->num_side_sets_global, -1, si.ss_num_sides_global, d->ss_num_sides_global); if ( d->num_props_ss > 1 ) { put_variable(u, NC_INT, 2, d->num_props_ss, d->num_side_sets_global, si.ss_prop_global, &(d->ss_prop_global[0][0])); } put_variable(u, NC_INT, 0, -1, -1, si.undefined_basic_eqnvar_id, &(d->undefined_basic_eqnvar_id)); if (d->num_side_sets_global > 0) { put_variable(u, NC_INT, 1, d->num_side_sets_global, -1, si.ss_internal_global, d->ss_internal_global); put_variable(u, NC_INT, 1, d->num_side_sets_global+1, -1, si.ss_block_index_global, d->ss_block_index_global); put_variable(u, NC_INT, 1, d->ss_block_index_global[d->num_side_sets_global], -1, si.ss_block_list_global, d->ss_block_list_global); } /* * Close the file (flush buffers). */ #ifdef NETCDF_3 err = nc_close(u); if ( err != NC_NOERR ) { EH(-1, "nc_close() problem."); } #endif #ifdef NETCDF_2 err = ncclose(u); EH(err, "ncclose()"); #endif return(status); }
object *eval_definition(object *exp, object *env) { define_variable(definition_variable(exp), eval(definition_value(exp), env), env); return ok_symbol(); }
static data_t *eval_definition(const data_t *exp, data_t *env) { return define_variable(get_definition_variable(exp), eval(get_definition_value(exp), env), env); }