SCM scm_the_root_module (void) { if (scm_module_system_booted_p) return SCM_VARIABLE_REF (the_root_module_var); else return SCM_BOOL_F; }
SWIGINTERN swig_module_info * SWIG_Guile_GetModule(void) { SCM module; SCM variable; module = SWIG_Guile_Init(); variable = scm_sym2var(scm_from_locale_symbol("swig-type-list-address" SWIG_RUNTIME_VERSION SWIG_TYPE_TABLE_NAME), scm_module_lookup_closure(module), SCM_BOOL_T); if (SCM_UNBNDP(SCM_VARIABLE_REF(variable))) { return NULL; } else { return (swig_module_info *) scm_to_ulong(SCM_VARIABLE_REF(variable)); } }
SWIGINTERN int ensure_smob_tag(SCM swig_module, scm_t_bits *tag_variable, const char *smob_name, const char *scheme_variable_name) { SCM variable = scm_sym2var(scm_from_locale_symbol(scheme_variable_name), scm_module_lookup_closure(swig_module), SCM_BOOL_T); if (SCM_UNBNDP(SCM_VARIABLE_REF(variable))) { *tag_variable = scm_make_smob_type((char*)scheme_variable_name, 0); SCM_VARIABLE_SET(variable, scm_from_ulong(*tag_variable)); return 1; } else { *tag_variable = scm_to_ulong(SCM_VARIABLE_REF(variable)); return 0; } }
SCM scm_dynstack_find_old_fluid_value (scm_t_dynstack *dynstack, SCM fluid, size_t depth, SCM dflt) { scm_t_bits *walk; for (walk = SCM_DYNSTACK_PREV (dynstack->top); walk; walk = SCM_DYNSTACK_PREV (walk)) { scm_t_bits tag = SCM_DYNSTACK_TAG (walk); switch (SCM_DYNSTACK_TAG_TYPE (tag)) { case SCM_DYNSTACK_TYPE_WITH_FLUID: { if (scm_is_eq (WITH_FLUID_FLUID (walk), fluid)) { if (depth == 0) return SCM_VARIABLE_REF (WITH_FLUID_VALUE_BOX (walk)); else depth--; } break; } case SCM_DYNSTACK_TYPE_DYNAMIC_STATE: { SCM state, val; /* The previous dynamic state may or may not have established a binding for this fluid. */ state = scm_variable_ref (DYNAMIC_STATE_STATE_BOX (walk)); val = scm_dynamic_state_ref (state, fluid, SCM_UNDEFINED); if (!SCM_UNBNDP (val)) { if (depth == 0) return val; else depth--; } break; } default: break; } } return dflt; }
static SCM eval (SCM x, SCM env) { SCM mx; SCM proc = SCM_UNDEFINED, args = SCM_EOL; unsigned int argc; loop: SCM_TICK; if (!SCM_MEMOIZED_P (x)) abort (); mx = SCM_MEMOIZED_ARGS (x); switch (SCM_MEMOIZED_TAG (x)) { case SCM_M_SEQ: eval (CAR (mx), env); x = CDR (mx); goto loop; case SCM_M_IF: if (scm_is_true (EVAL1 (CAR (mx), env))) x = CADR (mx); else x = CDDR (mx); goto loop; case SCM_M_LET: { SCM inits = CAR (mx); SCM new_env = CAPTURE_ENV (env); for (; scm_is_pair (inits); inits = CDR (inits)) new_env = scm_cons (EVAL1 (CAR (inits), env), new_env); env = new_env; x = CDR (mx); goto loop; } case SCM_M_LAMBDA: RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env)); case SCM_M_QUOTE: return mx; case SCM_M_DEFINE: scm_define (CAR (mx), EVAL1 (CDR (mx), env)); return SCM_UNSPECIFIED; case SCM_M_DYNWIND: { SCM in, out, res; scm_i_thread *t = SCM_I_CURRENT_THREAD; in = EVAL1 (CAR (mx), env); out = EVAL1 (CDDR (mx), env); scm_call_0 (in); scm_dynstack_push_dynwind (&t->dynstack, in, out); res = eval (CADR (mx), env); scm_dynstack_pop (&t->dynstack); scm_call_0 (out); return res; } case SCM_M_WITH_FLUIDS: { long i, len; SCM *fluidv, *valuesv, walk, res; scm_i_thread *thread = SCM_I_CURRENT_THREAD; len = scm_ilength (CAR (mx)); fluidv = alloca (sizeof (SCM)*len); for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk)) fluidv[i] = EVAL1 (CAR (walk), env); valuesv = alloca (sizeof (SCM)*len); for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk)) valuesv[i] = EVAL1 (CAR (walk), env); scm_dynstack_push_fluids (&thread->dynstack, len, fluidv, valuesv, thread->dynamic_state); res = eval (CDDR (mx), env); scm_dynstack_unwind_fluids (&thread->dynstack, thread->dynamic_state); return res; } case SCM_M_APPLY: /* Evaluate the procedure to be applied. */ proc = EVAL1 (CAR (mx), env); /* Evaluate the argument holding the list of arguments */ args = EVAL1 (CADR (mx), env); apply_proc: /* Go here to tail-apply a procedure. PROC is the procedure and * ARGS is the list of arguments. */ if (BOOT_CLOSURE_P (proc)) { prepare_boot_closure_env_for_apply (proc, args, &x, &env); goto loop; } else return scm_call_with_vm (scm_the_vm (), proc, args); case SCM_M_CALL: /* Evaluate the procedure to be applied. */ proc = EVAL1 (CAR (mx), env); argc = SCM_I_INUM (CADR (mx)); mx = CDDR (mx); if (BOOT_CLOSURE_P (proc)) { prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env); goto loop; } else { SCM *argv; unsigned int i; argv = alloca (argc * sizeof (SCM)); for (i = 0; i < argc; i++, mx = CDR (mx)) argv[i] = EVAL1 (CAR (mx), env); return scm_c_vm_run (scm_the_vm (), proc, argv, argc); } case SCM_M_CONT: return scm_i_call_with_current_continuation (EVAL1 (mx, env)); case SCM_M_CALL_WITH_VALUES: { SCM producer; SCM v; producer = EVAL1 (CAR (mx), env); /* `proc' is the consumer. */ proc = EVAL1 (CDR (mx), env); v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL); if (SCM_VALUESP (v)) args = scm_struct_ref (v, SCM_INUM0); else args = scm_list_1 (v); goto apply_proc; } case SCM_M_LEXICAL_REF: { int n; SCM ret; for (n = SCM_I_INUM (mx); n; n--) env = CDR (env); ret = CAR (env); if (SCM_UNLIKELY (SCM_UNBNDP (ret))) /* we don't know what variable, though, because we don't have its name */ error_used_before_defined (); return ret; } case SCM_M_LEXICAL_SET: { int n; SCM val = EVAL1 (CDR (mx), env); for (n = SCM_I_INUM (CAR (mx)); n; n--) env = CDR (env); SCM_SETCAR (env, val); return SCM_UNSPECIFIED; } case SCM_M_TOPLEVEL_REF: if (SCM_VARIABLEP (mx)) return SCM_VARIABLE_REF (mx); else { while (scm_is_pair (env)) env = CDR (env); return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, CAPTURE_ENV (env))); } case SCM_M_TOPLEVEL_SET: { SCM var = CAR (mx); SCM val = EVAL1 (CDR (mx), env); if (SCM_VARIABLEP (var)) { SCM_VARIABLE_SET (var, val); return SCM_UNSPECIFIED; } else { while (scm_is_pair (env)) env = CDR (env); SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)), val); return SCM_UNSPECIFIED; } } case SCM_M_MODULE_REF: if (SCM_VARIABLEP (mx)) return SCM_VARIABLE_REF (mx); else return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, SCM_BOOL_F)); case SCM_M_MODULE_SET: if (SCM_VARIABLEP (CDR (mx))) { SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env)); return SCM_UNSPECIFIED; } else { SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, SCM_BOOL_F), EVAL1 (CAR (mx), env)); return SCM_UNSPECIFIED; } case SCM_M_PROMPT: { SCM vm, k, res; scm_i_jmp_buf registers; /* We need the handler after nonlocal return to the setjmp, so make sure it is volatile. */ volatile SCM handler; k = EVAL1 (CAR (mx), env); handler = EVAL1 (CDDR (mx), env); vm = scm_the_vm (); /* Push the prompt onto the dynamic stack. */ scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack, SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY, k, SCM_VM_DATA (vm)->fp, SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip, ®isters); if (SCM_I_SETJMP (registers)) { /* The prompt exited nonlocally. */ proc = handler; args = scm_i_prompt_pop_abort_args_x (scm_the_vm ()); goto apply_proc; } res = eval (CADR (mx), env); scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack); return res; } default: abort (); } }
/* in the form: (1 2 3 4). Repeated slots are NOT returned */ SCM g_get_unique_slots(SCM scm_uref) { NETLIST *nl_current; char *uref; gchar *slot = NULL; char *slot_tmp = NULL; SCM slots_list = SCM_EOL; SCM slot_number; SCM_ASSERT(scm_is_string (scm_uref), scm_uref, SCM_ARG1, "gnetlist:get-unique-slots-used-of-package"); uref = SCM_STRING_CHARS (scm_uref); /* here is where you make it multi page aware */ nl_current = netlist_head; /* search for the first instance */ /* through the entire list */ while (nl_current != NULL) { if (nl_current->component_uref) { if (strcmp(nl_current->component_uref, uref) == 0) { /* first search outside the symbol */ slot_tmp = o_attrib_search_name_single(nl_current->object_ptr, "slot", NULL); if (!slot_tmp) { /* if not found, search inside the symbol */ slot_tmp = o_attrib_search_name(nl_current->object_ptr-> complex->prim_objs, "slot", 0); } /* When a package has no slot attribute, then assume it's slot number 1 */ if (!slot_tmp) { slot_tmp=g_strdup("1"); } slot = g_strconcat ("#d", slot_tmp, NULL); slot_number = scm_string_to_number(scm_makfrom0str (slot), scm_from_int(10)); g_free (slot); if (slot_number != SCM_BOOL_F) { if (scm_member(slot_number, slots_list) == SCM_BOOL_F) { slots_list = scm_cons (slot_number, slots_list); } } else fprintf(stderr, "Uref %s: Bad slot number: %s.\n", uref, slot_tmp); g_free (slot_tmp); } } nl_current = nl_current->next; } slots_list = scm_sort_list_x(slots_list, SCM_VARIABLE_REF (scm_c_module_lookup ( scm_current_module (), "<"))); return (slots_list); }