src/guile.c

   1 /* GNU Guile interface for GNU Make.
   2 Copyright (C) 2011-2022 Free Software Foundation, Inc.
   3 This file is part of GNU Make.
   4
   5 GNU Make is free software; you can redistribute it and/or modify it under the
   6 terms of the GNU General Public License as published by the Free Software
   7 Foundation; either version 3 of the License, or (at your option) any later
   8 version.
   9
  10 GNU Make is distributed in the hope that it will be useful, but WITHOUT ANY
  11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
  12 A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
  13
  14 You should have received a copy of the GNU General Public License along with
  15 this program.  If not, see <https://www.gnu.org/licenses/>.  */
  16
  17 #include "makeint.h"
  18
  19 #ifdef HAVE_GUILE
  20
  21 #include "gnumake.h"
  22
  23 #include "debug.h"
  24 #include "filedef.h"
  25 #include "dep.h"
  26 #include "variable.h"
  27
  28 #include <libguile.h>
  29
  30 /* Pre-2.0 versions of Guile don't have a typedef for gsubr function types.  */
  31 #if SCM_MAJOR_VERSION < 2
  32 # define GSUBR_TYPE         SCM (*) ()
  33 /* Guile 1.x doesn't really support i18n.  */
  34 # define EVAL_STRING(_s)    scm_c_eval_string (_s)
  35 #else
  36 # define GSUBR_TYPE         scm_t_subr
  37 # define EVAL_STRING(_s)    scm_eval_string (scm_from_utf8_string (_s))
  38 #endif
  39
  40 static SCM make_mod = SCM_EOL;
  41 static SCM obj_to_str = SCM_EOL;
  42
  43 /* Convert an SCM object into a string.  */
  44 static char *
  45 cvt_scm_to_str (SCM obj)
  46 {
  47   return scm_to_locale_string (scm_call_1 (obj_to_str, obj));
  48 }
  49
  50 /* Perform the GNU make expansion function.  */
  51 static SCM
  52 guile_expand_wrapper (SCM obj)
  53 {
  54   char *str = cvt_scm_to_str (obj);
  55   SCM ret;
  56   char *res;
  57
  58   DB (DB_BASIC, (_("guile: Expanding '%s'\n"), str));
  59   res = gmk_expand (str);
  60   ret = scm_from_locale_string (res);
  61
  62   free (str);
  63   free (res);
  64
  65   return ret;
  66 }
  67
  68 /* Perform the GNU make eval function.  */
  69 static SCM
  70 guile_eval_wrapper (SCM obj)
  71 {
  72   char *str = cvt_scm_to_str (obj);
  73
  74   DB (DB_BASIC, (_("guile: Evaluating '%s'\n"), str));
  75   gmk_eval (str, 0);
  76
  77   return SCM_BOOL_F;
  78 }
  79
  80 /* Invoked by scm_c_define_module(), in the context of the GNU make module.  */
  81 static void
  82 guile_define_module (void *data UNUSED)
  83 {
  84 /* Ingest the predefined Guile module for GNU make.  */
  85 #include "gmk-default.h"
  86
  87   /* Register a subr for GNU make's eval capability.  */
  88   scm_c_define_gsubr ("gmk-expand", 1, 0, 0, (GSUBR_TYPE) guile_expand_wrapper);
  89
  90   /* Register a subr for GNU make's eval capability.  */
  91   scm_c_define_gsubr ("gmk-eval", 1, 0, 0, (GSUBR_TYPE) guile_eval_wrapper);
  92
  93   /* Define the rest of the module.  */
  94   scm_c_eval_string (GUILE_module_defn);
  95 }
  96
  97 /* Initialize the GNU make Guile module.  */
  98 static void *
  99 guile_init (void *arg UNUSED)
 100 {
 101   /* Define the module.  */
 102   make_mod = scm_c_define_module ("gnu make", guile_define_module, NULL);
 103
 104   /* Get a reference to the object-to-string translator, for later.  */
 105   obj_to_str = scm_variable_ref (scm_c_module_lookup (make_mod, "obj-to-str"));
 106
 107   /* Import the GNU make module exports into the generic space.  */
 108   scm_c_eval_string ("(use-modules (gnu make))");
 109
 110   return NULL;
 111 }
 112
 113 static void *
 114 internal_guile_eval (void *arg)
 115 {
 116   return cvt_scm_to_str (EVAL_STRING (arg));
 117 }
 118
 119 /* This is the function registered with make  */
 120 static char *
 121 func_guile (const char *funcname UNUSED, unsigned int argc UNUSED, char **argv)
 122 {
 123   static int init = 0;
 124
 125   if (! init)
 126     {
 127       /* Initialize the Guile interpreter.  */
 128       scm_with_guile (guile_init, NULL);
 129       init = 1;
 130     }
 131
 132   if (argv[0] && argv[0][0] != '\0')
 133     return scm_with_guile (internal_guile_eval, argv[0]);
 134
 135   return NULL;
 136 }
 137
 138 /* ----- Public interface ----- */
 139
 140 /* We could send the flocp to define_new_function(), but since guile is
 141    "kind of" built-in, that didn't seem so useful.  */
 142 int
 143 guile_gmake_setup (const floc *flocp UNUSED)
 144 {
 145   /* Create a make function "guile".  */
 146   gmk_add_function ("guile", func_guile, 0, 1, GMK_FUNC_DEFAULT);
 147
 148   return 1;
 149 }
 150
 151 #else
 152
 153 int
 154 guile_gmake_setup (const floc *flocp UNUSED)
 155 {
 156   return 1;
 157 }
 158
 159 #endif