예제 #1
0
static SCM
ppscm_search_pp_list (SCM list, SCM value)
{
  SCM orig_list = list;

  if (scm_is_null (list))
    return SCM_BOOL_F;
  if (gdbscm_is_false (scm_list_p (list))) /* scm_is_pair? */
    {
      return ppscm_make_pp_type_error_exception
	(_("pretty-printer list is not a list"), list);
    }

  for ( ; scm_is_pair (list); list = scm_cdr (list))
    {
      SCM matcher = scm_car (list);
      SCM worker;
      pretty_printer_smob *pp_smob;

      if (!ppscm_is_pretty_printer (matcher))
	{
	  return ppscm_make_pp_type_error_exception
	    (_("pretty-printer list contains non-pretty-printer object"),
	     matcher);
	}

      pp_smob = (pretty_printer_smob *) SCM_SMOB_DATA (matcher);

      /* Skip if disabled.  */
      if (gdbscm_is_false (pp_smob->enabled))
	continue;

      if (!gdbscm_is_procedure (pp_smob->lookup))
	{
	  return ppscm_make_pp_type_error_exception
	    (_("invalid lookup object in pretty-printer matcher"),
	     pp_smob->lookup);
	}

      worker = gdbscm_safe_call_2 (pp_smob->lookup, matcher,
				   value, gdbscm_memory_error_p);
      if (!gdbscm_is_false (worker))
	{
	  if (gdbscm_is_exception (worker))
	    return worker;
	  if (ppscm_is_pretty_printer_worker (worker))
	    return worker;
	  return ppscm_make_pp_type_error_exception
	    (_("invalid result from pretty-printer lookup"), worker);
	}
    }

  if (!scm_is_null (list))
    {
      return ppscm_make_pp_type_error_exception
	(_("pretty-printer list is not a list"), orig_list);
    }

  return SCM_BOOL_F;
}
예제 #2
0
SCM
scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist)
{
  if (!SCM_UNBNDP (filename))
    {
      SCM old_alist = alist;

      /*
	have to extract the acons, and operate on that, for
	thread safety.
       */
      SCM last_acons = SCM_CDR (scm_last_alist_filename);
      if (scm_is_null (old_alist)
	  && scm_is_eq (SCM_CDAR (last_acons), filename))
	{
	  alist = last_acons;
	}
      else
	{
	  alist = scm_acons (scm_sym_filename, filename, alist);
	  if (scm_is_null (old_alist))
	    scm_set_cdr_x (scm_last_alist_filename, alist);
	}
    }
  
  SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops,
		       SRCPROPMAKPOS (line, col),
		       SCM_UNPACK (copy),
		       SCM_UNPACK (alist));
}
예제 #3
0
파일: expand.c 프로젝트: Card1nal/guile
static SCM
expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
{
  SCM test;
  const long length = scm_ilength (clause);
  ASSERT_SYNTAX (length >= 1, s_bad_cond_clause, clause);

  test = CAR (clause);
  if (scm_is_eq (test, scm_sym_else) && elp)
    {
      const int last_clause_p = scm_is_null (rest);
      ASSERT_SYNTAX (length >= 2, s_bad_cond_clause, clause);
      ASSERT_SYNTAX (last_clause_p, s_misplaced_else_clause, clause);
      return expand_sequence (CDR (clause), env);
    }

  if (scm_is_null (rest))
    rest = VOID (SCM_BOOL_F);
  else
    rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);

  if (length >= 2
      && scm_is_eq (CADR (clause), scm_sym_arrow)
      && alp)
    {
      SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
      SCM new_env = scm_acons (tmp, tmp, env);
      ASSERT_SYNTAX (length > 2, s_missing_recipient, clause);
      ASSERT_SYNTAX (length == 3, s_extra_expression, clause);
      return LET (SCM_BOOL_F,
                  scm_list_1 (tmp),
                  scm_list_1 (tmp),
                  scm_list_1 (expand (test, env)),
                  CONDITIONAL (SCM_BOOL_F,
                               LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
                               CALL (SCM_BOOL_F,
                                     expand (CADDR (clause), new_env),
                                     scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
                                                              tmp, tmp))),
                               rest));
    }
  /* FIXME length == 1 case */
  else
    return CONDITIONAL (SCM_BOOL_F,
                        expand (test, env),
                        expand_sequence (CDR (clause), env),
                        rest);
}
예제 #4
0
파일: expand.c 프로젝트: Card1nal/guile
static SCM
expand_let (SCM expr, SCM env)
{
  SCM bindings;

  const SCM cdr_expr = CDR (expr);
  const long length = scm_ilength (cdr_expr);
  ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
  ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);

  bindings = CAR (cdr_expr);
  if (scm_is_symbol (bindings))
    {
      ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
      return expand_named_let (expr, env);
    }

  check_bindings (bindings, expr);
  if (scm_is_null (bindings))
    return expand_sequence (CDDR (expr), env);
  else
    {
      SCM var_names, var_syms, inits;
      transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
      return LET (SCM_BOOL_F,
                  var_names, var_syms, expand_exprs (inits, env),
                  expand_sequence (CDDR (expr),
                                   expand_env_extend (env, var_names,
                                                      var_syms)));
    }
}
예제 #5
0
static SCM
decode_scm_col_list (GttGhtml *ghtml, SCM col_list)
{
	SCM col_name;
	char * tok = NULL;

	/* reset the parser */
	ghtml->ninvl_cols = 0;
	ghtml->ntask_cols = 0;
		
	while (!scm_is_null (col_list))
	{
		col_name = SCM_CAR (col_list);

		/* either a 'symbol or a "quoted string" */
		if (!scm_is_symbol(col_name) && !scm_is_string (col_name))
		{
			col_list = SCM_CDR (col_list);
			continue;
		}
		tok = scm_to_locale_string (col_name);
		decode_column (ghtml, tok);

		free (tok);
		col_list = SCM_CDR (col_list);
	}

	return SCM_UNSPECIFIED;
}
예제 #6
0
GList *
gnc_scm_list_to_glist(SCM rest)
{
    GList *result = NULL;
    SCM scm_item;

    SWIG_GetModule(NULL); /* Work-around for SWIG bug. */
    SCM_ASSERT(scm_is_list(rest), rest, SCM_ARG1, "gnc_scm_list_to_glist");

    while (!scm_is_null(rest))
    {
        void *item;

        scm_item = SCM_CAR(rest);
        rest = SCM_CDR(rest);

        if (scm_item == SCM_BOOL_F)
        {
            result = g_list_prepend(result, NULL);
        }
        else
        {
            if (!SWIG_IsPointer(scm_item))
                scm_misc_error("gnc_scm_list_to_glist",
                               "Item in list not a wcp.", scm_item);

            item = (void *)SWIG_PointerAddress(scm_item);
            result = g_list_prepend(result, item);
        }
    }

    return g_list_reverse(result);
}
예제 #7
0
파일: expand.c 프로젝트: Card1nal/guile
static SCM
expand_and (SCM expr, SCM env)
{
  const SCM cdr_expr = CDR (expr);

  if (scm_is_null (cdr_expr))
    return CONST (SCM_BOOL_F, SCM_BOOL_T);

  ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);

  if (scm_is_null (CDR (cdr_expr)))
    return expand (CAR (cdr_expr), env);
  else
    return CONDITIONAL (scm_source_properties (expr),
                        expand (CAR (cdr_expr), env),
                        expand_and (cdr_expr, env),
                        CONST (SCM_BOOL_F, SCM_BOOL_F));
}
예제 #8
0
파일: expand.c 프로젝트: Card1nal/guile
static SCM
expand_exprs (SCM forms, const SCM env)
{
  SCM ret = SCM_EOL;

  for (; !scm_is_null (forms); forms = CDR (forms))
    ret = scm_cons (expand (CAR (forms), env), ret);
  return scm_reverse_x (ret, SCM_UNDEFINED);
}
예제 #9
0
/********************************************************************
 * update_report_list
 *
 * this procedure does the real work of displaying a sorted list of
 * available custom reports
 ********************************************************************/
static void
update_report_list(GtkListStore *store, CustomReportDialog *crd)
{
    SCM get_rpt_guids = scm_c_eval_string("gnc:custom-report-template-guids");
    SCM template_menu_name = scm_c_eval_string("gnc:report-template-menu-name/report-guid");
    SCM rpt_guids;
    int i;
    GtkTreeIter iter;
    GtkTreeModel *model = GTK_TREE_MODEL (store);
    gboolean valid_iter;

    gtk_tree_sortable_set_sort_column_id(GTK_TREE_SORTABLE(store), COL_NAME, GTK_SORT_ASCENDING);

    crd->reportlist = scm_call_0(get_rpt_guids);
    rpt_guids = crd->reportlist;

    /* Empty current liststore */
    valid_iter = gtk_tree_model_get_iter_first (model, &iter);
    while (valid_iter)
    {
        GValue value = { 0, };
        GncGUID *row_guid;
        g_value_init ( &value, G_TYPE_POINTER);
        gtk_tree_model_get_value (model, &iter, COL_NUM, &value);
        row_guid = (GncGUID *) g_value_get_pointer (&value);
        guid_free (row_guid);
        g_value_unset (&value);
        valid_iter = gtk_tree_model_iter_next (model, &iter);
    }
    gtk_list_store_clear(store);

    if (scm_is_list(rpt_guids))
    {
        /* for all the report guids in the list, store them, with a reference,
        	 in the gtkliststore */
        for (i = 0; !scm_is_null(rpt_guids); i++)
        {
            GncGUID *guid = guid_malloc ();
            gchar *guid_str = scm_to_utf8_string (SCM_CAR(rpt_guids));
            gchar *name = gnc_scm_to_utf8_string (scm_call_2(template_menu_name, SCM_CAR(rpt_guids), SCM_BOOL_F));

            if (string_to_guid (guid_str, guid))
            {
                gtk_list_store_append(store, &iter);
                gtk_list_store_set(store, &iter,
                                   COL_NAME, name,
                                   COL_NUM, guid,
                                   -1);
            }
            g_free (name);
            g_free (guid_str);

            rpt_guids = SCM_CDR(rpt_guids);
        }
    }
}
예제 #10
0
파일: expand.c 프로젝트: Card1nal/guile
static SCM
expand_sequence (const SCM forms, const SCM env)
{
  ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
                 scm_cons (scm_sym_begin, forms));
  if (scm_is_null (CDR (forms)))
    return expand (CAR (forms), env);
  else
    return SEQ (scm_source_properties (forms),
                expand (CAR (forms), env),
                expand_sequence (CDR (forms), env));
}
예제 #11
0
파일: s_clib.c 프로젝트: peter-b/geda-gaf
/*! \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();
}
예제 #12
0
static void
gnc_style_sheet_select_dialog_fill(StyleSheetDialog * ss)
{
    SCM stylesheets = scm_c_eval_string("(gnc:get-html-style-sheets)");
    SCM sheet_info;

    /* pack it full of content */
    for (; !scm_is_null(stylesheets); stylesheets = SCM_CDR(stylesheets))
    {
        sheet_info = SCM_CAR(stylesheets);
        gnc_style_sheet_select_dialog_add_one(ss, sheet_info, FALSE);
    }
}
예제 #13
0
static int
more_specificp (SCM m1, SCM m2, SCM const *targs)
{
  register SCM s1, s2;
  register long i;
  /*
   * Note:
   *   m1 and m2 can have != length (i.e. one can be one element longer than the
   * other when we have a dotted parameter list). For instance, with the call
   *   (M 1)
   * with
   *   (define-method M (a . l) ....)
   *   (define-method M (a) ....)
   *
   * we consider that the second method is more specific.
   *
   * BTW, targs is an array of types. We don't need it's size since
   * we already know that m1 and m2 are applicable (no risk to go past
   * the end of this array).
   *
   */
  for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
    if (scm_is_null(s1)) return 1;
    if (scm_is_null(s2)) return 0;
    if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
      register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);

      for (l = CPL_OF (targs[i]);   ; l = SCM_CDR(l)) {
	if (scm_is_eq (cs1, SCM_CAR (l)))
	  return 1;
	if (scm_is_eq (cs2, SCM_CAR (l)))
	  return 0;
      }
      return 0;/* should not occur! */
    }
  }
  return 0; /* should not occur! */
}
예제 #14
0
파일: main.c 프로젝트: sph-mn/sph-lib
int scm_list_to_imht_set(SCM scm_a, imht_set_t **result) {
  int a_length = scm_to_uint32((scm_length(scm_a)));
  if (!imht_set_create((3 + a_length), result)) {
    return (1);
  };
  while (!scm_is_null(scm_a)) {
    if (!imht_set_add((*result), (scm_to_int((SCM_CAR(scm_a)))))) {
      imht_set_destroy((*result));
      return (2);
    };
    scm_a = SCM_CDR(scm_a);
  };
  return (0);
};
예제 #15
0
int scm_is_alist(SCM x) {
	SCM item;

	if (!scm_is_list(x))
		return 0;
	
	while (!scm_is_null(x)) {
		item = SCM_CAR(x);
		if (!scm_is_pair(item))
			return 0;
		x = SCM_CDR(x);
	}
	return 1;
}
예제 #16
0
/**************************************************************
 * custom_report_run_report
 *
 * this procedure sets up and calls the report on the scheme
 * side. This is what makes the report actually run.
 **************************************************************/
static void
custom_report_edit_report_name (SCM guid,
                                CustomReportDialog *crd,
                                gchar *new_name)
{
    SCM rename_report = scm_c_eval_string("gnc:rename-report");
    SCM new_name_scm = scm_from_utf8_string(new_name);

    if (scm_is_null(guid) || !new_name || (*new_name == '\0'))
        return;

    /* rename the report */
    scm_call_2(rename_report, guid, new_name_scm);
    update_report_list(GTK_LIST_STORE(gtk_tree_view_get_model(GTK_TREE_VIEW(crd->reportview))),
                       crd);

}
예제 #17
0
파일: expand.c 프로젝트: Card1nal/guile
static SCM
expand (SCM exp, SCM env)
{
  if (scm_is_pair (exp))
    {
      SCM car;
      scm_t_macro_primitive trans = NULL;
      SCM macro = SCM_BOOL_F;
      
      car = CAR (exp);
      if (scm_is_symbol (car))
        macro = expand_env_ref_macro (env, car);
      
      if (scm_is_true (macro))
        trans = scm_i_macro_primitive (macro);

      if (trans)
        return trans (exp, env);
      else
        {
          SCM arg_exps = SCM_EOL;
          SCM args = SCM_EOL;
          SCM proc = CAR (exp);
          
          for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
               arg_exps = CDR (arg_exps))
            args = scm_cons (expand (CAR (arg_exps), env), args);
          if (scm_is_null (arg_exps))
            return CALL (scm_source_properties (exp),
                         expand (proc, env),
                         scm_reverse_x (args, SCM_UNDEFINED));
          else
            syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
        }
    }
  else if (scm_is_symbol (exp))
    {
      SCM gensym = expand_env_lexical_gensym (env, exp);
      if (scm_is_true (gensym))
        return LEXICAL_REF (SCM_BOOL_F, exp, gensym);
      else
        return TOPLEVEL_REF (SCM_BOOL_F, exp);
    }
  else
    return CONST (SCM_BOOL_F, exp);
}
예제 #18
0
void
custom_report_name_edited_cb(GtkCellRendererText *renderer, gchar *path, gchar *new_text, gpointer data)
{
    CustomReportDialog *crd = data;
    SCM guid = get_custom_report_selection(crd, _("Unable to change report configuration name."));
    SCM unique_name_func = scm_c_eval_string("gnc:report-template-has-unique-name?");
    SCM new_name_scm = scm_from_utf8_string(new_text);

    g_object_set(G_OBJECT(crd->namerenderer), "editable", FALSE, NULL);
    if (scm_is_null (guid))
        return;

    if (scm_is_true (scm_call_2 (unique_name_func, guid, new_name_scm)))
        custom_report_edit_report_name (guid, crd, new_text);
    else
        gnc_error_dialog (GTK_WINDOW (crd->dialog), "%s",
                          _("A saved report configuration with this name already exists, please choose another name.") );
}
예제 #19
0
static SCM pg_map_rows(SCM res, SCM rest) {
	struct pg_res *pgr;
	SCM bag, row;
	scm_assert_smob_type(pg_res_tag, res);
	bag = row = SCM_EOL;
	pgr = (struct pg_res *)SCM_SMOB_DATA(res);
	while (pgr->cursor < pgr->tuples) {
		row = build_row(pgr);
		if (!scm_is_null(rest))
			bag = scm_cons(scm_call_1(SCM_CAR(rest), row), bag);
		else bag = scm_cons(row, bag);
		pgr->cursor++;
		}
	PQclear(pgr->res);
	pgr->res = NULL;
	bag = scm_reverse(bag);
	scm_remember_upto_here_2(bag, row);
	scm_remember_upto_here_2(res, rest);
	return bag;
	}
예제 #20
0
/*********************************************************************
 * custom_report_delete
 *
 * this will delete the report, update the reports list and leave the
 * dialog active for additional usage.
 *********************************************************************/
static void
custom_report_delete (SCM guid, CustomReportDialog *crd)
{
    SCM template_menu_name = scm_c_eval_string("gnc:report-template-menu-name/report-guid");
    gchar *report_name;

    if (scm_is_null (guid))
        return;

    report_name = gnc_scm_to_utf8_string(scm_call_2(template_menu_name, guid, SCM_BOOL_F));

    /* we must confirm the user wants to delete their precious custom report! */
    if (gnc_verify_dialog( GTK_WINDOW (crd->dialog), FALSE, _("Are you sure you want to delete %s?"), report_name))
    {
        SCM del_report = scm_c_eval_string("gnc:delete-report");
        scm_call_1(del_report, guid);
        update_report_list(GTK_LIST_STORE(gtk_tree_view_get_model(GTK_TREE_VIEW(crd->reportview))),
                           crd);
    }
    g_free (report_name);
}
예제 #21
0
파일: expand.c 프로젝트: Card1nal/guile
/* Check if the format of the bindings is ((<symbol> <init-form>) ...).  */
static void
check_bindings (const SCM bindings, const SCM expr)
{
  SCM binding_idx;

  ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
                   s_bad_bindings, bindings, expr);

  binding_idx = bindings;
  for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
    {
      SCM name;         /* const */

      const SCM binding = CAR (binding_idx);
      ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
                       s_bad_binding, binding, expr);

      name = CAR (binding);
      ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
    }
}
예제 #22
0
GSList *
gnc_scm_to_gslist_string(SCM list)
{
    GSList *gslist = NULL;

    while (!scm_is_null (list))
    {
        if (scm_is_string(SCM_CAR(list)))
        {
            gchar * str;

            str = gnc_scm_to_locale_string (SCM_CAR(list));
            if (str)
                gslist = g_slist_prepend (gslist, g_strdup (str));
            g_free (str);
        }
        list = SCM_CDR (list);
    }

    return g_slist_reverse (gslist);
}
예제 #23
0
SCM
scm_find_method (SCM l)
#define FUNC_NAME "find-method"
{
  SCM gf;
  long len = scm_ilength (l);

  if (len == 0)
    SCM_WRONG_NUM_ARGS ();

  scm_c_issue_deprecation_warning
    ("scm_find_method is deprecated.  Use `compute-applicable-methods' "
     "from Scheme instead.");

  gf = SCM_CAR(l); l = SCM_CDR(l);
  SCM_VALIDATE_GENERIC (1, gf);
  if (scm_is_null (scm_slot_ref (gf, scm_from_latin1_symbol ("methods"))))
    SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));

  return scm_compute_applicable_methods (gf, l, len - 1, 1);
}
예제 #24
0
/**************************************************************
 * custom_report_run_report
 *
 * this procedure sets up and calls the report on the scheme
 * side. This is what makes the report actually run.
 **************************************************************/
static void
custom_report_run_report(SCM guid,
                         CustomReportDialog *crd)
{
    SCM make_report = scm_c_eval_string("gnc:make-report");
    int report_id;
    GncMainWindow *window = crd->window;

    if (scm_is_null(guid))
        return;

    /* this generates the report */
    report_id = scm_to_int (scm_call_1(make_report, guid));

    /* do this *before* displaying the report because sometimes that
         takes a while... */
    custom_report_dialog_close_cb(NULL, crd);

    /* display the report */
    gnc_main_window_open_report(report_id, window);

}
예제 #25
0
/*
 *  Recursive routine.  It calls itself for list values and calls
 *  "do_substitution" for string values.  Each substitution will
 *  be done in the order found in the tree walk of list values.
 *  The "match" and "repl" trees *must* be identical in structure.
 */
LOCAL void
do_multi_subs(char ** ppzStr, ssize_t * pStrLen, SCM match, SCM repl)
{
    char * pzStr = *ppzStr;
    char * pzNxt = pzStr;

    /*
     *  Loop for as long as our list has more entries
     */
    while (! scm_is_null(match)) {
        /*
         *  "CAR" is the current value, "CDR" is rest of list
         */
        SCM  matchCar  = SCM_CAR(match);
        SCM  replCar   = SCM_CAR(repl);

        match = SCM_CDR(match);
        repl  = SCM_CDR(repl);

        if (AG_SCM_STRING_P(matchCar)) {
            do_substitution(pzStr, *pStrLen, matchCar, replCar,
                            &pzNxt, pStrLen);

            // coverity[use_after_free] -- invalid alias analysis
            pzStr = pzNxt;
        }

        else if (AG_SCM_LIST_P(matchCar))
            do_multi_subs(&pzStr, pStrLen, matchCar, replCar);

        else
            /*
             *  Whatever it is it is not part of what we would expect.  Bail.
             */
            break;
    }

    *ppzStr = pzStr;
}
예제 #26
0
파일: expand.c 프로젝트: Card1nal/guile
static SCM
expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
{
  if (scm_is_null (bindings))
    return expand_sequence (body, env);
  else
    {
      SCM bind, name, sym, init;

      ASSERT_SYNTAX (scm_is_pair (bindings), s_bad_expression, bindings);
      bind = CAR (bindings);
      ASSERT_SYNTAX (scm_ilength (bind) == 2, s_bad_binding, bind);
      name = CAR (bind);
      sym = scm_gensym (SCM_UNDEFINED);
      init = CADR (bind);
      
      return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym),
                  scm_list_1 (expand (init, env)),
                  expand_letstar_clause (CDR (bindings), body,
                                         scm_acons (name, sym, env)));
    }
}
예제 #27
0
파일: cache.c 프로젝트: pmyadlowsky/gusher
static SCM touch_node(SCM doc, SCM args) {
	MAKE_NODE *node;
	node = (MAKE_NODE *)SCM_SMOB_DATA(doc);
	scm_lock_mutex(node->mutex);
	invalidate(node);
	if (scm_is_null(args)) {
		scm_unlock_mutex(node->mutex);
		return SCM_BOOL_T;
		}
	switch (node->type) {
	case TYPE_DATUM:
		node->payload = SCM_CAR(args);
		break;
	case TYPE_FILE:
		free(node->filepath);
		node->filepath = scm_to_locale_string(SCM_CAR(args));
		break;
		}
	scm_unlock_mutex(node->mutex);
	scm_remember_upto_here_2(doc, args);
	return SCM_BOOL_T;
	}
예제 #28
0
static SCM pg_format_sql(SCM conn, SCM obj) {
	struct pg_conn *pgc;
	SCM out;
	if (SCM_SMOB_PREDICATE(time_tag, obj)) {
		out = format_time(obj, c2s("'%Y-%m-%d %H:%M:%S'"));
		}
	else if (scm_boolean_p(obj) == SCM_BOOL_T) {
		if (scm_is_true(obj)) out = c2s("'t'");
		else out = c2s("'f'");
		}
	else if (scm_is_number(obj)) {
		out = scm_number_to_string(obj,
			scm_from_signed_integer(10));
		}
	else if (scm_is_symbol(obj)) {
		out = pg_format_sql(conn, scm_symbol_to_string(obj));
		}
	else if (scm_is_string(obj)) {
		if (scm_string_null_p(obj) == SCM_BOOL_T) out = c2s("NULL");
		else {
			char *src = scm_to_utf8_string(obj);
			scm_assert_smob_type(pg_conn_tag, conn);
			pgc = (struct pg_conn *)SCM_SMOB_DATA(conn);
			scm_lock_mutex(pgc->mutex);
			char *sql = PQescapeLiteral(pgc->conn,
					src, strlen(src));
			out = safe_from_utf8(sql);
			scm_unlock_mutex(pgc->mutex);
			free(src);
			PQfreemem(sql);
			}
		}
	else if (scm_is_null(obj)) out = c2s("NULL");
	else out = c2s("NULL");
	scm_remember_upto_here_1(out);
	scm_remember_upto_here_2(conn, obj);
	return out;
	}
예제 #29
0
파일: expand.c 프로젝트: Card1nal/guile
static SCM
expand_or (SCM expr, SCM env SCM_UNUSED)
{
  SCM tail = CDR (expr);
  const long length = scm_ilength (tail);

  ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);

  if (scm_is_null (CDR (expr)))
    return CONST (SCM_BOOL_F, SCM_BOOL_F);
  else
    {
      SCM tmp = scm_gensym (SCM_UNDEFINED);
      return LET (SCM_BOOL_F,
                  scm_list_1 (tmp), scm_list_1 (tmp),
                  scm_list_1 (expand (CADR (expr), env)),
                  CONDITIONAL (SCM_BOOL_F,
                               LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
                               LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
                               expand_or (CDR (expr),
                                          scm_acons (tmp, tmp, env))));
    }
}
예제 #30
0
파일: expand.c 프로젝트: Card1nal/guile
/* 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);
}