static PyObject *load_wrapper(PyObject *name_arg) { return scm2py( scm_eval( scm_list_2(scm_from_utf8_symbol("load"), py2scm(name_arg)), scm_current_module())); }
PyObject *VM_init(VM *self, PyObject *args, PyObject *kwds){ // For the enviroment setup scm_init_guile(); self->root = scm_current_module(); self->SMOB_Tag = scm_make_smob_type("PythonSMOB", 0); self->callbacks = PyDict_New(); return 0; }
static SCM expand_env_ref_macro (SCM env, SCM x) { SCM var; if (!expand_env_var_is_free (env, x)) return SCM_BOOL_F; /* lexical */ var = scm_module_variable (scm_current_module (), x); if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var)) && scm_is_true (scm_macro_p (scm_variable_ref (var)))) return scm_variable_ref (var); else return SCM_BOOL_F; /* anything else */ }
static void shell_main (void *data, int argc, char **argv) { SCM setup_lst = SCM_EOL; /* We reverse! this before using it. */ SCM run_lst = SCM_EOL; /* We reverse! this before using it. */ int c; int interactive = 1; int inhibit_rc = 0; int status; TOPLEVEL *toplevel; #include "shell.x" /* Parse command-line arguments */ opterr = 0; while ((c = getopt (argc, argv, GETOPT_OPTIONS)) != -1) { switch (c) { case 's': /* Construct an application of LOAD to the script name */ run_lst = scm_cons (scm_list_2 (sym_load, scm_from_locale_string (optarg)), run_lst); interactive = 0; goto endoptloop; case 'c': /* We need to evaluate an expression */ run_lst = scm_cons (scm_list_2 (sym_eval_string, scm_from_locale_string (optarg)), run_lst); interactive = 0; goto endoptloop; case 'L': /* Add argument to %load-path */ setup_lst = scm_cons (scm_list_3 (sym_set_x, sym_load_path, scm_list_3 (sym_cons, scm_from_locale_string (optarg), sym_load_path)), setup_lst); break; case 'l': /* Same as -s, pretty much */ run_lst = scm_cons (scm_list_2 (sym_load, scm_from_locale_string (optarg)), run_lst); break; case 'q': inhibit_rc = 1; break; case 'h': usage (0); case 'V': version(); case '?': if ((optopt != ':') && (strchr (GETOPT_OPTIONS, optopt) != NULL)) { fprintf (stderr, "ERROR: -%c option requires an argument.\n\n", optopt); usage (1); } else if (isprint (optopt)) { fprintf (stderr, "ERROR: Unknown option -%c\n\n", optopt); usage (1); } else { fprintf (stderr, "ERROR: Unknown option character `\\x%x'.\n\n", optopt); usage (1); } default: g_assert_not_reached (); } } endoptloop: /* Set program arguments visible from Guile */ scm_set_program_arguments (argc - optind, argv + optind, "geda-shell"); /* If interactive mode, load readline and run top REPL. */ if (interactive) { run_lst = scm_cons (scm_list_2 (sym_use_modules, scm_list_2 (sym_ice_9, sym_readline)), run_lst); run_lst = scm_cons (scm_list_1 (sym_activate_readline), run_lst); run_lst = scm_cons (scm_list_1 (sym_top_repl), run_lst); /* Print GPL bumf if necessary */ if (isatty (1) && isatty (0)) { printf ( "gEDA " PACKAGE_GIT_VERSION "\n" "Copyright (C) 1998-2010 gEDA developers\n" "This is free software, and you are welcome to redistribute it under\n" "certain conditions. For details, see the file `COPYING', which is\n" "included in the gEDA distribution.\n" "There is NO WARRANTY, to the extent permitted by law.\n" ); } } else { run_lst = scm_cons (scm_list_1 (sym_quit), run_lst); } /* Reverse lists */ setup_lst = scm_reverse_x (setup_lst, SCM_UNDEFINED); run_lst = scm_reverse_x (run_lst, SCM_UNDEFINED); /* Initialise libgeda */ libgeda_init (); scm_dynwind_begin (0); toplevel = s_toplevel_new (); edascm_dynwind_toplevel (toplevel); /* First run the setup list */ if (setup_lst != SCM_EOL) { setup_lst = scm_cons (sym_begin, setup_lst); scm_eval_x (setup_lst, scm_current_module ()); } /* Now load rc files, if necessary */ if (!inhibit_rc) g_rc_parse (toplevel, argv[0], NULL, NULL); i_vars_libgeda_set (toplevel); /* Ugh */ /* Finally evaluate run list */ run_lst = scm_cons (sym_begin, run_lst); status = scm_exit_status (scm_eval_x (run_lst, scm_current_module ())); exit (status); scm_dynwind_end (); scm_remember_upto_here_2 (setup_lst, run_lst); }
/* 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); }
void * weechat_guile_exec (struct t_plugin_script *script, int ret_type, const char *function, char *format, void **argv) { struct t_plugin_script *old_guile_current_script; SCM rc, old_current_module; void *argv2[17], *ret_value; int i, argc, *ret_int; old_guile_current_script = guile_current_script; old_current_module = NULL; if (script->interpreter) { old_current_module = scm_current_module (); scm_set_current_module ((SCM)(script->interpreter)); } guile_current_script = script; if (argv && argv[0]) { argc = strlen (format); for (i = 0; i < argc; i++) { switch (format[i]) { case 's': /* string */ argv2[i] = scm_from_locale_string ((char *)argv[i]); break; case 'i': /* integer */ argv2[i] = scm_from_int (*((int *)argv[i])); break; case 'h': /* hash */ argv2[i] = weechat_guile_hashtable_to_alist (argv[i]); break; } } for (i = argc; i < 17; i++) { argv2[i] = SCM_UNDEFINED; } rc = weechat_guile_exec_function (function, (SCM *)argv2, argc); } else { rc = weechat_guile_exec_function (function, NULL, 0); } ret_value = NULL; if ((ret_type == WEECHAT_SCRIPT_EXEC_STRING) && (scm_is_string (rc))) { ret_value = scm_to_locale_string (rc); } else if ((ret_type == WEECHAT_SCRIPT_EXEC_INT) && (scm_is_integer (rc))) { ret_int = malloc (sizeof (*ret_int)); if (ret_int) *ret_int = scm_to_int (rc); ret_value = ret_int; } else if (ret_type == WEECHAT_SCRIPT_EXEC_HASHTABLE) { ret_value = weechat_guile_alist_to_hashtable (rc, WEECHAT_SCRIPT_HASHTABLE_DEFAULT_SIZE, WEECHAT_HASHTABLE_STRING, WEECHAT_HASHTABLE_STRING); } else { weechat_printf (NULL, weechat_gettext ("%s%s: function \"%s\" must return " "a valid value"), weechat_prefix ("error"), GUILE_PLUGIN_NAME, function); } if (ret_value == NULL) { weechat_printf (NULL, weechat_gettext ("%s%s: error in function \"%s\""), weechat_prefix ("error"), GUILE_PLUGIN_NAME, function); } if (old_current_module) scm_set_current_module (old_current_module); guile_current_script = old_guile_current_script; return ret_value; }
static SCM memoize (SCM exp, SCM env) { if (!SCM_EXPANDED_P (exp)) abort (); switch (SCM_EXPANDED_TYPE (exp)) { case SCM_EXPANDED_VOID: return MAKMEMO_QUOTE (SCM_UNSPECIFIED); case SCM_EXPANDED_CONST: return MAKMEMO_QUOTE (REF (exp, CONST, EXP)); case SCM_EXPANDED_PRIMITIVE_REF: if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return maybe_makmemo_capture_module (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, REF (exp, PRIMITIVE_REF, NAME))), env); else return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF, list_of_guile, REF (exp, PRIMITIVE_REF, NAME), SCM_BOOL_F)); case SCM_EXPANDED_LEXICAL_REF: return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env)); case SCM_EXPANDED_LEXICAL_SET: return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env), memoize (REF (exp, LEXICAL_SET, EXP), env)); case SCM_EXPANDED_MODULE_REF: return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF, REF (exp, MODULE_REF, MOD), REF (exp, MODULE_REF, NAME), REF (exp, MODULE_REF, PUBLIC))); case SCM_EXPANDED_MODULE_SET: return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_SET, REF (exp, MODULE_SET, MOD), REF (exp, MODULE_SET, NAME), REF (exp, MODULE_SET, PUBLIC)), memoize (REF (exp, MODULE_SET, EXP), env)); case SCM_EXPANDED_TOPLEVEL_REF: return maybe_makmemo_capture_module (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, REF (exp, TOPLEVEL_REF, NAME))), env); case SCM_EXPANDED_TOPLEVEL_SET: return maybe_makmemo_capture_module (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET, REF (exp, TOPLEVEL_SET, NAME)), memoize (REF (exp, TOPLEVEL_SET, EXP), capture_env (env))), env); case SCM_EXPANDED_TOPLEVEL_DEFINE: return maybe_makmemo_capture_module (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE, REF (exp, TOPLEVEL_DEFINE, NAME)), memoize (REF (exp, TOPLEVEL_DEFINE, EXP), capture_env (env))), env); case SCM_EXPANDED_CONDITIONAL: return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env), memoize (REF (exp, CONDITIONAL, CONSEQUENT), env), memoize (REF (exp, CONDITIONAL, ALTERNATE), env)); case SCM_EXPANDED_CALL: { SCM proc, args; proc = REF (exp, CALL, PROC); args = memoize_exps (REF (exp, CALL, ARGS), env); return MAKMEMO_CALL (memoize (proc, env), args); } case SCM_EXPANDED_PRIMCALL: { SCM name, args; int nargs; name = REF (exp, PRIMCALL, NAME); args = memoize_exps (REF (exp, PRIMCALL, ARGS), env); nargs = scm_ilength (args); if (nargs == 3 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt"))) return MAKMEMO_CALL_WITH_PROMPT (CAR (args), CADR (args), CADDR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("apply"))) return MAKMEMO_APPLY (CAR (args), CADR (args)); else if (nargs == 1 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-current-continuation"))) return MAKMEMO_CONT (CAR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-values"))) return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args)); else if (nargs == 1 && scm_is_eq (name, scm_from_latin1_symbol ("variable-ref"))) return MAKMEMO_BOX_REF (CAR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("variable-set!"))) return MAKMEMO_BOX_SET (CAR (args), CADR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("wind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("unwind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), SCM_EOL); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL); else if (nargs == 1 && scm_is_eq (name, scm_from_latin1_symbol ("push-dynamic-state"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("pop-dynamic-state"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL); else if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return MAKMEMO_CALL (maybe_makmemo_capture_module (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF, name)), env), args); else return MAKMEMO_CALL (MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF, list_of_guile, name, SCM_BOOL_F)), args); } case SCM_EXPANDED_SEQ: return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env), memoize (REF (exp, SEQ, TAIL), env)); case SCM_EXPANDED_LAMBDA: /* The body will be a lambda-case. */ { SCM meta, body, proc, new_env; meta = REF (exp, LAMBDA, META); body = REF (exp, LAMBDA, BODY); new_env = push_flat_link (capture_env (env)); proc = memoize (body, new_env); SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta); return maybe_makmemo_capture_module (capture_flat_env (proc, new_env), env); } case SCM_EXPANDED_LAMBDA_CASE: { SCM req, rest, opt, kw, inits, vars, body, alt; SCM unbound, arity, rib, new_env; int nreq, nopt, ninits; req = REF (exp, LAMBDA_CASE, REQ); rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST))); opt = REF (exp, LAMBDA_CASE, OPT); kw = REF (exp, LAMBDA_CASE, KW); inits = REF (exp, LAMBDA_CASE, INITS); vars = REF (exp, LAMBDA_CASE, GENSYMS); body = REF (exp, LAMBDA_CASE, BODY); alt = REF (exp, LAMBDA_CASE, ALTERNATE); nreq = scm_ilength (req); nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0; ninits = scm_ilength (inits); /* This relies on assignment conversion turning inits into a sequence of CONST expressions whose values are a unique "unbound" token. */ unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F; rib = scm_vector (vars); new_env = push_nested_link (rib, env); if (scm_is_true (kw)) { /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */ SCM aok = CAR (kw), indices = SCM_EOL; for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw)) { SCM k; int idx; k = CAR (CAR (kw)); idx = lookup_rib (CADDR (CAR (kw)), rib); indices = scm_acons (k, SCM_I_MAKINUM (idx), indices); } kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED)); } if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt)) { if (scm_is_false (rest)) arity = FIXED_ARITY (nreq); else arity = REST_ARITY (nreq, SCM_BOOL_T); } else if (scm_is_true (alt)) arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound, SCM_MEMOIZED_ARGS (memoize (alt, env))); else arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound, SCM_BOOL_F); return MAKMEMO_LAMBDA (memoize (body, new_env), arity, SCM_EOL /* meta, filled in later */); } case SCM_EXPANDED_LET: { SCM vars, exps, body, varsv, inits, new_env; int i; vars = REF (exp, LET, GENSYMS); exps = REF (exp, LET, VALS); body = REF (exp, LET, BODY); varsv = scm_vector (vars); inits = scm_c_make_vector (VECTOR_LENGTH (varsv), SCM_BOOL_F); new_env = push_nested_link (varsv, capture_env (env)); for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++) VECTOR_SET (inits, i, memoize (CAR (exps), env)); return maybe_makmemo_capture_module (MAKMEMO_LET (inits, memoize (body, new_env)), env); } default: abort (); } }
static SCM eval (SCM x, SCM env) { SCM mx; SCM proc = SCM_UNDEFINED, args = SCM_EOL; unsigned int argc; loop: SCM_TICK; mx = SCM_MEMOIZED_ARGS (x); switch (SCM_I_INUM (SCM_CAR (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; int i; new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, env); for (i = 0; i < VECTOR_LENGTH (inits); i++) env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env)); env = new_env; x = CDR (mx); goto loop; } case SCM_M_LAMBDA: RETURN_BOOT_CLOSURE (mx, env); case SCM_M_CAPTURE_ENV: { SCM locs = CAR (mx); SCM new_env; int i; new_env = make_env (VECTOR_LENGTH (locs), SCM_BOOL_F, env); for (i = 0; i < VECTOR_LENGTH (locs); i++) { SCM loc = VECTOR_REF (locs, i); int depth, width; depth = SCM_I_INUM (CAR (loc)); width = SCM_I_INUM (CDR (loc)); env_set (new_env, 0, i, env_ref (env, depth, width)); } env = new_env; x = CDR (mx); goto loop; } case SCM_M_QUOTE: return mx; case SCM_M_CAPTURE_MODULE: return eval (mx, scm_current_module ()); 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_apply_0 (proc, args); case SCM_M_CALL: /* Evaluate the procedure to be applied. */ proc = EVAL1 (CAR (mx), env); argc = scm_ilength (CDR (mx)); mx = CDR (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_call_n (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_0 (producer); 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: { SCM pos; int depth, width; pos = mx; depth = SCM_I_INUM (CAR (pos)); width = SCM_I_INUM (CDR (pos)); return env_ref (env, depth, width); } case SCM_M_LEXICAL_SET: { SCM pos; int depth, width; SCM val = EVAL1 (CDR (mx), env); pos = CAR (mx); depth = SCM_I_INUM (CAR (pos)); width = SCM_I_INUM (CDR (pos)); env_set (env, depth, width, val); return SCM_UNSPECIFIED; } case SCM_M_BOX_REF: { SCM box = mx; return scm_variable_ref (EVAL1 (box, env)); } case SCM_M_BOX_SET: { SCM box = CAR (mx), val = CDR (mx); return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env)); } case SCM_M_RESOLVE: if (SCM_VARIABLEP (mx)) return mx; else { SCM var; var = scm_sys_resolve_variable (mx, env_tail (env)); scm_set_cdr_x (x, var); return var; } case SCM_M_CALL_WITH_PROMPT: { struct scm_vm *vp; SCM k, handler, res; scm_i_jmp_buf registers; scm_t_ptrdiff saved_stack_depth; k = EVAL1 (CAR (mx), env); handler = EVAL1 (CDDR (mx), env); vp = scm_the_vm (); saved_stack_depth = vp->stack_top - vp->sp; /* Push the prompt onto the dynamic stack. */ scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack, SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY, k, vp->stack_top - vp->fp, saved_stack_depth, vp->ip, ®isters); if (SCM_I_SETJMP (registers)) { /* The prompt exited nonlocally. */ scm_gc_after_nonlocal_exit (); proc = handler; args = scm_i_prompt_pop_abort_args_x (vp, saved_stack_depth); goto apply_proc; } res = scm_call_0 (eval (CADR (mx), env)); scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack); return res; } default: abort (); } }
/*! \brief Main Scheme(GUILE) program function. * \par Function Description * This function is the main program called from scm_boot_guile. * It handles initializing all libraries and gSchem variables * and passes control to the gtk main loop. */ void main_prog(void *closure, int argc, char *argv[]) { int i; char *cwd = NULL; GSCHEM_TOPLEVEL *w_current = NULL; char *input_str = NULL; int argv_index; int first_page = 1; char *filename; SCM scm_tmp; #ifdef HAVE_GTHREAD /* Gschem isn't threaded, but some of GTK's file chooser * backends uses threading so we need to call g_thread_init(). * GLib requires threading be initialised before any other GLib * functions are called. Do it now if its not already setup. */ if (!g_thread_supported ()) g_thread_init (NULL); #endif #if ENABLE_NLS /* this should be equivalent to setlocale (LC_ALL, "") */ gtk_set_locale(); /* This must be the same for all locales */ setlocale(LC_NUMERIC, "C"); /* Disable gtk's ability to set the locale. */ /* If gtk is allowed to set the locale, then it will override the */ /* setlocale for LC_NUMERIC (which is important for proper PS output. */ /* This may look funny here, given we make a call to gtk_set_locale() */ /* above. I don't know yet, if this is really the right thing to do. */ gtk_disable_setlocale(); #endif gtk_init(&argc, &argv); argv_index = parse_commandline(argc, argv); cwd = g_get_current_dir(); libgeda_init(); /* create log file right away even if logging is enabled */ s_log_init ("gschem"); s_log_message( _("gEDA/gschem version %s%s.%s\n"), PREPEND_VERSION_STRING, PACKAGE_DOTTED_VERSION, PACKAGE_DATE_VERSION); s_log_message( _("gEDA/gschem comes with ABSOLUTELY NO WARRANTY; see COPYING for more details.\n")); s_log_message( _("This is free software, and you are welcome to redistribute it under certain\n")); s_log_message( _("conditions; please see the COPYING file for more details.\n\n")); #if defined(__MINGW32__) && defined(DEBUG) fprintf(stderr, _("This is the MINGW32 port.\n")); #endif #if DEBUG fprintf(stderr, _("Current locale settings: %s\n"), setlocale(LC_ALL, NULL)); #endif /* init global buffers */ o_buffer_init(); /* register guile (scheme) functions */ g_register_funcs(); g_init_window (); g_init_select (); g_init_hook (); g_init_attrib (); g_init_keys (); g_init_util (); /* initialise color map (need to do this before reading rc files */ x_color_init (); o_undo_init(); if (s_path_sys_data () == NULL) { const gchar *message = _("You must set the GEDADATA environment variable!\n\n" "gschem cannot locate its data files. You must set the GEDADATA\n" "environment variable to point to the correct location.\n"); GtkWidget* error_diag = gtk_message_dialog_new (NULL, 0, GTK_MESSAGE_ERROR, GTK_BUTTONS_OK, "%s", message); gtk_dialog_run (GTK_DIALOG (error_diag)); g_error ("%s", message); } /* Allocate w_current */ w_current = gschem_toplevel_new (); /* Connect hooks that run for each s_toplevel_new() first */ s_toplevel_append_new_hook ((NewToplevelFunc) add_libgeda_toplevel_hooks, w_current); w_current->toplevel = s_toplevel_new (); w_current->toplevel->load_newer_backup_func = x_fileselect_load_backup; w_current->toplevel->load_newer_backup_data = w_current; o_text_set_rendered_bounds_func (w_current->toplevel, o_text_get_rendered_bounds, w_current); /* Damage notifications should invalidate the object on screen */ o_add_change_notify (w_current->toplevel, (ChangeNotifyFunc) o_invalidate, (ChangeNotifyFunc) o_invalidate, w_current); scm_dynwind_begin (0); g_dynwind_window (w_current); /* Run pre-load Scheme expressions */ g_scm_eval_protected (s_pre_load_expr, scm_current_module ()); /* By this point, libgeda should have setup the Guile load path, so * we can take advantage of that. */ scm_tmp = scm_sys_search_load_path (scm_from_utf8_string ("gschem.scm")); if (scm_is_false (scm_tmp)) { s_log_message (_("Couldn't find init scm file [%s]\n"), "gschem.scm"); } input_str = scm_to_utf8_string (scm_tmp); if (g_read_file(w_current->toplevel, input_str, NULL)) { s_log_message(_("Read init scm file [%s]\n"), input_str); } else { /*! \todo These two messages are the same. Should be * integrated. */ s_log_message(_("Failed to read init scm file [%s]\n"), input_str); } free (input_str); /* M'allocated by scm_to_utf8_string() */ scm_remember_upto_here_1 (scm_tmp); /* Now read in RC files. */ g_rc_parse_gtkrc(); x_rc_parse_gschem (w_current, rc_filename); /* Set default icon */ x_window_set_default_icon(); /* At end, complete set up of window. */ x_color_allocate(); x_window_setup (w_current); #ifdef HAVE_LIBSTROKE x_stroke_init (); #endif /* HAVE_LIBSTROKE */ for (i = argv_index; i < argc; i++) { if (g_path_is_absolute(argv[i])) { /* Path is already absolute so no need to do any concat of cwd */ filename = g_strdup (argv[i]); } else { filename = g_build_filename (cwd, argv[i], NULL); } if ( first_page ) first_page = 0; /* * SDB notes: at this point the filename might be unnormalized, like * /path/to/foo/../bar/baz.sch. Bad filenames will be normalized in * f_open (called by x_window_open_page). This works for Linux and MINGW32. */ x_window_open_page(w_current, filename); g_free (filename); } g_free(cwd); /* If no page has been loaded (wasn't specified in the command line.) */ /* Then create an untitled page */ if ( first_page ) { x_window_open_page( w_current, NULL ); } /* Update the window to show the current page */ x_window_set_current_page( w_current, w_current->toplevel->page_current ); #if DEBUG scm_c_eval_string ("(display \"hello guile\n\")"); #endif /* Run post-load expressions */ g_scm_eval_protected (s_post_load_expr, scm_current_module ()); /* open up log window on startup */ if (w_current->log_window == MAP_ON_STARTUP) { x_log_open (); } /* if there were any symbols which had major changes, put up an error */ /* dialog box */ major_changed_dialog(w_current); scm_dynwind_end (); /* enter main loop */ gtk_main(); }
void main_prog(void *closure, int argc, char *argv[]) { int i; int argv_index; char *cwd; gchar *str; gchar *filename; TOPLEVEL *pr_current; /* set default output filename */ output_filename = g_strdup("output.net"); argv_index = parse_commandline(argc, argv); cwd = g_get_current_dir(); scm_set_program_arguments (argc, argv, NULL); /* this is a kludge to make sure that spice mode gets set */ /* Hacked by SDB to allow spice netlisters of arbitrary name * as long as they begin with "spice". For example, this spice * netlister is valid: "spice-sdb". */ if (guile_proc) { if (strncmp(guile_proc, "spice", 5) == 0) { netlist_mode = SPICE; } } libgeda_init(); /* create log file right away */ /* even if logging is enabled */ s_log_init ("gnetlist"); s_log_message("gEDA/gnetlist version %s%s.%s\n", PREPEND_VERSION_STRING, PACKAGE_DOTTED_VERSION, PACKAGE_DATE_VERSION); s_log_message ("gEDA/gnetlist comes with ABSOLUTELY NO WARRANTY; see COPYING for more details.\n"); s_log_message ("This is free software, and you are welcome to redistribute it under certain\n"); s_log_message ("conditions; please see the COPYING file for more details.\n\n"); #if defined(__MINGW32__) && defined(DEBUG) fprintf(stderr, "This is the MINGW32 port.\n\n"); #endif /* register guile (scheme) functions */ g_register_funcs(); pr_current = s_toplevel_new (); /* Evaluate Scheme expressions that need to be run before rc files * are loaded. */ scm_eval (pre_rc_list, scm_current_module ()); g_rc_parse (pr_current, argv[0], "gnetlistrc", rc_filename); /* immediately setup user params */ i_vars_set (pr_current); s_rename_init(); if(list_backends) { gnetlist_backends(pr_current); exit (0); } /* Evaluate the first set of Scheme expressions before we load any * schematic files */ scm_eval (pre_backend_list, scm_current_module ()); i = argv_index; while (argv[i] != NULL) { GError *err = NULL; if (g_path_is_absolute(argv[i])) { /* Path is already absolute so no need to do any concat of cwd */ filename = g_strdup (argv[i]); } else { filename = g_build_filename (cwd, argv[i], NULL); } if (!quiet_mode) { s_log_message ("Loading schematic [%s]\n", filename); printf ("Loading schematic [%s]\n", filename); } s_page_goto (pr_current, s_page_new (pr_current, filename)); if (!f_open (pr_current, pr_current->page_current, filename, &err)) { g_warning ("%s\n", err->message); fprintf (stderr, "%s\n", err->message); g_error_free (err); } /* collect input filenames for backend use */ input_files = g_slist_append(input_files, argv[i]); i++; g_free (filename); } /* Change back to the directory where we started. This is done */ /* since gnetlist is a command line utility and will deposit its output */ /* in the current directory. Having the output go to a different */ /* directory will confuse the user (confused me, at first). */ if (chdir (cwd)) { /* Error occured with chdir */ #warning FIME: What do we do? } /* free(cwd); - Defered; see below */ if (argv[argv_index] == NULL) { fprintf (stderr, "ERROR: No schematics files specified for processing.\n"); fprintf (stderr, "\nRun `%s --help' for more information.\n", argv[0]); exit (1); } g_set_project_current(pr_current); #if DEBUG s_page_print_all(pr_current); #endif /* Load basic gnetlist functions */ scm_primitive_load_path (scm_from_utf8_string ("gnetlist.scm")); if (guile_proc) { SCM s_backend_path; /* Search for backend scm file in load path */ str = g_strdup_printf("gnet-%s.scm", guile_proc); s_backend_path = scm_sys_search_load_path (scm_from_locale_string (str)); g_free (str); /* If it couldn't be found, fail. */ if (scm_is_false (s_backend_path)) { fprintf (stderr, "ERROR: Could not find backend `%s' in load path.\n", guile_proc); fprintf (stderr, "\nRun `%s --list-backends' for a full list of available backends.\n", argv[0]); exit (1); } /* Load backend code. */ scm_primitive_load (s_backend_path); /* Evaluate second set of Scheme expressions. */ scm_eval (post_backend_list, scm_current_module ()); } s_traverse_init(); s_traverse_start(pr_current); /* Change back to the directory where we started AGAIN. This is done */ /* because the s_traverse functions can change the Current Working Directory. */ if (chdir (cwd)) { /* Error occured with chdir */ #warning FIXME: What do we do? } g_free(cwd); /* Run post-traverse code. */ scm_primitive_load_path (scm_from_utf8_string ("gnetlist-post.scm")); if (guile_proc) { /* check size here hack */ str = g_strdup_printf ("(%s \"%s\")", guile_proc, output_filename); scm_c_eval_string (str); g_free (str); /* gh_eval_str_with_stack_saving_handler (input_str); */ } else if (interactive_mode) { scm_c_eval_string ("(set-repl-prompt! \"gnetlist> \")"); scm_shell (0, NULL); } else { fprintf(stderr, "You gave neither backend to execute nor interactive mode!\n"); } gnetlist_quit(); }
static SCM memoize (SCM exp, SCM env) { if (!SCM_EXPANDED_P (exp)) abort (); switch (SCM_EXPANDED_TYPE (exp)) { case SCM_EXPANDED_VOID: return MAKMEMO_QUOTE (SCM_UNSPECIFIED); case SCM_EXPANDED_CONST: return MAKMEMO_QUOTE (REF (exp, CONST, EXP)); case SCM_EXPANDED_PRIMITIVE_REF: if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME)); else return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME), SCM_BOOL_F); case SCM_EXPANDED_LEXICAL_REF: return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env)); case SCM_EXPANDED_LEXICAL_SET: return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env), memoize (REF (exp, LEXICAL_SET, EXP), env)); case SCM_EXPANDED_MODULE_REF: return MAKMEMO_MOD_REF (REF (exp, MODULE_REF, MOD), REF (exp, MODULE_REF, NAME), REF (exp, MODULE_REF, PUBLIC)); case SCM_EXPANDED_MODULE_SET: return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env), REF (exp, MODULE_SET, MOD), REF (exp, MODULE_SET, NAME), REF (exp, MODULE_SET, PUBLIC)); case SCM_EXPANDED_TOPLEVEL_REF: return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME)); case SCM_EXPANDED_TOPLEVEL_SET: return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME), memoize (REF (exp, TOPLEVEL_SET, EXP), env)); case SCM_EXPANDED_TOPLEVEL_DEFINE: return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME), memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env)); case SCM_EXPANDED_CONDITIONAL: return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env), memoize (REF (exp, CONDITIONAL, CONSEQUENT), env), memoize (REF (exp, CONDITIONAL, ALTERNATE), env)); case SCM_EXPANDED_CALL: { SCM proc, args; proc = REF (exp, CALL, PROC); args = memoize_exps (REF (exp, CALL, ARGS), env); return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args); } case SCM_EXPANDED_PRIMCALL: { SCM name, args; int nargs; name = REF (exp, PRIMCALL, NAME); args = memoize_exps (REF (exp, PRIMCALL, ARGS), env); nargs = scm_ilength (args); if (nargs == 3 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt"))) return MAKMEMO_CALL_WITH_PROMPT (CAR (args), CADR (args), CADDR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("apply"))) return MAKMEMO_APPLY (CAR (args), CADR (args)); else if (nargs == 1 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-current-continuation"))) return MAKMEMO_CONT (CAR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("call-with-values"))) return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args)); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("wind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("unwind"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL); else if (nargs == 2 && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args); else if (nargs == 0 && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid"))) return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL); else if (scm_is_eq (scm_current_module (), scm_the_root_module ())) return MAKMEMO_CALL (MAKMEMO_TOP_REF (name), nargs, args); else return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name, SCM_BOOL_F), nargs, args); } case SCM_EXPANDED_SEQ: return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env), memoize (REF (exp, SEQ, TAIL), env)); case SCM_EXPANDED_LAMBDA: /* The body will be a lambda-case or #f. */ { SCM meta, docstring, body, proc; meta = REF (exp, LAMBDA, META); docstring = scm_assoc_ref (meta, scm_sym_documentation); body = REF (exp, LAMBDA, BODY); if (scm_is_false (body)) /* Give a body to case-lambda with no clauses. */ proc = MAKMEMO_LAMBDA (MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, scm_from_latin1_symbol ("throw"), SCM_BOOL_F), 5, scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key), MAKMEMO_QUOTE (SCM_BOOL_F), MAKMEMO_QUOTE (scm_from_latin1_string ("Wrong number of arguments")), MAKMEMO_QUOTE (SCM_EOL), MAKMEMO_QUOTE (SCM_BOOL_F))), FIXED_ARITY (0), SCM_BOOL_F /* docstring */); else proc = memoize (body, env); if (scm_is_string (docstring)) { SCM args = SCM_MEMOIZED_ARGS (proc); SCM_SETCAR (SCM_CDR (args), docstring); } return proc; } case SCM_EXPANDED_LAMBDA_CASE: { SCM req, rest, opt, kw, inits, vars, body, alt; SCM walk, minits, arity, new_env; int nreq, nopt, ntotal; req = REF (exp, LAMBDA_CASE, REQ); rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST))); opt = REF (exp, LAMBDA_CASE, OPT); kw = REF (exp, LAMBDA_CASE, KW); inits = REF (exp, LAMBDA_CASE, INITS); vars = REF (exp, LAMBDA_CASE, GENSYMS); body = REF (exp, LAMBDA_CASE, BODY); alt = REF (exp, LAMBDA_CASE, ALTERNATE); nreq = scm_ilength (req); nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0; ntotal = scm_ilength (vars); /* The vars are the gensyms, according to the divine plan. But we need to memoize the inits within their appropriate environment, complicating things. */ new_env = env; for (walk = req; scm_is_pair (walk); walk = CDR (walk), vars = CDR (vars)) new_env = scm_cons (CAR (vars), new_env); minits = SCM_EOL; for (walk = opt; scm_is_pair (walk); walk = CDR (walk), vars = CDR (vars), inits = CDR (inits)) { minits = scm_cons (memoize (CAR (inits), new_env), minits); new_env = scm_cons (CAR (vars), new_env); } if (scm_is_true (rest)) { new_env = scm_cons (CAR (vars), new_env); vars = CDR (vars); } for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits)) { minits = scm_cons (memoize (CAR (inits), new_env), minits); new_env = scm_cons (CAR (vars), new_env); } if (!scm_is_null (vars)) abort (); minits = scm_reverse_x (minits, SCM_UNDEFINED); if (scm_is_true (kw)) { /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */ SCM aok = CAR (kw), indices = SCM_EOL; for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw)) { SCM k; int idx; k = CAR (CAR (kw)); idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env); indices = scm_acons (k, SCM_I_MAKINUM (idx), indices); } kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED)); } if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt)) { if (scm_is_false (rest)) arity = FIXED_ARITY (nreq); else arity = REST_ARITY (nreq, SCM_BOOL_T); } else if (scm_is_true (alt)) arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_MEMOIZED_ARGS (memoize (alt, env))); else arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F); return MAKMEMO_LAMBDA (memoize (body, new_env), arity, SCM_BOOL_F /* docstring */); } case SCM_EXPANDED_LET: { SCM vars, exps, body, inits, new_env; vars = REF (exp, LET, GENSYMS); exps = REF (exp, LET, VALS); body = REF (exp, LET, BODY); inits = SCM_EOL; new_env = env; for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps)) { new_env = scm_cons (CAR (vars), new_env); inits = scm_cons (memoize (CAR (exps), env), inits); } return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED), memoize (body, new_env)); } case SCM_EXPANDED_LETREC: { SCM vars, exps, body, undefs, new_env; int i, nvars, in_order_p; vars = REF (exp, LETREC, GENSYMS); exps = REF (exp, LETREC, VALS); body = REF (exp, LETREC, BODY); in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P)); nvars = i = scm_ilength (vars); undefs = SCM_EOL; new_env = env; for (; scm_is_pair (vars); vars = CDR (vars)) { new_env = scm_cons (CAR (vars), new_env); undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs); } if (in_order_p) { SCM body_exps = SCM_EOL, seq; for (; scm_is_pair (exps); exps = CDR (exps), i--) body_exps = scm_cons (MAKMEMO_LEX_SET (i-1, memoize (CAR (exps), new_env)), body_exps); seq = memoize (body, new_env); for (; scm_is_pair (body_exps); body_exps = CDR (body_exps)) seq = MAKMEMO_SEQ (CAR (body_exps), seq); return MAKMEMO_LET (undefs, seq); } else { SCM sets = SCM_EOL, inits = SCM_EOL, set_seq; for (; scm_is_pair (exps); exps = CDR (exps), i--) { sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars, MAKMEMO_LEX_REF (i-1)), sets); inits = scm_cons (memoize (CAR (exps), new_env), inits); } inits = scm_reverse_x (inits, SCM_UNDEFINED); sets = scm_reverse_x (sets, SCM_UNDEFINED); if (scm_is_null (sets)) return memoize (body, env); for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets); sets = CDR (sets)) set_seq = MAKMEMO_SEQ (CAR (sets), set_seq); return MAKMEMO_LET (undefs, MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq), memoize (body, new_env))); } } default: abort (); } }