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,