1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
25 #include "libguile/_scm.h"
26 #include "libguile/ports.h"
27 #include "libguile/print.h"
28 #include "libguile/smob.h"
29 #include "libguile/validate.h"
30 #include "libguile/macros.h"
32 #include "libguile/private-options.h"
35 static scm_t_bits scm_tc16_macro
;
37 #define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
38 #define SCM_MACRO_PRIMITIVE(m) ((scm_t_macro_primitive)SCM_SMOB_DATA (m))
39 #define SCM_MACRO_NAME(m) (SCM_SMOB_OBJECT_2 (m))
40 #define SCM_MACRO_TYPE(m) (SCM_SMOB_OBJECT_3 (m))
41 #define SCM_MACRO_BINDING(m) (SCM_CELL_OBJECT ((m), 4))
42 #define SCM_VALIDATE_MACRO(p,v) SCM_MAKE_VALIDATE ((p), (v), MACROP)
45 SCM_API scm_t_bits scm_tc16_macro
;
49 macro_print (SCM macro
, SCM port
, scm_print_state
*pstate
)
51 if (scm_is_false (SCM_MACRO_TYPE (macro
)))
52 scm_puts_unlocked ("#<primitive-syntax-transformer ", port
);
54 scm_puts_unlocked ("#<syntax-transformer ", port
);
55 scm_iprin1 (scm_macro_name (macro
), port
, pstate
);
56 scm_putc_unlocked ('>', port
);
61 /* Return a mmacro that is known to be one of guile's built in macros. */
63 scm_i_make_primitive_macro (const char *name
, scm_t_macro_primitive fn
)
65 SCM z
= scm_words (scm_tc16_macro
, 5);
66 SCM_SET_SMOB_DATA_N (z
, 1, (scm_t_bits
)fn
);
67 SCM_SET_SMOB_OBJECT_N (z
, 2, scm_from_utf8_symbol (name
));
68 SCM_SET_SMOB_OBJECT_N (z
, 3, SCM_BOOL_F
);
69 SCM_SET_SMOB_OBJECT_N (z
, 4, SCM_BOOL_F
);
74 scm_i_macro_primitive (SCM macro
)
76 return SCM_MACRO_PRIMITIVE (macro
);
80 SCM_DEFINE (scm_make_syntax_transformer
, "make-syntax-transformer", 3, 0, 0,
81 (SCM name
, SCM type
, SCM binding
),
82 "Construct a @dfn{syntax transformer}.\n\n"
83 "This function is part of Guile's low-level support for the psyntax\n"
84 "syntax expander. Users should not call this function.")
85 #define FUNC_NAME s_scm_make_syntax_transformer
88 SCM (*prim
)(SCM
,SCM
) = NULL
;
90 if (scm_is_true (name
))
94 SCM_VALIDATE_SYMBOL (1, name
);
96 existing_var
= scm_module_variable (scm_current_module (), name
);
97 if (scm_is_true (existing_var
)
98 && scm_is_true (scm_variable_bound_p (existing_var
))
99 && SCM_MACROP (SCM_VARIABLE_REF (existing_var
)))
100 prim
= SCM_MACRO_PRIMITIVE (SCM_VARIABLE_REF (existing_var
));
103 SCM_VALIDATE_SYMBOL (2, type
);
105 z
= scm_words (scm_tc16_macro
, 5);
106 SCM_SET_SMOB_DATA_N (z
, 1, prim
);
107 SCM_SET_SMOB_OBJECT_N (z
, 2, name
);
108 SCM_SET_SMOB_OBJECT_N (z
, 3, type
);
109 SCM_SET_SMOB_OBJECT_N (z
, 4, binding
);
114 SCM_DEFINE (scm_macro_p
, "macro?", 1, 0, 0,
116 "Return @code{#t} if @var{obj} is a syntax transformer (an object that "
117 "transforms Scheme expressions at expansion-time).\n\n"
118 "Macros are actually just one kind of syntax transformer; this\n"
119 "procedure has its name due to historical reasons.")
120 #define FUNC_NAME s_scm_macro_p
122 return scm_from_bool (SCM_MACROP (obj
));
126 SCM_DEFINE (scm_macro_type
, "macro-type", 1, 0, 0,
128 "Return the type of the syntax transformer @var{m}, as passed to\n"
129 "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n"
130 "transformer, @code{#f} will be returned.")
131 #define FUNC_NAME s_scm_macro_type
133 SCM_VALIDATE_MACRO (1, m
);
134 return SCM_MACRO_TYPE (m
);
138 SCM_DEFINE (scm_macro_name
, "macro-name", 1, 0, 0,
140 "Return the name of the syntax transformer @var{m}.")
141 #define FUNC_NAME s_scm_macro_name
143 SCM_VALIDATE_MACRO (1, m
);
144 return SCM_MACRO_NAME (m
);
148 SCM_DEFINE (scm_macro_transformer
, "macro-transformer", 1, 0, 0,
150 "Return the transformer procedure of the macro @var{m}.\n\n"
151 "If @var{m} is a syntax transformer but not a macro, @code{#f}\n"
152 "will be returned. (This can happen, for example, with primitive\n"
153 "syntax transformers).")
154 #define FUNC_NAME s_scm_macro_transformer
156 SCM_VALIDATE_MACRO (1, m
);
157 /* here we rely on knowledge of how psyntax represents macro bindings, but
158 hey, there is code out there that calls this function, and expects to get
159 a procedure in return... */
160 if (scm_is_true (scm_procedure_p (SCM_MACRO_BINDING (m
))))
161 return SCM_MACRO_BINDING (m
);
167 SCM_DEFINE (scm_macro_binding
, "macro-binding", 1, 0, 0,
169 "Return the binding of the syntax transformer @var{m}, as passed to\n"
170 "@code{make-syntax-transformer}. If @var{m} is a primitive syntax\n"
171 "transformer, @code{#f} will be returned.")
172 #define FUNC_NAME s_scm_macro_binding
174 SCM_VALIDATE_MACRO (1, m
);
175 return SCM_MACRO_BINDING (m
);
180 static SCM syntax_session_id
;
182 #define SESSION_ID_LENGTH 22 /* bytes */
183 #define BASE64_RADIX_BITS 6
184 #define BASE64_RADIX (1 << (BASE64_RADIX_BITS))
185 #define BASE64_MASK (BASE64_RADIX - 1)
188 fresh_syntax_session_id (void)
190 static const char base64
[BASE64_RADIX
] =
191 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789$@";
193 unsigned char digit_buf
[SESSION_ID_LENGTH
];
194 char char_buf
[SESSION_ID_LENGTH
];
197 scm_i_random_bytes_from_platform (digit_buf
, SESSION_ID_LENGTH
);
198 for (i
= 0; i
< SESSION_ID_LENGTH
; ++i
)
199 char_buf
[i
] = base64
[digit_buf
[i
] & BASE64_MASK
];
201 return scm_from_latin1_stringn (char_buf
, SESSION_ID_LENGTH
);
205 scm_syntax_session_id (void)
207 return syntax_session_id
;
214 scm_tc16_macro
= scm_make_smob_type ("macro", 0);
215 scm_set_smob_print (scm_tc16_macro
, macro_print
);
216 #include "libguile/macros.x"
218 syntax_session_id
= fresh_syntax_session_id();
219 scm_c_define_gsubr ("syntax-session-id", 0, 0, 0, scm_syntax_session_id
);