static void
syntax_error (const char* const msg, const SCM form, const SCM expr)
{
SCM msg_string = scm_from_locale_string (msg);
SCM filename = SCM_BOOL_F;
SCM linenr = SCM_BOOL_F;
const char *format;
SCM args;
if (scm_is_pair (form))
{
filename = scm_source_property (form, scm_sym_filename);
linenr = scm_source_property (form, scm_sym_line);
}
if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
{
filename = scm_source_property (expr, scm_sym_filename);
linenr = scm_source_property (expr, scm_sym_line);
}
if (!SCM_UNBNDP (expr))
{
if (scm_is_true (filename))
{
format = "In file ~S, line ~S: ~A ~S in expression ~S.";
args = scm_list_5 (filename, linenr, msg_string, form, expr);
}
else if (scm_is_true (linenr))
{
format = "In line ~S: ~A ~S in expression ~S.";
args = scm_list_4 (linenr, msg_string, form, expr);
}
else
{
format = "~A ~S in expression ~S.";
args = scm_list_3 (msg_string, form, expr);
}
}
else
{
if (scm_is_true (filename))
{
format = "In file ~S, line ~S: ~A ~S.";
args = scm_list_4 (filename, linenr, msg_string, form);
}
else if (scm_is_true (linenr))
{
format = "In line ~S: ~A ~S.";
args = scm_list_3 (linenr, msg_string, form);
}
else
{
format = "~A ~S.";
args = scm_list_2 (msg_string, form);
}
}
scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
}
/*! \brief Add symbol-generating Scheme procedures to the library.
* \par Function Description
* Adds a source to the library based on Scheme procedures. See page
* \ref libscms for more information. Two procedures are required: \a
* listfunc must return a Scheme list of symbol names, and \a getfunc
* must return a string containing symbol data when passed a symbol
* name.
*
* \param listfunc A Scheme function returning a list of symbols.
* \param getfunc A Scheme function returning symbol data.
* \param name A descriptive name for the component source.
*
* \return The new CLibSource.
*/
const CLibSource *s_clib_add_scm (SCM listfunc, SCM getfunc, const gchar *name)
{
CLibSource *source;
gchar *realname;
if (name == NULL) {
s_log_message (_("Cannot add library: name not specified."));
return NULL;
}
realname = uniquify_source_name (name);
if (scm_is_false (scm_procedure_p (listfunc))
&& scm_is_false (scm_procedure_p (getfunc))) {
s_log_message (_("Cannot add Scheme-library [%1$s]: callbacks must be closures."),
realname);
return NULL;
}
source = g_new0 (CLibSource, 1);
source->type = CLIB_SCM;
source->name = realname;
source->list_fn = scm_gc_protect_object (listfunc);
source->get_fn = scm_gc_protect_object (getfunc);
refresh_scm (source);
clib_sources = g_list_prepend (clib_sources, source);
return source;
}
SCM ffmpeg_decode_audio_video(SCM scm_self)
{
SCM retval = SCM_BOOL_F;
struct ffmpeg_t *self = get_self(scm_self);
if (!is_input_context(self))
scm_misc_error("ffmpeg-decode-audio/video", "Attempt to read frame from FFmpeg output video", SCM_EOL);
while (scm_is_false(retval)) {
if (packet_empty(self)) read_packet(self);
int reading_cache = packet_empty(self);
if (self->pkt.stream_index == self->audio_stream_idx) {
av_frame_unref(self->audio_target_frame);
retval = decode_audio(self, &self->pkt, self->audio_target_frame);
} else if (self->pkt.stream_index == self->video_stream_idx) {
av_frame_unref(self->video_target_frame);
retval = decode_video(self, &self->pkt, self->video_target_frame);
} else
consume_packet_data(&self->pkt, self->pkt.size);
if (scm_is_false(retval) && reading_cache) break;
};
return retval;
}
static int
sf_close (SCM port)
{
SCM p = SCM_PACK (SCM_STREAM (port));
SCM f = SCM_SIMPLE_VECTOR_REF (p, 4);
if (scm_is_false (f))
return 0;
f = scm_call_0 (f);
errno = 0;
return scm_is_false (f) ? EOF : 0;
}
void run_hook(const char *hook_name, SCM args)
{
SCM hook_symb = scm_from_utf8_symbol(hook_name);
SCM hook = scm_eval(hook_symb, scm_interaction_environment());
if (scm_is_false(scm_defined_p(hook_symb, SCM_UNDEFINED))) {
fprintf(stderr, "error: %s undefined\n", hook_name);
return;
}
else if (scm_is_false(scm_hook_p(hook))) {
fprintf(stderr, "error: %s is not a hook!\n", hook_name);
return;
}
if (scm_is_false(scm_hook_empty_p(hook)))
scm_run_hook(hook, args);
}
static SCM
maybe_makmemo_capture_module (SCM exp, SCM env)
{
if (scm_is_false (env))
return MAKMEMO_CAPTURE_MODULE (exp);
return exp;
}
static void
env_link_add_flat_var (SCM env_link, SCM var, SCM pos)
{
SCM vars = env_link_vars (env_link);
if (scm_is_false (scm_assq (var, vars)))
scm_set_cdr_x (env_link, scm_acons (var, pos, vars));
}
static SCM
capture_env (SCM env)
{
if (scm_is_false (env))
return SCM_BOOL_T;
return env;
}
int test_cl_is_handle_p__true (void)
{
SCM handle = SCM_BOOL_T;
SCM ret = cl_is_handle_p(handle);
printf("test that cl_is_handle_p returns #f when not passed a handle: %d\n", ret);
return scm_is_false(ret);
}
/*! \brief Get the action position.
* \par Function Description
* Retrieves the current action position and stores it in \a x and \a
* y, optionally snapping it to the grid if \a snap is true. This
* should be interpreted as the position that the user was pointing
* with the mouse pointer when the current action was invoked. If
* there is no valid world position for the current action, returns
* FALSE without modifying the output variables.
*
* This should be used by actions implemented in C to figure out where
* on the schematic the user wants them to apply the action.
*
* See also the (gschem action) Scheme module.
*
* \param w_current Current gschem toplevel structure.
* \param x Location to store x coordinate.
* \param y Location to store y coordinate.
*
* \return TRUE if current action position is set, FALSE otherwise.
*/
gboolean
g_action_get_position (gboolean snap, int *x, int *y)
{
SCM s_action_position_proc;
SCM s_point;
GschemToplevel *w_current = g_current_window ();
g_assert (w_current);
/* Get the action-position procedure */
s_action_position_proc =
scm_variable_ref (scm_c_module_lookup (scm_c_resolve_module ("gschem action"),
"action-position"));
/* Retrieve the action position */
s_point = scm_call_0 (s_action_position_proc);
if (scm_is_false (s_point)) return FALSE;
if (x) {
*x = scm_to_int (scm_car (s_point));
if (snap) {
*x = snap_grid (w_current, *x);
}
}
if (y) {
*y = scm_to_int (scm_cdr (s_point));
if (snap) {
*y = snap_grid (w_current, *y);
}
}
return TRUE;
}
/* places a single char in the input buffer. */
static int
sf_fill_input (SCM port)
{
SCM p = SCM_PACK (SCM_STREAM (port));
SCM ans;
scm_t_port *pt;
ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char. */
if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
return EOF;
SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
pt = SCM_PTAB_ENTRY (port);
if (pt->encoding == NULL)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
*pt->read_buf = SCM_CHAR (ans);
pt->read_pos = pt->read_buf;
pt->read_end = pt->read_buf + 1;
return *pt->read_buf;
}
else
scm_ungetc_unlocked (SCM_CHAR (ans), port);
return SCM_CHAR (ans);
}
/***********************************************************
* gnc_ui_custom_report_edit_name
*
* open the custom report dialog and highlight the given
* report's name for editing.
***********************************************************/
void
gnc_ui_custom_report_edit_name (GncMainWindow * window, SCM scm_guid)
{
SCM is_custom_report;
CustomReportDialog *crd = gnc_ui_custom_report_internal (window);
GtkTreeModel *model;
GtkTreeIter iter;
GncGUID *guid;
gchar *guid_str;
gboolean valid_iter;
is_custom_report = scm_c_eval_string ("gnc:report-template-is-custom/template-guid?");
if (scm_is_false (scm_call_1 (is_custom_report, scm_guid)))
return;
guid = guid_malloc ();
guid_str = scm_to_utf8_string (scm_guid);
if (!string_to_guid (guid_str, guid))
goto cleanup;
/* Look up the row for the requested guid */
model = gtk_tree_view_get_model (GTK_TREE_VIEW (crd->reportview));
valid_iter = gtk_tree_model_get_iter_first (model, &iter);
while (valid_iter)
{
GValue value = { 0, };
GncGUID *row_guid;
gtk_tree_model_get_value (model, &iter, COL_NUM, &value);
row_guid = (GncGUID *) g_value_get_pointer (&value);
if (guid_equal (guid, row_guid))
{
/* We found the row for the requested guid
* Now let's set the report's name cell in edit mode
* so the user can edit the name.
*/
GtkTreePath *path;
GtkTreeSelection *selection = gtk_tree_view_get_selection (GTK_TREE_VIEW (crd->reportview));
gtk_tree_selection_select_iter (selection, &iter);
path = gtk_tree_model_get_path (model, &iter);
g_object_set(G_OBJECT(crd->namerenderer), "editable", TRUE, NULL);
gtk_tree_view_set_cursor_on_cell (GTK_TREE_VIEW (crd->reportview),
path, crd->namecol,
crd->namerenderer, TRUE);
break;
}
g_value_unset (&value);
valid_iter = gtk_tree_model_iter_next (model, &iter);
}
cleanup:
guid_free (guid);
}
/*! \brief Re-poll a scheme procedure for symbols.
* \par Function Description
* Calls a Scheme procedure to obtain a list of available symbols,
* and updates the source with the new list
*
* Private function used only in s_clib.c.
*/
static void refresh_scm (CLibSource *source)
{
SCM symlist;
SCM symname;
CLibSymbol *symbol;
char *tmp;
g_return_if_fail (source != NULL);
g_return_if_fail (source->type == CLIB_SCM);
/* Clear the current symbol list */
g_list_foreach (source->symbols, (GFunc) free_symbol, NULL);
g_list_free (source->symbols);
source->symbols = NULL;
symlist = scm_call_0 (source->list_fn);
if (scm_is_false (scm_list_p (symlist))) {
s_log_message (_("Failed to scan library [%1$s]: Scheme function returned non-list."),
source->name);
return;
}
while (!scm_is_null (symlist)) {
symname = SCM_CAR (symlist);
if (!scm_is_string (symname)) {
s_log_message (_("Non-string symbol name while scanning library [%1$s]"),
source->name);
} else {
symbol = g_new0 (CLibSymbol, 1);
symbol->source = source;
/* Need to make sure that the correct free() function is called
* on strings allocated by Guile. */
tmp = scm_to_utf8_string (symname);
symbol->name = g_strdup(tmp);
free (tmp);
/* Prepend because it's faster and it doesn't matter what order we
* add them. */
source->symbols = g_list_prepend (source->symbols, symbol);
}
symlist = SCM_CDR (symlist);
}
/* Now sort the list of symbols by name. */
source->symbols = g_list_sort (source->symbols,
(GCompareFunc) compare_symbol_name);
s_clib_flush_search_cache();
s_clib_flush_symbol_cache();
}
SCM
guile_lookup (const char *name)
{
SCM var;
var = scm_sym2var (scm_from_locale_symbol (name),
scm_current_module_lookup_closure (),
SCM_BOOL_F);
if (scm_is_false (var))
return SCM_UNDEFINED;
else
return scm_variable_ref (var);
};
/*!
* \brief Get the name of the RC filename being evaluated.
* \par Function Description
*
* Creates a Guile stack object, extracts the topmost frame from that
* stack and gets the sourcefile name.
*
* \returns If the interpreter can resolve the filename, returns a
* Scheme object with the full path to the RC file, otherwise #f
*/
SCM
g_rc_rc_filename()
{
SCM stack, frame, source;
stack = scm_make_stack (SCM_BOOL_T, SCM_EOL);
if (scm_is_false (stack)) {
return SCM_BOOL_F;
}
frame = scm_stack_ref (stack, scm_from_int(0));
if (scm_is_false (frame)) {
return SCM_BOOL_F;
}
source = scm_frame_source (frame);
if (scm_is_false (source)) {
return SCM_BOOL_F;
}
return scm_source_property (source, scm_sym_filename);
}
/* Free the smob. */
size_t
free_key_smob (SCM arg1)
{
struct key_data *data = _scm_to_key_data (arg1);
if (scm_is_false (data->parent))
{
/* It's safe to free the key only if it was not derived from some other
object and thereby does not share any resources with it. If the key
does have a parent then all the resources will be freed along with
it. */
ssh_key_free (data->ssh_key);
}
return 0;
}
void
scm_dynstack_push_dynamic_state (scm_t_dynstack *dynstack, SCM state,
scm_t_dynamic_state *dynamic_state)
{
scm_t_bits *words;
SCM state_box;
if (SCM_UNLIKELY (scm_is_false (scm_dynamic_state_p (state))))
scm_wrong_type_arg ("with-dynamic-state", 0, state);
state_box = scm_make_variable (scm_set_current_dynamic_state (state));
words = push_dynstack_entry (dynstack, SCM_DYNSTACK_TYPE_DYNAMIC_STATE, 0,
DYNAMIC_STATE_WORDS);
words[0] = SCM_UNPACK (state_box);
}
static SCM
scm_rexp_general_compile_once (rexp_t (*compile) (const uint8_t *pattern),
SCM pattern)
{
SCM buffers = scm_fluid_ref (_rexp_buffers ());
SCM my_rexp = scm_hash_ref (buffers, pattern, SCM_BOOL_F);
if (scm_is_false (my_rexp))
{
uint8_t *_pattern = (uint8_t *) scm_to_utf8_stringn (pattern, NULL);
rexp_t _re = compile (_pattern);
free (_pattern);
my_rexp = (_re == NULL) ? SCM_BOOL_F : scm_from_rexp_t (_re);
scm_hash_set_x (buffers, pattern, my_rexp);
}
return my_rexp;
}
int
xscm_val_to_int (SCM x)
{
if (SCM_UNBNDP (x))
return 0;
else if (scm_is_bool (x))
{
if (scm_is_false(x))
return 0;
else
return 1;
}
else if (scm_is_integer (x))
return scm_to_int (x);
return 0;
}
static SCM scm_launch_program(SCM prog)
{
scm_dynwind_begin(0);
char *c_path = scm_to_locale_string(scm_car(prog));
scm_dynwind_free(c_path);
fprintf(stderr, "launching program %s\n", c_path);
pid_t pid = fork();
if (pid == 0) {
if (scm_is_false(scm_execlp(scm_car(prog), prog))) {
perror("execl failed");
exit(2);
}
}
else {
fprintf(stderr, "launched %s as pid %d\n", c_path, pid);
}
scm_dynwind_end();
return SCM_UNSPECIFIED;
}
/*! \brief Load a subpage
*
* \par Function Description
* Implements s_hierarchy_down_schematic(), but without changing variables
* related to the UI.
*
* - Ensures a duplicate page is not loaded
* - Does not change the current page
* - Does not modify the most recent "up" page
*
* \param [in] page
* \param [in] filename
* \param [out] error
* \return A pointer to the subpage or NULL if an error occured.
*/
PAGE*
s_hierarchy_load_subpage (PAGE *page, const char *filename, GError **error)
{
char *string;
PAGE *subpage = NULL;
g_return_val_if_fail (filename != NULL, NULL);
g_return_val_if_fail (page != NULL, NULL);
SCM string_s = scm_call_1 (scm_c_public_ref ("geda library",
"get-source-library-file"),
scm_from_utf8_string (filename));
if (scm_is_false (string_s)) {
g_set_error (error,
EDA_ERROR,
EDA_ERROR_NOLIB,
_("Schematic not found in source library."));
} else {
string = scm_to_utf8_string (string_s);
gchar *normalized = f_normalize_filename (string, error);
subpage = s_page_search (page->toplevel, normalized);
if (subpage == NULL) {
int success;
subpage = s_page_new (page->toplevel, string);
success = f_open (page->toplevel, subpage, s_page_get_filename (subpage), error);
if (success) {
subpage->page_control = ++page_control_counter;
} else {
s_page_delete (page->toplevel, subpage);
subpage = NULL;
}
}
g_free (normalized);
}
return subpage;
}
SCM g_get_all_unique_nets(SCM scm_level)
{
SCM list = SCM_EOL;
SCM x = SCM_EOL;
NETLIST *nl_current;
CPINLIST *pl_current;
char *net_name;
SCM_ASSERT(scm_is_string (scm_level), scm_level, SCM_ARG1,
"gnetlist:get-all-unique-nets");
nl_current = netlist_head;
/* walk through the list of components, and through the list
* of individual pins on each, adding net names to the list
* being careful to ignore duplicates, and unconnected pins
*/
while (nl_current != NULL) {
pl_current = nl_current->cpins;
while (pl_current != NULL) {
if (pl_current->net_name) {
net_name = pl_current->net_name;
/* filter off unconnected pins */
if (strncmp(net_name, "unconnected_pin", 15) != 0) {
/* add the net name to the list */
/*printf("Got net: `%s'\n",net_name); */
x = scm_from_utf8_string (net_name);
if (scm_is_false (scm_member (x, list))) {
list = scm_cons (x, list);
}
}
}
pl_current = pl_current->next;
}
nl_current = nl_current->next;
}
return list;
}
//get scm symbols: scm_from_utf8_symbol(name)
SCM scm_connect_tls(SCM host, SCM port){
char hostbuf[256], portbuf[16];
//Assume the current locale is utf8, as the only function that lets
//use use our own buffers implicitly uses the current locale
if(!scm_is_string(host)){
scm_raise_error("wrong-type-arg", "expected string in position 1");
} else {
size_t len = scm_to_locale_stringbuf(host, hostbuf, 256);
if(len >= 256){
scm_raise_error("too-long", "hostname too long");
} else {
hostbuf[len] = '\0';
}
}
if(scm_is_string(port)){
//make sure port looks like a number
if(scm_is_false(scm_string_to_number(port, scm_from_int(10)))){
scm_raise_error("wrong-type-arg",
"expected number or number as string in position 2");
}
size_t len = scm_to_locale_stringbuf(port, portbuf, 32);
if(len >= 16){
scm_raise_error("out-of-range", "Maximum port number is 65535");
} else {
portbuf[len] = '\0';
}
} else if(scm_is_integer(port)){
uint16_t portno = scm_to_uint16(port);
snprintf(portbuf, 16, "%d", portno);
} else {
scm_raise_error("wrong-type-arg",
"expected number or number as string in position 2");
}
BIO *bio = connect_tls(hostbuf, portbuf);
if(!bio){
scm_raise_error("system-error", "Failed to make tls connection");
}
return scm_new_smob(tls_tag, (scm_t_bits)bio);
}
/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
* transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
* variable name is detected, an error is signalled. */
static void
transform_bindings (const SCM bindings, const SCM expr,
SCM *const names, SCM *const vars, SCM *const initptr)
{
SCM rnames = SCM_EOL;
SCM rvars = SCM_EOL;
SCM rinits = SCM_EOL;
SCM binding_idx = bindings;
for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
{
const SCM binding = CAR (binding_idx);
const SCM CDR_binding = CDR (binding);
const SCM name = CAR (binding);
ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rnames)),
s_duplicate_binding, name, expr);
rnames = scm_cons (name, rnames);
rvars = scm_cons (scm_gensym (SCM_UNDEFINED), rvars);
rinits = scm_cons (CAR (CDR_binding), rinits);
}
*names = scm_reverse_x (rnames, SCM_UNDEFINED);
*vars = scm_reverse_x (rvars, SCM_UNDEFINED);
*initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
}
/* given a net name, return all connections */
SCM g_get_all_connections(SCM scm_netname)
{
SCM list = SCM_EOL;
SCM x = SCM_EOL;
SCM is_member = SCM_EOL;
SCM connlist = SCM_EOL;
SCM pairlist = SCM_EOL;
NETLIST *nl_current;
CPINLIST *pl_current;
NET *n_current;
char *wanted_net_name;
char *net_name;
char *pin;
char *uref;
SCM_ASSERT(scm_is_string(scm_netname), scm_netname, SCM_ARG1,
"gnetlist:get-all-connections");
wanted_net_name = scm_to_utf8_string (scm_netname);
if (wanted_net_name == NULL) {
return list;
}
nl_current = netlist_head;
/* walk through the list of components, and through the list
* of individual pins on each, adding net names to the list
* being careful to ignore duplicates, and unconnected pins
*/
while (nl_current != NULL) {
pl_current = nl_current->cpins;
while (pl_current != NULL) {
if (pl_current->net_name) {
net_name = pl_current->net_name;
/* filter off unconnected pins */
if (strcmp(net_name, wanted_net_name) == 0) {
/* add the net name to the list */
#if DEBUG
printf("found net: `%s'\n", net_name);
#endif
n_current = pl_current->nets;
while (n_current != NULL) {
if (n_current->connected_to) {
pairlist = SCM_EOL;
pin = (char *) g_malloc(sizeof(char) *
strlen(n_current->
connected_to));
uref =
(char *) g_malloc(sizeof(char) *
strlen(n_current->
connected_to));
sscanf(n_current->connected_to,
"%s %s", uref, pin);
pairlist = scm_list_n (scm_from_utf8_string (uref),
scm_from_utf8_string (pin),
SCM_UNDEFINED);
x = pairlist;
is_member = scm_member(x, connlist);
if (scm_is_false (is_member)) {
connlist = scm_cons (pairlist, connlist);
}
g_free(uref);
g_free(pin);
}
n_current = n_current->next;
}
}
}
pl_current = pl_current->next;
}
nl_current = nl_current->next;
}
free (wanted_net_name);
return connlist;
}
/*!
* \brief Search for schematic associated source files and load them.
* \par Function Description
* This function searches the associated source file refered by the
* <B>filename</B> and loads it. If the <B>flag</B> is set to
* <B>HIERARCHY_NORMAL_LOAD</B> and the page is already in the list of
* pages it will return the <B>pid</B> of that page.
* If the <B>flag</B> is set to <B>HIERARCHY_FORCE_LOAD</B> then this
* function will load the page again with a new page id. The second case
* is mainly used by gnetlist where pushed down schematics MUST be unique.
*
* \param [in] toplevel The TOPLEVEL object.
* \param [in] filename Schematic file name.
* \param [in] parent The parent page of the schematic.
* \param [in] page_control
* \param [in] flag sets whether to force load
* \param [out] err Location to return a GError on failure.
* \return The page loaded, or NULL if failed.
*
* \note
* This function finds the associated source files and
* loads all up
* It only works for schematic files though
* this is basically push
* flag can either be HIERARCHY_NORMAL_LOAD or HIERARCHY_FORCE_LOAD
* flag is mainly used by gnetlist where pushed down schematics MUST be unique
*/
PAGE *
s_hierarchy_down_schematic_single(TOPLEVEL *toplevel, const gchar *filename,
PAGE *parent, int page_control, int flag,
GError **err)
{
gchar *string;
PAGE *found = NULL;
PAGE *forbear;
g_return_val_if_fail ((toplevel != NULL), NULL);
g_return_val_if_fail ((filename != NULL), NULL);
g_return_val_if_fail ((parent != NULL), NULL);
SCM string_s = scm_call_1 (scm_c_public_ref ("geda library",
"get-source-library-file"),
scm_from_utf8_string (filename));
if (scm_is_false (string_s)) {
g_set_error (err, EDA_ERROR, EDA_ERROR_NOLIB,
_("Schematic not found in source library."));
return NULL;
}
string = scm_to_utf8_string (string_s);
switch (flag) {
case HIERARCHY_NORMAL_LOAD:
{
gchar *filename = f_normalize_filename (string, NULL);
found = s_page_search (toplevel, filename);
g_free (filename);
if (found) {
/* check whether this page is in the parents list */
for (forbear = parent;
forbear != NULL && found->pid != forbear->pid && forbear->up >= 0;
forbear = s_page_search_by_page_id (toplevel->pages, forbear->up))
; /* void */
if (forbear != NULL && found->pid == forbear->pid) {
g_set_error (err, EDA_ERROR, EDA_ERROR_LOOP,
_("Hierarchy contains a circular dependency."));
return NULL; /* error signal */
}
s_page_goto (toplevel, found);
if (page_control != 0) {
found->page_control = page_control;
}
found->up = parent->pid;
g_free (string);
return found;
}
found = s_page_new (toplevel, string);
f_open (toplevel, found, s_page_get_filename (found), NULL);
}
break;
case HIERARCHY_FORCE_LOAD:
{
found = s_page_new (toplevel, string);
f_open (toplevel, found, s_page_get_filename (found), NULL);
}
break;
default:
g_return_val_if_reached (NULL);
}
if (page_control == 0) {
page_control_counter++;
found->page_control = page_control_counter;
} else {
found->page_control = page_control;
}
found->up = parent->pid;
g_free (string);
return found;
}
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 ();
}
}
/*! \brief Opens a new page from a file.
* \par Function Description
* This function opens the file whose name is <B>filename</B> in a
* new PAGE of <B>toplevel</B>.
*
* If there is no page for <B>filename</B> in <B>toplevel</B>'s list
* of pages, it creates a new PAGE, loads the file in it and returns
* a pointer on the new page. Otherwise it returns a pointer on the
* existing page.
*
* If the filename passed is NULL, this function creates an empty,
* untitled page. The name of the untitled page is build from
* configuration data ('untitled-name') and a counter for uniqueness.
*
* The opened page becomes the current page of <B>toplevel</B>.
*
* \param [in] w_current The toplevel environment.
* \param [in] filename The name of the file to open or NULL for a blank page.
* \returns A pointer on the new page.
*
* \bug This code should check to make sure any untitled filename
* does not conflict with a file on disk.
*/
PAGE*
x_window_open_page (GSCHEM_TOPLEVEL *w_current, const gchar *filename)
{
TOPLEVEL *toplevel = w_current->toplevel;
PAGE *old_current, *page;
gchar *fn;
g_return_val_if_fail (toplevel != NULL, NULL);
/* Generate untitled filename if none was specified */
if (filename == NULL) {
gchar *cwd, *tmp;
cwd = g_get_current_dir ();
tmp = g_strdup_printf ("%s_%d.sch",
toplevel->untitled_name,
++w_current->num_untitled);
fn = g_build_filename (cwd, tmp, NULL);
g_free(cwd);
g_free(tmp);
} else {
fn = g_strdup (filename);
}
/* Return existing page if it is already loaded */
page = s_page_search (toplevel, fn);
if ( page != NULL ) {
g_free(fn);
return page;
}
old_current = toplevel->page_current;
page = s_page_new (toplevel, fn);
s_page_goto (toplevel, page);
/* Load from file if necessary, otherwise just print a message */
if (filename != NULL) {
GError *err = NULL;
if (!quiet_mode)
s_log_message (_("Loading schematic [%s]\n"), fn);
if (!f_open (toplevel, page, (gchar *) fn, &err)) {
GtkWidget *dialog;
g_warning ("%s\n", err->message);
dialog = gtk_message_dialog_new (GTK_WINDOW (w_current->main_window),
GTK_DIALOG_DESTROY_WITH_PARENT,
GTK_MESSAGE_ERROR,
GTK_BUTTONS_CLOSE,
"%s",
err->message);
gtk_window_set_title (GTK_WINDOW (dialog), _("Failed to load file"));
gtk_dialog_run (GTK_DIALOG (dialog));
gtk_widget_destroy (dialog);
g_error_free (err);
} else {
gtk_recent_manager_add_item (recent_manager, g_filename_to_uri(fn, NULL, NULL));
}
} else {
if (!quiet_mode)
s_log_message (_("New file [%s]\n"),
toplevel->page_current->page_filename);
}
if (scm_is_false (scm_hook_empty_p (new_page_hook)))
scm_run_hook (new_page_hook,
scm_cons (g_make_page_smob (toplevel, page), SCM_EOL));
a_zoom_extents (w_current,
s_page_objects (toplevel->page_current),
A_PAN_DONT_REDRAW);
o_undo_savestate (w_current, UNDO_ALL);
if ( old_current != NULL )
s_page_goto (toplevel, old_current);
/* This line is generally un-needed, however if some code
* wants to open a page, yet not bring it to the front, it is
* needed needed to add it into the page manager. Otherwise,
* it will get done in x_window_set_current_page(...)
*/
x_pagesel_update (w_current); /* ??? */
g_free (fn);
return page;
}
/* Return a new string port with MODES. If STR is #f, a new backing
buffer is allocated; otherwise STR must be a string and a copy of it
serves as the buffer for the new port. */
SCM
scm_mkstrport (SCM pos, SCM str, long modes, const char *caller)
{
SCM z, buf;
scm_t_port *pt;
const char *encoding;
size_t read_buf_size, str_len, c_pos;
char *c_buf;
if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG)))
scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL);
encoding = scm_i_default_port_encoding ();
if (scm_is_false (str))
{
/* Allocate a new buffer to write to. */
str_len = INITIAL_BUFFER_SIZE;
buf = scm_c_make_bytevector (str_len);
c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
/* Reset `read_buf_size'. It will contain the actual number of
bytes written to the port. */
read_buf_size = 0;
c_pos = 0;
}
else
{
/* STR is a string. */
char *copy;
SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller);
/* Create a copy of STR in ENCODING. */
copy = scm_to_stringn (str, &str_len, encoding,
SCM_FAILED_CONVERSION_ERROR);
buf = scm_c_make_bytevector (str_len);
c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf);
memcpy (c_buf, copy, str_len);
free (copy);
c_pos = scm_to_unsigned_integer (pos, 0, str_len);
read_buf_size = str_len;
}
z = scm_c_make_port_with_encoding (scm_tc16_strport, modes,
encoding,
scm_i_default_port_conversion_handler (),
(scm_t_bits)buf);
pt = SCM_PTAB_ENTRY (z);
pt->write_buf = pt->read_buf = (unsigned char *) c_buf;
pt->read_pos = pt->write_pos = pt->read_buf + c_pos;
pt->read_buf_size = read_buf_size;
pt->write_buf_size = str_len;
pt->write_end = pt->read_end = pt->read_buf + pt->read_buf_size;
pt->rw_random = 1;
return z;
}
*
* \param target_s where to attach the new attribute.
* \param name_s name for the new attribute.
* \param value_s value for the new attribute.
* \param visible_s visibility of the new attribute (true or false).
* \param show_s the attribute part visibility setting.
*
* \return the newly created text object.
*/
SCM_DEFINE (add_attrib_x, "%add-attrib!", 5, 0, 0,
(SCM target_s, SCM name_s, SCM value_s, SCM visible_s, SCM show_s),
"Add an attribute to an object, or floating")
{
SCM_ASSERT ((edascm_is_page (target_s) ||
edascm_is_object (target_s) ||
scm_is_false (target_s)),
target_s, SCM_ARG1, s_add_attrib_x);
SCM_ASSERT (scm_is_string (name_s), name_s, SCM_ARG2, s_add_attrib_x);
SCM_ASSERT (scm_is_string (value_s), value_s, SCM_ARG3, s_add_attrib_x);
SCM_ASSERT (scm_is_symbol (show_s), show_s, SCM_ARG5, s_add_attrib_x);
GschemToplevel *w_current = g_current_window ();
TOPLEVEL *toplevel = gschem_toplevel_get_toplevel (w_current);
/* Check target object, if present */
OBJECT *obj = NULL;
if (edascm_is_object (target_s)) {
obj = edascm_to_object (target_s);
if (o_get_page (toplevel, obj) != toplevel->page_current) {
scm_error (object_state_sym,
s_add_attrib_x,
