guile/libguile/macros.c

/* Copyright 1995-1998,2000-2003,2006,2008-2012,2018-2019,2025
     Free Software Foundation, Inc.

   This file is part of Guile.

   Guile is free software: you can redistribute it and/or modify it
   under the terms of the GNU Lesser General Public License as published
   by the Free Software Foundation, either version 3 of the License, or
   (at your option) any later version.

   Guile is distributed in the hope that it will be useful, but WITHOUT
   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
   FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
   License for more details.

   You should have received a copy of the GNU Lesser General Public
   License along with Guile.  If not, see
   <https://www.gnu.org/licenses/>.  */



#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include "boolean.h"
#include "gsubr.h"
#include "modules.h"
#include "ports.h"
#include "print.h"
#include "private-options.h"
#include "procs.h"
#include "random.h"
#include "symbols.h"
#include "threads.h"
#include "variable.h"

#include "macros.h"


struct scm_syntax_transformer
{
  scm_t_bits tag;
  scm_t_macro_primitive primitive;
  SCM name;
  SCM type;
  SCM binding;
};

static inline int
scm_is_syntax_transformer (SCM x)
{
  return SCM_HAS_TYP16 (x, scm_tc16_syntax_transformer);
}

static inline struct scm_syntax_transformer*
scm_to_syntax_transformer (SCM x)
{
  if (!scm_is_syntax_transformer (x))
    abort ();
  return (struct scm_syntax_transformer *)SCM_UNPACK_POINTER (x);
}

static inline SCM
scm_from_syntax_transformer (struct scm_syntax_transformer *m)
{
  return SCM_PACK_POINTER (m);
}

#define SCM_MACROP(x) scm_is_syntax_transformer (x)
#define SCM_VALIDATE_MACRO(p,v) SCM_MAKE_VALIDATE ((p), (v), MACROP)


int
scm_i_print_syntax_transformer (SCM macro, SCM port, scm_print_state *pstate)
{
  struct scm_syntax_transformer *tx = scm_to_syntax_transformer (macro);

  if (scm_is_false (tx->type))
    scm_puts ("#<primitive-syntax-transformer ", port);
  else
    scm_puts ("#<syntax-transformer ", port);
  scm_iprin1 (tx->name, port, pstate);
  scm_putc ('>', port);

  return 1;
}

SCM_SYMBOL (sym_primitive_macro, "primitive-macro");

/* Return a mmacro that is known to be one of guile's built in macros. */
SCM
scm_i_make_primitive_syntax_transformer (const char *name,
                                         scm_t_macro_primitive fn)
{
  struct scm_syntax_transformer *tx =
    scm_allocate_tagged (SCM_I_CURRENT_THREAD, sizeof (*tx));
  tx->tag = scm_tc16_syntax_transformer;
  tx->primitive = fn;
  tx->name = scm_from_utf8_symbol (name);
  tx->type = sym_primitive_macro;
  tx->binding = SCM_BOOL_F;

  return scm_from_syntax_transformer (tx);
}

scm_t_macro_primitive
scm_i_primitive_syntax_transformer (SCM macro)
{
  return scm_to_syntax_transformer (macro)->primitive;
}


SCM_DEFINE (scm_make_syntax_transformer, "make-syntax-transformer", 3, 0, 0,
            (SCM name, SCM type, SCM binding),
	    "Construct a @dfn{syntax transformer}.\n\n"
            "This function is part of Guile's low-level support for the psyntax\n"
            "syntax expander. Users should not call this function.")
#define FUNC_NAME s_scm_make_syntax_transformer
{
  if (scm_is_true (name))
    SCM_VALIDATE_SYMBOL (1, name);

  SCM_VALIDATE_SYMBOL (2, type);

  struct scm_syntax_transformer *tx = scm_allocate_tagged (SCM_I_CURRENT_THREAD,
                                                           sizeof (*tx));
  tx->tag = scm_tc16_syntax_transformer;
  tx->primitive = NULL;
  tx->name = name;
  tx->type = type;
  tx->binding = binding;

  if (scm_is_true (name))
    {
      SCM existing_var;

      existing_var = scm_module_variable (scm_current_module (), name);
      if (scm_is_true (existing_var)
          && scm_is_true (scm_variable_bound_p (existing_var)))
        {
          SCM val = SCM_VARIABLE_REF (existing_var);
          if (scm_is_syntax_transformer (val))
            tx->primitive = scm_to_syntax_transformer (val)->primitive;
        }
    }

  return scm_from_syntax_transformer (tx);
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0, 
            (SCM obj),
	    "Return @code{#t} if @var{obj} is a syntax transformer (an object that "
            "transforms Scheme expressions at expansion-time).\n\n"
            "Macros are actually just one kind of syntax transformer; this\n"
            "procedure has its name due to historical reasons.")
#define FUNC_NAME s_scm_macro_p
{
  return scm_from_bool (scm_is_syntax_transformer (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, 
            (SCM m),
	    "Return the type of the syntax transformer @var{m}, as passed to\n"
            "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n"
            "transformer, @code{#f} will be returned.")
#define FUNC_NAME s_scm_macro_type
{
  SCM_VALIDATE_MACRO (1, m);
  return scm_to_syntax_transformer (m)->type;
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0, 
            (SCM m),
	    "Return the name of the syntax transformer @var{m}.")
#define FUNC_NAME s_scm_macro_name
{
  SCM_VALIDATE_MACRO (1, m);
  return scm_to_syntax_transformer (m)->name;
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, 
            (SCM m),
	    "Return the transformer procedure of the macro @var{m}.\n\n"
            "If @var{m} is a syntax transformer but not a macro, @code{#f}\n"
            "will be returned. (This can happen, for example, with primitive\n"
            "syntax transformers).")
#define FUNC_NAME s_scm_macro_transformer
{
  SCM_VALIDATE_MACRO (1, m);
  SCM binding = scm_macro_binding (m);
  /* here we rely on knowledge of how psyntax represents macro bindings, but
     hey, there is code out there that calls this function, and expects to get
     a procedure in return... */
  if (scm_is_true (scm_procedure_p (binding)))
    return binding;
  return SCM_BOOL_F;
}
#undef FUNC_NAME

SCM_DEFINE (scm_macro_binding, "macro-binding", 1, 0, 0, 
            (SCM m),
	    "Return the binding of the syntax transformer @var{m}, as passed to\n"
            "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n"
            "transformer, @code{#f} will be returned.")
#define FUNC_NAME s_scm_macro_binding
{
  SCM_VALIDATE_MACRO (1, m);
  return scm_to_syntax_transformer (m)->binding;
}
#undef FUNC_NAME


static SCM syntax_session_id;

#define SESSION_ID_LENGTH      22  /* bytes */
#define BASE64_RADIX_BITS  6
#define BASE64_RADIX       (1 << (BASE64_RADIX_BITS))
#define BASE64_MASK        (BASE64_RADIX - 1)

static SCM
fresh_syntax_session_id (void)
{
  static const char base64[BASE64_RADIX] =
    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@";

  unsigned char digit_buf[SESSION_ID_LENGTH];
  char char_buf[SESSION_ID_LENGTH];
  size_t i;

  scm_i_random_bytes_from_platform (digit_buf, SESSION_ID_LENGTH);
  for (i = 0; i < SESSION_ID_LENGTH; ++i)
    char_buf[i] = base64[digit_buf[i] & BASE64_MASK];

  return scm_from_latin1_stringn (char_buf, SESSION_ID_LENGTH);
}

static SCM
scm_syntax_session_id (void)
{
  return syntax_session_id;
}


void
scm_init_macros ()
{
#include "macros.x"

  syntax_session_id = fresh_syntax_session_id();
  scm_c_define_gsubr ("syntax-session-id", 0, 0, 0, scm_syntax_session_id);
}