expand.c 52 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665
  1. /* Copyright 1995-2014,2016,2018-2020
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include "alist.h"
  19. #include "boolean.h"
  20. #include "continuations.h"
  21. #include "eq.h"
  22. #include "gsubr.h"
  23. #include "hashtab.h"
  24. #include "keywords.h"
  25. #include "list.h"
  26. #include "macros.h"
  27. #include "memoize.h" /* for the SCM_API declarations of 'scm_sym_' */
  28. #include "modules.h"
  29. #include "pairs.h"
  30. #include "ports.h"
  31. #include "print.h"
  32. #include "srcprop.h"
  33. #include "strings.h"
  34. #include "symbols.h"
  35. #include "throw.h"
  36. #include "variable.h"
  37. #include "vectors.h"
  38. #include "expand.h"
  39. SCM scm_exp_vtable_vtable;
  40. static SCM exp_vtables[SCM_NUM_EXPANDED_TYPES];
  41. static size_t exp_nfields[SCM_NUM_EXPANDED_TYPES];
  42. static SCM const_unbound;
  43. static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
  44. static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
  45. /* The trailing underscores on these first to are to avoid spurious
  46. conflicts with macros defined on MinGW. */
  47. #define VOID_(src) \
  48. SCM_MAKE_EXPANDED_VOID(src)
  49. #define CONST_(src, exp) \
  50. SCM_MAKE_EXPANDED_CONST(src, exp)
  51. #define PRIMITIVE_REF(src, name) \
  52. SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name)
  53. #define LEXICAL_REF(src, name, gensym) \
  54. SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
  55. #define LEXICAL_SET(src, name, gensym, exp) \
  56. SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp)
  57. #define MODULE_REF(src, mod, name, public) \
  58. SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public)
  59. #define MODULE_SET(src, mod, name, public, exp) \
  60. SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp)
  61. #define TOPLEVEL_REF(src, mod, name) \
  62. SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name)
  63. #define TOPLEVEL_SET(src, mod, name, exp) \
  64. SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp)
  65. #define TOPLEVEL_DEFINE(src, mod, name, exp) \
  66. SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, name, exp)
  67. #define CONDITIONAL(src, test, consequent, alternate) \
  68. SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
  69. #define PRIMCALL(src, name, exps) \
  70. SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps)
  71. #define CALL(src, proc, exps) \
  72. SCM_MAKE_EXPANDED_CALL(src, proc, exps)
  73. #define SEQ(src, head, tail) \
  74. SCM_MAKE_EXPANDED_SEQ(src, head, tail)
  75. #define LAMBDA(src, meta, body) \
  76. SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
  77. #define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
  78. SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate)
  79. #define LET(src, names, gensyms, vals, body) \
  80. SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
  81. #define LETREC(src, in_order_p, names, gensyms, vals, body) \
  82. SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
  83. #define CAR(x) SCM_CAR(x)
  84. #define CDR(x) SCM_CDR(x)
  85. #define CAAR(x) SCM_CAAR(x)
  86. #define CADR(x) SCM_CADR(x)
  87. #define CDAR(x) SCM_CDAR(x)
  88. #define CDDR(x) SCM_CDDR(x)
  89. #define CADDR(x) SCM_CADDR(x)
  90. #define CDDDR(x) SCM_CDDDR(x)
  91. #define CADDDR(x) SCM_CADDDR(x)
  92. /* Abbreviate SCM_EXPANDED_REF. */
  93. #define REF(x,type,field) \
  94. (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
  95. static const char s_bad_expression[] = "Bad expression";
  96. static const char s_expression[] = "Missing or extra expression in";
  97. static const char s_missing_expression[] = "Missing expression in";
  98. static const char s_extra_expression[] = "Extra expression in";
  99. static const char s_bad_define[] = "Bad define placement";
  100. static const char s_missing_clauses[] = "Missing clauses";
  101. static const char s_misplaced_else_clause[] = "Misplaced else clause";
  102. static const char s_bad_cond_clause[] = "Bad cond clause";
  103. static const char s_missing_recipient[] = "Missing recipient in";
  104. static const char s_bad_variable[] = "Bad variable";
  105. static const char s_bad_bindings[] = "Bad bindings";
  106. static const char s_bad_binding[] = "Bad binding";
  107. static const char s_duplicate_binding[] = "Duplicate binding";
  108. static const char s_bad_formals[] = "Bad formals";
  109. static const char s_bad_formal[] = "Bad formal";
  110. static const char s_duplicate_formal[] = "Duplicate formal";
  111. static void syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
  112. SCM_SYMBOL (syntax_error_key, "syntax-error");
  113. /* Shortcut macros to simplify syntax error handling. */
  114. #define ASSERT_SYNTAX(cond, message, form) \
  115. { if (SCM_UNLIKELY (!(cond))) \
  116. syntax_error (message, form, SCM_UNDEFINED); }
  117. #define ASSERT_SYNTAX_2(cond, message, form, expr) \
  118. { if (SCM_UNLIKELY (!(cond))) \
  119. syntax_error (message, form, expr); }
  120. /* Primitive syntax. */
  121. #define SCM_SYNTAX(STR, CFN) \
  122. SCM_SNARF_HERE(static SCM CFN (SCM xorig, SCM env)) \
  123. SCM_SNARF_INIT(scm_c_define (STR, scm_i_make_primitive_macro (STR, CFN)))
  124. /* True primitive syntax */
  125. SCM_SYNTAX ("@", expand_at);
  126. SCM_SYNTAX ("@@", expand_atat);
  127. SCM_SYNTAX ("begin", expand_begin);
  128. SCM_SYNTAX ("define", expand_define);
  129. SCM_SYNTAX ("eval-when", expand_eval_when);
  130. SCM_SYNTAX ("if", expand_if);
  131. SCM_SYNTAX ("lambda", expand_lambda);
  132. SCM_SYNTAX ("let", expand_let);
  133. SCM_SYNTAX ("quote", expand_quote);
  134. SCM_SYNTAX ("set!", expand_set_x);
  135. /* Convenient syntax during boot, expands to primitive syntax. Replaced after
  136. psyntax boots. */
  137. SCM_SYNTAX ("and", expand_and);
  138. SCM_SYNTAX ("cond", expand_cond);
  139. SCM_SYNTAX ("letrec", expand_letrec);
  140. SCM_SYNTAX ("letrec*", expand_letrec_star);
  141. SCM_SYNTAX ("let*", expand_letstar);
  142. SCM_SYNTAX ("or", expand_or);
  143. SCM_SYNTAX ("lambda*", expand_lambda_star);
  144. SCM_SYNTAX ("case-lambda", expand_case_lambda);
  145. SCM_SYNTAX ("case-lambda*", expand_case_lambda_star);
  146. SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
  147. SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
  148. SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
  149. SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
  150. SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
  151. SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
  152. SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
  153. SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
  154. SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
  155. SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
  156. SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
  157. SCM_GLOBAL_SYMBOL (scm_sym_let, "let");
  158. SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
  159. SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
  160. SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
  161. SCM_SYMBOL (sym_call_with_prompt, "call-with-prompt");
  162. SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
  163. SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
  164. SCM_SYMBOL (sym_lambda_star, "lambda*");
  165. SCM_SYMBOL (sym_eval, "eval");
  166. SCM_SYMBOL (sym_load, "load");
  167. SCM_SYMBOL (sym_primitive, "primitive");
  168. SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
  169. SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
  170. SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
  171. SCM_KEYWORD (kw_allow_other_keys, "allow-other-keys");
  172. SCM_KEYWORD (kw_optional, "optional");
  173. SCM_KEYWORD (kw_key, "key");
  174. SCM_KEYWORD (kw_rest, "rest");
  175. /* Signal a syntax error. We distinguish between the form that caused the
  176. * error and the enclosing expression. The error message will print out as
  177. * shown in the following pattern. The file name and line number are only
  178. * given when they can be determined from the erroneous form or from the
  179. * enclosing expression.
  180. *
  181. * <filename>: In procedure memoization:
  182. * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
  183. static void
  184. syntax_error (const char* const msg, const SCM form, const SCM expr)
  185. {
  186. SCM msg_string = scm_from_utf8_string (msg);
  187. SCM filename = SCM_BOOL_F;
  188. SCM linenr = SCM_BOOL_F;
  189. const char *format;
  190. SCM args;
  191. if (scm_is_pair (form))
  192. {
  193. filename = scm_source_property (form, scm_sym_filename);
  194. linenr = scm_source_property (form, scm_sym_line);
  195. }
  196. if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
  197. {
  198. filename = scm_source_property (expr, scm_sym_filename);
  199. linenr = scm_source_property (expr, scm_sym_line);
  200. }
  201. if (!SCM_UNBNDP (expr))
  202. {
  203. if (scm_is_true (filename))
  204. {
  205. format = "In file ~S, line ~S: ~A ~S in expression ~S.";
  206. args = scm_list_5 (filename, linenr, msg_string, form, expr);
  207. }
  208. else if (scm_is_true (linenr))
  209. {
  210. format = "In line ~S: ~A ~S in expression ~S.";
  211. args = scm_list_4 (linenr, msg_string, form, expr);
  212. }
  213. else
  214. {
  215. format = "~A ~S in expression ~S.";
  216. args = scm_list_3 (msg_string, form, expr);
  217. }
  218. }
  219. else
  220. {
  221. if (scm_is_true (filename))
  222. {
  223. format = "In file ~S, line ~S: ~A ~S.";
  224. args = scm_list_4 (filename, linenr, msg_string, form);
  225. }
  226. else if (scm_is_true (linenr))
  227. {
  228. format = "In line ~S: ~A ~S.";
  229. args = scm_list_3 (linenr, msg_string, form);
  230. }
  231. else
  232. {
  233. format = "~A ~S.";
  234. args = scm_list_2 (msg_string, form);
  235. }
  236. }
  237. scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
  238. }
  239. static int
  240. expand_env_var_is_free (SCM env, SCM x)
  241. {
  242. for (; scm_is_pair (env); env = CDR (env))
  243. if (scm_is_eq (x, CAAR (env)))
  244. return 0; /* bound */
  245. return 1; /* free */
  246. }
  247. static SCM
  248. expand_env_ref_macro (SCM env, SCM x)
  249. {
  250. SCM var;
  251. if (!expand_env_var_is_free (env, x))
  252. return SCM_BOOL_F; /* lexical */
  253. var = scm_module_variable (scm_current_module (), x);
  254. if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
  255. && scm_is_true (scm_macro_p (scm_variable_ref (var))))
  256. return scm_variable_ref (var);
  257. else
  258. return SCM_BOOL_F; /* anything else */
  259. }
  260. static SCM
  261. expand_env_lexical_gensym (SCM env, SCM name)
  262. {
  263. for (; scm_is_pair (env); env = CDR (env))
  264. if (scm_is_eq (name, CAAR (env)))
  265. return CDAR (env); /* bound */
  266. return SCM_BOOL_F; /* free */
  267. }
  268. static SCM
  269. expand_env_extend (SCM env, SCM names, SCM vars)
  270. {
  271. while (scm_is_pair (names))
  272. {
  273. env = scm_acons (CAR (names), CAR (vars), env);
  274. names = CDR (names);
  275. vars = CDR (vars);
  276. }
  277. return env;
  278. }
  279. static SCM
  280. expand (SCM exp, SCM env)
  281. {
  282. if (scm_is_pair (exp))
  283. {
  284. SCM car;
  285. scm_t_macro_primitive trans = NULL;
  286. SCM macro = SCM_BOOL_F;
  287. car = CAR (exp);
  288. if (scm_is_symbol (car))
  289. macro = expand_env_ref_macro (env, car);
  290. if (scm_is_true (macro))
  291. trans = scm_i_macro_primitive (macro);
  292. if (trans)
  293. return trans (exp, env);
  294. else
  295. {
  296. SCM arg_exps = SCM_EOL;
  297. SCM args = SCM_EOL;
  298. SCM proc = expand (CAR (exp), env);
  299. for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
  300. arg_exps = CDR (arg_exps))
  301. args = scm_cons (expand (CAR (arg_exps), env), args);
  302. args = scm_reverse_x (args, SCM_UNDEFINED);
  303. if (!scm_is_null (arg_exps))
  304. syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
  305. if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF)
  306. return PRIMCALL (scm_source_properties (exp),
  307. SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
  308. args);
  309. else
  310. return CALL (scm_source_properties (exp), proc, args);
  311. }
  312. }
  313. else if (scm_is_symbol (exp))
  314. {
  315. SCM gensym = expand_env_lexical_gensym (env, exp);
  316. if (scm_is_true (gensym))
  317. return LEXICAL_REF (SCM_BOOL_F, exp, gensym);
  318. else
  319. return TOPLEVEL_REF (SCM_BOOL_F, SCM_BOOL_F, exp);
  320. }
  321. else
  322. return CONST_ (SCM_BOOL_F, exp);
  323. }
  324. static SCM
  325. expand_exprs (SCM forms, const SCM env)
  326. {
  327. SCM ret = SCM_EOL;
  328. for (; !scm_is_null (forms); forms = CDR (forms))
  329. ret = scm_cons (expand (CAR (forms), env), ret);
  330. return scm_reverse_x (ret, SCM_UNDEFINED);
  331. }
  332. static SCM
  333. expand_sequence (const SCM forms, const SCM env)
  334. {
  335. ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
  336. scm_cons (scm_sym_begin, forms));
  337. if (scm_is_null (CDR (forms)))
  338. return expand (CAR (forms), env);
  339. else
  340. return SEQ (scm_source_properties (forms),
  341. expand (CAR (forms), env),
  342. expand_sequence (CDR (forms), env));
  343. }
  344. static SCM
  345. expand_at (SCM expr, SCM env SCM_UNUSED)
  346. {
  347. ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
  348. ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
  349. ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
  350. return MODULE_REF (scm_source_properties (expr),
  351. CADR (expr), CADDR (expr), SCM_BOOL_T);
  352. }
  353. static SCM
  354. expand_atat (SCM expr, SCM env SCM_UNUSED)
  355. {
  356. ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
  357. ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
  358. if (scm_is_eq (CADR (expr), sym_primitive))
  359. return PRIMITIVE_REF (scm_source_properties (expr), CADDR (expr));
  360. ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
  361. return MODULE_REF (scm_source_properties (expr),
  362. CADR (expr), CADDR (expr), SCM_BOOL_F);
  363. }
  364. static SCM
  365. expand_and (SCM expr, SCM env)
  366. {
  367. const SCM cdr_expr = CDR (expr);
  368. if (scm_is_null (cdr_expr))
  369. return CONST_ (SCM_BOOL_F, SCM_BOOL_T);
  370. ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
  371. if (scm_is_null (CDR (cdr_expr)))
  372. return expand (CAR (cdr_expr), env);
  373. else
  374. return CONDITIONAL (scm_source_properties (expr),
  375. expand (CAR (cdr_expr), env),
  376. expand_and (cdr_expr, env),
  377. CONST_ (SCM_BOOL_F, SCM_BOOL_F));
  378. }
  379. static SCM
  380. expand_begin (SCM expr, SCM env)
  381. {
  382. const SCM cdr_expr = CDR (expr);
  383. ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr);
  384. return expand_sequence (cdr_expr, env);
  385. }
  386. static SCM
  387. expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
  388. {
  389. SCM test;
  390. const long length = scm_ilength (clause);
  391. ASSERT_SYNTAX (length >= 1, s_bad_cond_clause, clause);
  392. test = CAR (clause);
  393. if (scm_is_eq (test, scm_sym_else) && elp)
  394. {
  395. const int last_clause_p = scm_is_null (rest);
  396. ASSERT_SYNTAX (length >= 2, s_bad_cond_clause, clause);
  397. ASSERT_SYNTAX (last_clause_p, s_misplaced_else_clause, clause);
  398. return expand_sequence (CDR (clause), env);
  399. }
  400. if (scm_is_null (rest))
  401. rest = VOID_ (SCM_BOOL_F);
  402. else
  403. rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
  404. if (length >= 2
  405. && scm_is_eq (CADR (clause), scm_sym_arrow)
  406. && alp)
  407. {
  408. SCM tmp = scm_gensym (scm_from_utf8_string ("cond "));
  409. SCM new_env = scm_acons (tmp, tmp, env);
  410. ASSERT_SYNTAX (length > 2, s_missing_recipient, clause);
  411. ASSERT_SYNTAX (length == 3, s_extra_expression, clause);
  412. return LET (SCM_BOOL_F,
  413. scm_list_1 (tmp),
  414. scm_list_1 (tmp),
  415. scm_list_1 (expand (test, env)),
  416. CONDITIONAL (SCM_BOOL_F,
  417. LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
  418. CALL (SCM_BOOL_F,
  419. expand (CADDR (clause), new_env),
  420. scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
  421. tmp, tmp))),
  422. rest));
  423. }
  424. /* FIXME length == 1 case */
  425. else
  426. return CONDITIONAL (SCM_BOOL_F,
  427. expand (test, env),
  428. expand_sequence (CDR (clause), env),
  429. rest);
  430. }
  431. static SCM
  432. expand_cond (SCM expr, SCM env)
  433. {
  434. const int else_literal_p = expand_env_var_is_free (env, scm_sym_else);
  435. const int arrow_literal_p = expand_env_var_is_free (env, scm_sym_arrow);
  436. const SCM clauses = CDR (expr);
  437. ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
  438. ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
  439. return expand_cond_clauses (CAR (clauses), CDR (clauses),
  440. else_literal_p, arrow_literal_p, env);
  441. }
  442. /* lone forward decl */
  443. static SCM expand_lambda (SCM expr, SCM env);
  444. /* According to Section 5.2.1 of R5RS we first have to make sure that the
  445. variable is bound, and then perform the `(set! variable expression)'
  446. operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
  447. bound. This means that EXPRESSION won't necessarily be able to assign
  448. values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
  449. static SCM
  450. expand_define (SCM expr, SCM env)
  451. {
  452. const SCM cdr_expr = CDR (expr);
  453. SCM body;
  454. SCM variable;
  455. ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
  456. ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
  457. ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);
  458. body = CDR (cdr_expr);
  459. variable = CAR (cdr_expr);
  460. if (scm_is_pair (variable))
  461. {
  462. ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
  463. return TOPLEVEL_DEFINE
  464. (scm_source_properties (expr),
  465. SCM_BOOL_F,
  466. CAR (variable),
  467. expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)),
  468. env));
  469. }
  470. ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
  471. ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
  472. return TOPLEVEL_DEFINE (scm_source_properties (expr), SCM_BOOL_F, variable,
  473. expand (CAR (body), env));
  474. }
  475. static SCM
  476. expand_eval_when (SCM expr, SCM env)
  477. {
  478. ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
  479. ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
  480. if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
  481. || scm_is_true (scm_memq (sym_load, CADR (expr))))
  482. return expand_sequence (CDDR (expr), env);
  483. else
  484. return VOID_ (scm_source_properties (expr));
  485. }
  486. static SCM
  487. expand_if (SCM expr, SCM env SCM_UNUSED)
  488. {
  489. const SCM cdr_expr = CDR (expr);
  490. const long length = scm_ilength (cdr_expr);
  491. ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
  492. return CONDITIONAL (scm_source_properties (expr),
  493. expand (CADR (expr), env),
  494. expand (CADDR (expr), env),
  495. ((length == 3)
  496. ? expand (CADDDR (expr), env)
  497. : VOID_ (SCM_BOOL_F)));
  498. }
  499. /* A helper function for expand_lambda to support checking for duplicate
  500. * formal arguments: Return true if OBJ is `eq?' to one of the elements of
  501. * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
  502. * forms that a formal argument can have:
  503. * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
  504. static int
  505. c_improper_memq (SCM obj, SCM list)
  506. {
  507. for (; scm_is_pair (list); list = CDR (list))
  508. {
  509. if (scm_is_eq (CAR (list), obj))
  510. return 1;
  511. }
  512. return scm_is_eq (list, obj);
  513. }
  514. static SCM
  515. expand_lambda_case (SCM clause, SCM alternate, SCM env)
  516. {
  517. SCM formals;
  518. SCM rest;
  519. SCM req = SCM_EOL;
  520. SCM vars = SCM_EOL;
  521. SCM body;
  522. int nreq = 0;
  523. ASSERT_SYNTAX (scm_is_pair (clause) && scm_is_pair (CDR (clause)),
  524. s_bad_expression, scm_cons (scm_sym_lambda, clause));
  525. /* Before iterating the list of formal arguments, make sure the formals
  526. * actually are given as either a symbol or a non-cyclic list. */
  527. formals = CAR (clause);
  528. if (scm_is_pair (formals))
  529. {
  530. /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
  531. * detected, report a 'Bad formals' error. */
  532. }
  533. else
  534. ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
  535. s_bad_formals, formals, scm_cons (scm_sym_lambda, clause));
  536. /* Now iterate the list of formal arguments to check if all formals are
  537. * symbols, and that there are no duplicates. */
  538. while (scm_is_pair (formals))
  539. {
  540. const SCM formal = CAR (formals);
  541. formals = CDR (formals);
  542. ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal,
  543. scm_cons (scm_sym_lambda, clause));
  544. ASSERT_SYNTAX_2 (!c_improper_memq (formal, formals), s_duplicate_formal,
  545. formal, scm_cons (scm_sym_lambda, clause));
  546. nreq++;
  547. req = scm_cons (formal, req);
  548. vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
  549. env = scm_acons (formal, CAR (vars), env);
  550. }
  551. ASSERT_SYNTAX_2 (scm_is_null (formals) || scm_is_symbol (formals),
  552. s_bad_formal, formals, scm_cons (scm_sym_lambda, clause));
  553. if (scm_is_symbol (formals))
  554. {
  555. rest = formals;
  556. vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
  557. env = scm_acons (rest, CAR (vars), env);
  558. }
  559. else
  560. rest = SCM_BOOL_F;
  561. body = expand_sequence (CDR (clause), env);
  562. req = scm_reverse_x (req, SCM_UNDEFINED);
  563. vars = scm_reverse_x (vars, SCM_UNDEFINED);
  564. if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE))
  565. abort ();
  566. return LAMBDA_CASE (SCM_BOOL_F, req, SCM_BOOL_F, rest, SCM_BOOL_F,
  567. SCM_EOL, vars, body, alternate);
  568. }
  569. static SCM
  570. expand_lambda (SCM expr, SCM env)
  571. {
  572. return LAMBDA (scm_source_properties (expr),
  573. SCM_EOL,
  574. expand_lambda_case (CDR (expr), SCM_BOOL_F, env));
  575. }
  576. static SCM
  577. expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
  578. {
  579. SCM req, opt, kw, allow_other_keys, rest, formals, vars, body, tmp;
  580. SCM inits;
  581. int nreq, nopt;
  582. const long length = scm_ilength (clause);
  583. ASSERT_SYNTAX (length >= 1, s_bad_expression,
  584. scm_cons (sym_lambda_star, clause));
  585. ASSERT_SYNTAX (length >= 2, s_missing_expression,
  586. scm_cons (sym_lambda_star, clause));
  587. formals = CAR (clause);
  588. body = CDR (clause);
  589. nreq = nopt = 0;
  590. req = opt = kw = SCM_EOL;
  591. rest = allow_other_keys = SCM_BOOL_F;
  592. while (scm_is_pair (formals) && scm_is_symbol (CAR (formals)))
  593. {
  594. nreq++;
  595. req = scm_cons (CAR (formals), req);
  596. formals = scm_cdr (formals);
  597. }
  598. if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_optional))
  599. {
  600. formals = CDR (formals);
  601. while (scm_is_pair (formals)
  602. && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
  603. {
  604. nopt++;
  605. opt = scm_cons (CAR (formals), opt);
  606. formals = scm_cdr (formals);
  607. }
  608. }
  609. if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_key))
  610. {
  611. formals = CDR (formals);
  612. while (scm_is_pair (formals)
  613. && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
  614. {
  615. kw = scm_cons (CAR (formals), kw);
  616. formals = scm_cdr (formals);
  617. }
  618. }
  619. if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_allow_other_keys))
  620. {
  621. formals = CDR (formals);
  622. allow_other_keys = SCM_BOOL_T;
  623. }
  624. if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_rest))
  625. {
  626. ASSERT_SYNTAX (scm_ilength (formals) == 2, s_bad_formals,
  627. CAR (clause));
  628. rest = CADR (formals);
  629. }
  630. else if (scm_is_symbol (formals))
  631. rest = formals;
  632. else
  633. {
  634. ASSERT_SYNTAX (scm_is_null (formals), s_bad_formals, CAR (clause));
  635. rest = SCM_BOOL_F;
  636. }
  637. /* Now, iterate through them a second time, building up an expansion-time
  638. environment, checking, expanding and canonicalizing the opt/kw init forms,
  639. and eventually memoizing the body as well. Note that the rest argument, if
  640. any, is expanded before keyword args, thus necessitating the second
  641. pass.
  642. Also note that the specific environment during expansion of init
  643. expressions here needs to coincide with the environment when psyntax
  644. expands. A lot of effort for something that is only used in the bootstrap
  645. expander, you say? Yes. Yes it is.
  646. */
  647. vars = SCM_EOL;
  648. req = scm_reverse_x (req, SCM_EOL);
  649. for (tmp = req; scm_is_pair (tmp); tmp = scm_cdr (tmp))
  650. {
  651. vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
  652. env = scm_acons (CAR (tmp), CAR (vars), env);
  653. }
  654. /* Build up opt inits and env */
  655. inits = SCM_EOL;
  656. opt = scm_reverse_x (opt, SCM_EOL);
  657. for (tmp = opt; scm_is_pair (tmp); tmp = scm_cdr (tmp))
  658. {
  659. SCM x = CAR (tmp);
  660. vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
  661. env = scm_acons (x, CAR (vars), env);
  662. if (scm_is_symbol (x))
  663. inits = scm_cons (CONST_ (SCM_BOOL_F, SCM_BOOL_F), inits);
  664. else
  665. {
  666. ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
  667. s_bad_formals, CAR (clause));
  668. inits = scm_cons (expand (CADR (x), env), inits);
  669. }
  670. env = scm_acons (scm_is_symbol (x) ? x : CAR (x), CAR (vars), env);
  671. }
  672. if (scm_is_null (opt))
  673. opt = SCM_BOOL_F;
  674. /* Process rest before keyword args */
  675. if (scm_is_true (rest))
  676. {
  677. vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
  678. env = scm_acons (rest, CAR (vars), env);
  679. }
  680. /* Build up kw inits, env, and kw-canon list */
  681. if (scm_is_null (kw))
  682. kw = SCM_BOOL_F;
  683. else
  684. {
  685. SCM kw_canon = SCM_EOL;
  686. kw = scm_reverse_x (kw, SCM_UNDEFINED);
  687. for (tmp = kw; scm_is_pair (tmp); tmp = scm_cdr (tmp))
  688. {
  689. SCM x, sym, k, init;
  690. x = CAR (tmp);
  691. if (scm_is_symbol (x))
  692. {
  693. sym = x;
  694. init = SCM_BOOL_F;
  695. k = scm_symbol_to_keyword (sym);
  696. }
  697. else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
  698. {
  699. sym = CAR (x);
  700. init = CADR (x);
  701. k = scm_symbol_to_keyword (sym);
  702. }
  703. else if (scm_ilength (x) == 3 && scm_is_symbol (CAR (x))
  704. && scm_is_keyword (CADDR (x)))
  705. {
  706. sym = CAR (x);
  707. init = CADR (x);
  708. k = CADDR (x);
  709. }
  710. else
  711. syntax_error (s_bad_formals, CAR (clause), SCM_UNDEFINED);
  712. inits = scm_cons (expand (init, env), inits);
  713. vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
  714. kw_canon = scm_cons (scm_list_3 (k, sym, CAR (vars)), kw_canon);
  715. env = scm_acons (sym, CAR (vars), env);
  716. }
  717. kw_canon = scm_reverse_x (kw_canon, SCM_UNDEFINED);
  718. kw = scm_cons (allow_other_keys, kw_canon);
  719. }
  720. /* We should check for no duplicates, but given that psyntax does this
  721. already, we can punt on it here... */
  722. vars = scm_reverse_x (vars, SCM_UNDEFINED);
  723. inits = scm_reverse_x (inits, SCM_UNDEFINED);
  724. body = expand_sequence (body, env);
  725. return LAMBDA_CASE (SCM_BOOL_F, req, opt, rest, kw, inits, vars, body,
  726. alternate);
  727. }
  728. static SCM
  729. expand_lambda_star (SCM expr, SCM env)
  730. {
  731. return LAMBDA (scm_source_properties (expr),
  732. SCM_EOL,
  733. expand_lambda_star_case (CDR (expr), SCM_BOOL_F, env));
  734. }
  735. static SCM
  736. expand_case_lambda_clauses (SCM expr, SCM rest, SCM env)
  737. {
  738. SCM alt;
  739. if (scm_is_pair (rest))
  740. alt = expand_case_lambda_clauses (CAR (rest), CDR (rest), env);
  741. else
  742. alt = SCM_BOOL_F;
  743. return expand_lambda_case (expr, alt, env);
  744. }
  745. static SCM
  746. expand_case_lambda (SCM expr, SCM env)
  747. {
  748. ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
  749. return LAMBDA (scm_source_properties (expr),
  750. SCM_EOL,
  751. expand_case_lambda_clauses (CADR (expr), CDDR (expr), env));
  752. }
  753. static SCM
  754. expand_case_lambda_star_clauses (SCM expr, SCM rest, SCM env)
  755. {
  756. SCM alt;
  757. if (scm_is_pair (rest))
  758. alt = expand_case_lambda_star_clauses (CAR (rest), CDR (rest), env);
  759. else
  760. alt = SCM_BOOL_F;
  761. return expand_lambda_star_case (expr, alt, env);
  762. }
  763. static SCM
  764. expand_case_lambda_star (SCM expr, SCM env)
  765. {
  766. ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
  767. return LAMBDA (scm_source_properties (expr),
  768. SCM_EOL,
  769. expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env));
  770. }
  771. /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
  772. static void
  773. check_bindings (const SCM bindings, const SCM expr)
  774. {
  775. SCM binding_idx;
  776. ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
  777. s_bad_bindings, bindings, expr);
  778. binding_idx = bindings;
  779. for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
  780. {
  781. SCM name; /* const */
  782. const SCM binding = CAR (binding_idx);
  783. ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
  784. s_bad_binding, binding, expr);
  785. name = CAR (binding);
  786. ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
  787. }
  788. }
  789. /* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
  790. * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
  791. * variable name is detected, an error is signaled. */
  792. static void
  793. transform_bindings (const SCM bindings, const SCM expr,
  794. SCM *const names, SCM *const vars, SCM *const initptr)
  795. {
  796. SCM rnames = SCM_EOL;
  797. SCM rvars = SCM_EOL;
  798. SCM rinits = SCM_EOL;
  799. SCM binding_idx = bindings;
  800. for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
  801. {
  802. const SCM binding = CAR (binding_idx);
  803. const SCM CDR_binding = CDR (binding);
  804. const SCM name = CAR (binding);
  805. ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rnames)),
  806. s_duplicate_binding, name, expr);
  807. rnames = scm_cons (name, rnames);
  808. rvars = scm_cons (scm_gensym (SCM_UNDEFINED), rvars);
  809. rinits = scm_cons (CAR (CDR_binding), rinits);
  810. }
  811. *names = scm_reverse_x (rnames, SCM_UNDEFINED);
  812. *vars = scm_reverse_x (rvars, SCM_UNDEFINED);
  813. *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
  814. }
  815. /* FIXME: Remove named let in this boot expander. */
  816. static SCM
  817. expand_named_let (const SCM expr, SCM env)
  818. {
  819. SCM var_names, var_syms, inits;
  820. SCM inner_env;
  821. SCM name_sym;
  822. const SCM cdr_expr = CDR (expr);
  823. const SCM name = CAR (cdr_expr);
  824. const SCM cddr_expr = CDR (cdr_expr);
  825. const SCM bindings = CAR (cddr_expr);
  826. check_bindings (bindings, expr);
  827. transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
  828. name_sym = scm_gensym (SCM_UNDEFINED);
  829. inner_env = scm_acons (name, name_sym, env);
  830. inner_env = expand_env_extend (inner_env, var_names, var_syms);
  831. return LETREC
  832. (scm_source_properties (expr), SCM_BOOL_F,
  833. scm_list_1 (name), scm_list_1 (name_sym),
  834. scm_list_1 (LAMBDA (SCM_BOOL_F,
  835. SCM_EOL,
  836. LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F,
  837. SCM_BOOL_F, SCM_EOL, var_syms,
  838. expand_sequence (CDDDR (expr), inner_env),
  839. SCM_BOOL_F))),
  840. CALL (SCM_BOOL_F,
  841. LEXICAL_REF (SCM_BOOL_F, name, name_sym),
  842. expand_exprs (inits, env)));
  843. }
  844. static SCM
  845. expand_let (SCM expr, SCM env)
  846. {
  847. SCM bindings;
  848. const SCM cdr_expr = CDR (expr);
  849. const long length = scm_ilength (cdr_expr);
  850. ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
  851. ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
  852. bindings = CAR (cdr_expr);
  853. if (scm_is_symbol (bindings))
  854. {
  855. ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
  856. return expand_named_let (expr, env);
  857. }
  858. check_bindings (bindings, expr);
  859. if (scm_is_null (bindings))
  860. return expand_sequence (CDDR (expr), env);
  861. else
  862. {
  863. SCM var_names, var_syms, inits;
  864. transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
  865. return LET (SCM_BOOL_F,
  866. var_names, var_syms, expand_exprs (inits, env),
  867. expand_sequence (CDDR (expr),
  868. expand_env_extend (env, var_names,
  869. var_syms)));
  870. }
  871. }
  872. static SCM
  873. expand_letrec_helper (SCM expr, SCM env, SCM in_order_p)
  874. {
  875. SCM bindings;
  876. const SCM cdr_expr = CDR (expr);
  877. const long length = scm_ilength (cdr_expr);
  878. ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
  879. ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
  880. bindings = CAR (cdr_expr);
  881. check_bindings (bindings, expr);
  882. if (scm_is_null (bindings))
  883. return expand_sequence (CDDR (expr), env);
  884. else
  885. {
  886. SCM var_names, var_syms, inits;
  887. transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
  888. env = expand_env_extend (env, var_names, var_syms);
  889. return LETREC (SCM_BOOL_F, in_order_p,
  890. var_names, var_syms, expand_exprs (inits, env),
  891. expand_sequence (CDDR (expr), env));
  892. }
  893. }
  894. static SCM
  895. expand_letrec (SCM expr, SCM env)
  896. {
  897. return expand_letrec_helper (expr, env, SCM_BOOL_F);
  898. }
  899. static SCM
  900. expand_letrec_star (SCM expr, SCM env)
  901. {
  902. return expand_letrec_helper (expr, env, SCM_BOOL_T);
  903. }
  904. static SCM
  905. expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
  906. {
  907. if (scm_is_null (bindings))
  908. return expand_sequence (body, env);
  909. else
  910. {
  911. SCM bind, name, sym, init;
  912. ASSERT_SYNTAX (scm_is_pair (bindings), s_bad_expression, bindings);
  913. bind = CAR (bindings);
  914. ASSERT_SYNTAX (scm_ilength (bind) == 2, s_bad_binding, bind);
  915. name = CAR (bind);
  916. sym = scm_gensym (SCM_UNDEFINED);
  917. init = CADR (bind);
  918. return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym),
  919. scm_list_1 (expand (init, env)),
  920. expand_letstar_clause (CDR (bindings), body,
  921. scm_acons (name, sym, env)));
  922. }
  923. }
  924. static SCM
  925. expand_letstar (SCM expr, SCM env SCM_UNUSED)
  926. {
  927. const SCM cdr_expr = CDR (expr);
  928. ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
  929. ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
  930. return expand_letstar_clause (CADR (expr), CDDR (expr), env);
  931. }
  932. static SCM
  933. expand_or (SCM expr, SCM env SCM_UNUSED)
  934. {
  935. SCM tail = CDR (expr);
  936. const long length = scm_ilength (tail);
  937. ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
  938. if (scm_is_null (CDR (expr)))
  939. return CONST_ (SCM_BOOL_F, SCM_BOOL_F);
  940. else
  941. {
  942. SCM tmp = scm_gensym (SCM_UNDEFINED);
  943. return LET (SCM_BOOL_F,
  944. scm_list_1 (tmp), scm_list_1 (tmp),
  945. scm_list_1 (expand (CADR (expr), env)),
  946. CONDITIONAL (SCM_BOOL_F,
  947. LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
  948. LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
  949. expand_or (CDR (expr),
  950. scm_acons (tmp, tmp, env))));
  951. }
  952. }
  953. static SCM
  954. expand_quote (SCM expr, SCM env SCM_UNUSED)
  955. {
  956. SCM quotee;
  957. const SCM cdr_expr = CDR (expr);
  958. ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
  959. ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
  960. quotee = CAR (cdr_expr);
  961. return CONST_ (scm_source_properties (expr), quotee);
  962. }
  963. static SCM
  964. expand_set_x (SCM expr, SCM env)
  965. {
  966. SCM variable;
  967. SCM vmem;
  968. const SCM cdr_expr = CDR (expr);
  969. ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
  970. ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
  971. variable = CAR (cdr_expr);
  972. vmem = expand (variable, env);
  973. switch (SCM_EXPANDED_TYPE (vmem))
  974. {
  975. case SCM_EXPANDED_LEXICAL_REF:
  976. return LEXICAL_SET (scm_source_properties (expr),
  977. SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME),
  978. SCM_EXPANDED_REF (vmem, LEXICAL_REF, GENSYM),
  979. expand (CADDR (expr), env));
  980. case SCM_EXPANDED_TOPLEVEL_REF:
  981. return TOPLEVEL_SET (scm_source_properties (expr),
  982. SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD),
  983. SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME),
  984. expand (CADDR (expr), env));
  985. case SCM_EXPANDED_MODULE_REF:
  986. return MODULE_SET (scm_source_properties (expr),
  987. SCM_EXPANDED_REF (vmem, MODULE_REF, MOD),
  988. SCM_EXPANDED_REF (vmem, MODULE_REF, NAME),
  989. SCM_EXPANDED_REF (vmem, MODULE_REF, PUBLIC),
  990. expand (CADDR (expr), env));
  991. default:
  992. syntax_error (s_bad_variable, variable, expr);
  993. }
  994. }
  995. /* This is the boot expander. It is later replaced with psyntax's sc-expand. */
  996. SCM_DEFINE (scm_macroexpand, "macroexpand", 1, 0, 0,
  997. (SCM exp),
  998. "Expand the expression @var{exp}.")
  999. #define FUNC_NAME s_scm_macroexpand
  1000. {
  1001. return expand (exp, scm_current_module ());
  1002. }
  1003. #undef FUNC_NAME
  1004. SCM_DEFINE (scm_macroexpanded_p, "macroexpanded?", 1, 0, 0,
  1005. (SCM exp),
  1006. "Return @code{#t} if @var{exp} is an expanded expression.")
  1007. #define FUNC_NAME s_scm_macroexpanded_p
  1008. {
  1009. return scm_from_bool (SCM_EXPANDED_P (exp));
  1010. }
  1011. #undef FUNC_NAME
  1012. static void
  1013. compute_assigned (SCM exp, SCM assigned)
  1014. {
  1015. if (scm_is_null (exp) || scm_is_false (exp))
  1016. return;
  1017. if (scm_is_pair (exp))
  1018. {
  1019. compute_assigned (CAR (exp), assigned);
  1020. compute_assigned (CDR (exp), assigned);
  1021. return;
  1022. }
  1023. if (!SCM_EXPANDED_P (exp))
  1024. abort ();
  1025. switch (SCM_EXPANDED_TYPE (exp))
  1026. {
  1027. case SCM_EXPANDED_VOID:
  1028. case SCM_EXPANDED_CONST:
  1029. case SCM_EXPANDED_PRIMITIVE_REF:
  1030. case SCM_EXPANDED_LEXICAL_REF:
  1031. case SCM_EXPANDED_MODULE_REF:
  1032. case SCM_EXPANDED_TOPLEVEL_REF:
  1033. return;
  1034. case SCM_EXPANDED_LEXICAL_SET:
  1035. scm_hashq_set_x (assigned, REF (exp, LEXICAL_SET, GENSYM), SCM_BOOL_T);
  1036. compute_assigned (REF (exp, LEXICAL_SET, EXP), assigned);
  1037. return;
  1038. case SCM_EXPANDED_MODULE_SET:
  1039. compute_assigned (REF (exp, MODULE_SET, EXP), assigned);
  1040. return;
  1041. case SCM_EXPANDED_TOPLEVEL_SET:
  1042. compute_assigned (REF (exp, TOPLEVEL_SET, EXP), assigned);
  1043. return;
  1044. case SCM_EXPANDED_TOPLEVEL_DEFINE:
  1045. compute_assigned (REF (exp, TOPLEVEL_DEFINE, EXP), assigned);
  1046. return;
  1047. case SCM_EXPANDED_CONDITIONAL:
  1048. compute_assigned (REF (exp, CONDITIONAL, TEST), assigned);
  1049. compute_assigned (REF (exp, CONDITIONAL, CONSEQUENT), assigned);
  1050. compute_assigned (REF (exp, CONDITIONAL, ALTERNATE), assigned);
  1051. return;
  1052. case SCM_EXPANDED_CALL:
  1053. compute_assigned (REF (exp, CALL, PROC), assigned);
  1054. compute_assigned (REF (exp, CALL, ARGS), assigned);
  1055. return;
  1056. case SCM_EXPANDED_PRIMCALL:
  1057. compute_assigned (REF (exp, PRIMCALL, ARGS), assigned);
  1058. return;
  1059. case SCM_EXPANDED_SEQ:
  1060. compute_assigned (REF (exp, SEQ, HEAD), assigned);
  1061. compute_assigned (REF (exp, SEQ, TAIL), assigned);
  1062. return;
  1063. case SCM_EXPANDED_LAMBDA:
  1064. compute_assigned (REF (exp, LAMBDA, BODY), assigned);
  1065. return;
  1066. case SCM_EXPANDED_LAMBDA_CASE:
  1067. compute_assigned (REF (exp, LAMBDA_CASE, INITS), assigned);
  1068. compute_assigned (REF (exp, LAMBDA_CASE, BODY), assigned);
  1069. compute_assigned (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
  1070. return;
  1071. case SCM_EXPANDED_LET:
  1072. compute_assigned (REF (exp, LET, VALS), assigned);
  1073. compute_assigned (REF (exp, LET, BODY), assigned);
  1074. return;
  1075. case SCM_EXPANDED_LETREC:
  1076. {
  1077. SCM syms = REF (exp, LETREC, GENSYMS);
  1078. /* We lower letrec in this same pass, so mark these variables as
  1079. assigned. */
  1080. for (; scm_is_pair (syms); syms = CDR (syms))
  1081. scm_hashq_set_x (assigned, CAR (syms), SCM_BOOL_T);
  1082. }
  1083. compute_assigned (REF (exp, LETREC, VALS), assigned);
  1084. compute_assigned (REF (exp, LETREC, BODY), assigned);
  1085. return;
  1086. default:
  1087. abort ();
  1088. }
  1089. }
  1090. static SCM
  1091. box_value (SCM exp)
  1092. {
  1093. return PRIMCALL (SCM_BOOL_F, scm_from_latin1_symbol ("make-variable"),
  1094. scm_list_1 (exp));
  1095. }
  1096. static SCM
  1097. box_lexical (SCM name, SCM sym)
  1098. {
  1099. return LEXICAL_SET (SCM_BOOL_F, name, sym,
  1100. box_value (LEXICAL_REF (SCM_BOOL_F, name, sym)));
  1101. }
  1102. static SCM
  1103. init_if_unbound (SCM src, SCM name, SCM sym, SCM init)
  1104. {
  1105. return CONDITIONAL (src,
  1106. PRIMCALL (src,
  1107. scm_from_latin1_symbol ("eq?"),
  1108. scm_list_2 (LEXICAL_REF (src, name, sym),
  1109. const_unbound)),
  1110. LEXICAL_SET (src, name, sym, init),
  1111. VOID_ (src));
  1112. }
  1113. static SCM
  1114. init_boxes (SCM names, SCM syms, SCM vals, SCM body)
  1115. {
  1116. if (scm_is_null (names)) return body;
  1117. return SEQ (SCM_BOOL_F,
  1118. PRIMCALL
  1119. (SCM_BOOL_F,
  1120. scm_from_latin1_symbol ("variable-set!"),
  1121. scm_list_2 (LEXICAL_REF (SCM_BOOL_F, CAR (names), CAR (syms)),
  1122. CAR (vals))),
  1123. init_boxes (CDR (names), CDR (syms), CDR (vals), body));
  1124. }
  1125. static SCM
  1126. convert_assignment (SCM exp, SCM assigned)
  1127. {
  1128. if (scm_is_null (exp) || scm_is_false (exp))
  1129. return exp;
  1130. if (scm_is_pair (exp))
  1131. return scm_cons (convert_assignment (CAR (exp), assigned),
  1132. convert_assignment (CDR (exp), assigned));
  1133. if (!SCM_EXPANDED_P (exp))
  1134. abort ();
  1135. switch (SCM_EXPANDED_TYPE (exp))
  1136. {
  1137. case SCM_EXPANDED_VOID:
  1138. case SCM_EXPANDED_CONST:
  1139. case SCM_EXPANDED_PRIMITIVE_REF:
  1140. case SCM_EXPANDED_MODULE_REF:
  1141. case SCM_EXPANDED_TOPLEVEL_REF:
  1142. return exp;
  1143. case SCM_EXPANDED_LEXICAL_REF:
  1144. {
  1145. SCM sym = REF (exp, LEXICAL_REF, GENSYM);
  1146. if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
  1147. return PRIMCALL
  1148. (REF (exp, LEXICAL_REF, SRC),
  1149. scm_from_latin1_symbol ("variable-ref"),
  1150. scm_list_1 (exp));
  1151. return exp;
  1152. }
  1153. case SCM_EXPANDED_LEXICAL_SET:
  1154. return PRIMCALL
  1155. (REF (exp, LEXICAL_SET, SRC),
  1156. scm_from_latin1_symbol ("variable-set!"),
  1157. scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, SRC),
  1158. REF (exp, LEXICAL_SET, NAME),
  1159. REF (exp, LEXICAL_SET, GENSYM)),
  1160. convert_assignment (REF (exp, LEXICAL_SET, EXP),
  1161. assigned)));
  1162. case SCM_EXPANDED_MODULE_SET:
  1163. return MODULE_SET
  1164. (REF (exp, MODULE_SET, SRC),
  1165. REF (exp, MODULE_SET, MOD),
  1166. REF (exp, MODULE_SET, NAME),
  1167. REF (exp, MODULE_SET, PUBLIC),
  1168. convert_assignment (REF (exp, MODULE_SET, EXP), assigned));
  1169. case SCM_EXPANDED_TOPLEVEL_SET:
  1170. return TOPLEVEL_SET
  1171. (REF (exp, TOPLEVEL_SET, SRC),
  1172. REF (exp, TOPLEVEL_SET, MOD),
  1173. REF (exp, TOPLEVEL_SET, NAME),
  1174. convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned));
  1175. case SCM_EXPANDED_TOPLEVEL_DEFINE:
  1176. return TOPLEVEL_DEFINE
  1177. (REF (exp, TOPLEVEL_DEFINE, SRC),
  1178. REF (exp, TOPLEVEL_DEFINE, MOD),
  1179. REF (exp, TOPLEVEL_DEFINE, NAME),
  1180. convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP),
  1181. assigned));
  1182. case SCM_EXPANDED_CONDITIONAL:
  1183. return CONDITIONAL
  1184. (REF (exp, CONDITIONAL, SRC),
  1185. convert_assignment (REF (exp, CONDITIONAL, TEST), assigned),
  1186. convert_assignment (REF (exp, CONDITIONAL, CONSEQUENT), assigned),
  1187. convert_assignment (REF (exp, CONDITIONAL, ALTERNATE), assigned));
  1188. case SCM_EXPANDED_CALL:
  1189. return CALL
  1190. (REF (exp, CALL, SRC),
  1191. convert_assignment (REF (exp, CALL, PROC), assigned),
  1192. convert_assignment (REF (exp, CALL, ARGS), assigned));
  1193. case SCM_EXPANDED_PRIMCALL:
  1194. return PRIMCALL
  1195. (REF (exp, PRIMCALL, SRC),
  1196. REF (exp, PRIMCALL, NAME),
  1197. convert_assignment (REF (exp, PRIMCALL, ARGS), assigned));
  1198. case SCM_EXPANDED_SEQ:
  1199. return SEQ
  1200. (REF (exp, SEQ, SRC),
  1201. convert_assignment (REF (exp, SEQ, HEAD), assigned),
  1202. convert_assignment (REF (exp, SEQ, TAIL), assigned));
  1203. case SCM_EXPANDED_LAMBDA:
  1204. return LAMBDA
  1205. (REF (exp, LAMBDA, SRC),
  1206. REF (exp, LAMBDA, META),
  1207. scm_is_false (REF (exp, LAMBDA, BODY))
  1208. /* Give a body to case-lambda with no clauses. */
  1209. ? LAMBDA_CASE (SCM_BOOL_F, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F,
  1210. SCM_EOL, SCM_EOL,
  1211. PRIMCALL
  1212. (SCM_BOOL_F,
  1213. scm_from_latin1_symbol ("throw"),
  1214. scm_list_5 (CONST_ (SCM_BOOL_F, scm_args_number_key),
  1215. CONST_ (SCM_BOOL_F, SCM_BOOL_F),
  1216. CONST_ (SCM_BOOL_F, scm_from_latin1_string
  1217. ("Wrong number of arguments")),
  1218. CONST_ (SCM_BOOL_F, SCM_EOL),
  1219. CONST_ (SCM_BOOL_F, SCM_BOOL_F))),
  1220. SCM_BOOL_F)
  1221. : convert_assignment (REF (exp, LAMBDA, BODY), assigned));
  1222. case SCM_EXPANDED_LAMBDA_CASE:
  1223. {
  1224. SCM src, req, opt, rest, kw, inits, syms, body, alt;
  1225. SCM namewalk, symwalk, new_inits, seq;
  1226. /* Box assigned formals. Since initializers can capture
  1227. previous formals, we convert initializers to be in the body
  1228. instead of in the "header". */
  1229. src = REF (exp, LAMBDA_CASE, SRC);
  1230. req = REF (exp, LAMBDA_CASE, REQ);
  1231. opt = REF (exp, LAMBDA_CASE, OPT);
  1232. rest = REF (exp, LAMBDA_CASE, REST);
  1233. kw = REF (exp, LAMBDA_CASE, KW);
  1234. inits = convert_assignment (REF (exp, LAMBDA_CASE, INITS), assigned);
  1235. syms = REF (exp, LAMBDA_CASE, GENSYMS);
  1236. body = convert_assignment (REF (exp, LAMBDA_CASE, BODY), assigned);
  1237. alt = convert_assignment (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
  1238. new_inits = scm_make_list (scm_length (inits), const_unbound);
  1239. seq = SCM_EOL, symwalk = syms;
  1240. /* Required arguments may need boxing. */
  1241. for (namewalk = req;
  1242. scm_is_pair (namewalk);
  1243. namewalk = CDR (namewalk), symwalk = CDR (symwalk))
  1244. {
  1245. SCM name = CAR (namewalk), sym = CAR (symwalk);
  1246. if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
  1247. seq = scm_cons (box_lexical (name, sym), seq);
  1248. }
  1249. /* Optional arguments may need initialization and/or boxing. */
  1250. for (namewalk = opt;
  1251. scm_is_pair (namewalk);
  1252. namewalk = CDR (namewalk), symwalk = CDR (symwalk),
  1253. inits = CDR (inits))
  1254. {
  1255. SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (inits);
  1256. seq = scm_cons (init_if_unbound (src, name, sym, init), seq);
  1257. if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
  1258. seq = scm_cons (box_lexical (name, sym), seq);
  1259. }
  1260. /* Rest arguments may need boxing. */
  1261. if (scm_is_true (rest))
  1262. {
  1263. SCM sym = CAR (symwalk);
  1264. symwalk = CDR (symwalk);
  1265. if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
  1266. seq = scm_cons (box_lexical (rest, sym), seq);
  1267. }
  1268. /* The rest of the arguments, if any, are keyword arguments,
  1269. which may need initialization and/or boxing. */
  1270. for (;
  1271. scm_is_pair (symwalk);
  1272. symwalk = CDR (symwalk), inits = CDR (inits))
  1273. {
  1274. SCM sym = CAR (symwalk), init = CAR (inits);
  1275. seq = scm_cons (init_if_unbound (src, SCM_BOOL_F, sym, init), seq);
  1276. if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
  1277. seq = scm_cons (box_lexical (SCM_BOOL_F, sym), seq);
  1278. }
  1279. for (; scm_is_pair (seq); seq = CDR (seq))
  1280. body = SEQ (src, CAR (seq), body);
  1281. return LAMBDA_CASE
  1282. (src, req, opt, rest, kw, new_inits, syms, body, alt);
  1283. }
  1284. case SCM_EXPANDED_LET:
  1285. {
  1286. SCM src, names, syms, vals, body, new_vals, walk;
  1287. src = REF (exp, LET, SRC);
  1288. names = REF (exp, LET, NAMES);
  1289. syms = REF (exp, LET, GENSYMS);
  1290. vals = convert_assignment (REF (exp, LET, VALS), assigned);
  1291. body = convert_assignment (REF (exp, LET, BODY), assigned);
  1292. for (new_vals = SCM_EOL, walk = syms;
  1293. scm_is_pair (vals);
  1294. vals = CDR (vals), walk = CDR (walk))
  1295. {
  1296. SCM sym = CAR (walk), val = CAR (vals);
  1297. if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
  1298. new_vals = scm_cons (box_value (val), new_vals);
  1299. else
  1300. new_vals = scm_cons (val, new_vals);
  1301. }
  1302. new_vals = scm_reverse (new_vals);
  1303. return LET (src, names, syms, new_vals, body);
  1304. }
  1305. case SCM_EXPANDED_LETREC:
  1306. {
  1307. SCM src, names, syms, vals, empty_box, boxes, body;
  1308. src = REF (exp, LETREC, SRC);
  1309. names = REF (exp, LETREC, NAMES);
  1310. syms = REF (exp, LETREC, GENSYMS);
  1311. vals = convert_assignment (REF (exp, LETREC, VALS), assigned);
  1312. body = convert_assignment (REF (exp, LETREC, BODY), assigned);
  1313. empty_box =
  1314. PRIMCALL (SCM_BOOL_F,
  1315. scm_from_latin1_symbol ("make-undefined-variable"),
  1316. SCM_EOL);
  1317. boxes = scm_make_list (scm_length (names), empty_box);
  1318. if (scm_is_true (REF (exp, LETREC, IN_ORDER_P)))
  1319. return LET
  1320. (src, names, syms, boxes,
  1321. init_boxes (names, syms, vals, body));
  1322. else
  1323. {
  1324. SCM walk, tmps = SCM_EOL, inits = SCM_EOL;
  1325. for (walk = syms; scm_is_pair (walk); walk = CDR (walk))
  1326. {
  1327. SCM tmp = scm_gensym (SCM_UNDEFINED);
  1328. tmps = scm_cons (tmp, tmps);
  1329. inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, SCM_BOOL_F, tmp),
  1330. inits);
  1331. }
  1332. tmps = scm_reverse (tmps);
  1333. inits = scm_reverse (inits);
  1334. return LET
  1335. (src, names, syms, boxes,
  1336. SEQ (src,
  1337. LET (src, names, tmps, vals,
  1338. init_boxes (names, syms, inits, VOID_ (src))),
  1339. body));
  1340. }
  1341. }
  1342. default:
  1343. abort ();
  1344. }
  1345. }
  1346. SCM
  1347. scm_convert_assignment (SCM exp)
  1348. {
  1349. SCM assigned = scm_c_make_hash_table (0);
  1350. compute_assigned (exp, assigned);
  1351. return convert_assignment (exp, assigned);
  1352. }
  1353. #define DEFINE_NAMES(type) \
  1354. { \
  1355. static const char *fields[] = SCM_EXPANDED_##type##_FIELD_NAMES; \
  1356. exp_field_names[SCM_EXPANDED_##type] = fields; \
  1357. exp_names[SCM_EXPANDED_##type] = SCM_EXPANDED_##type##_TYPE_NAME; \
  1358. exp_nfields[SCM_EXPANDED_##type] = SCM_NUM_EXPANDED_##type##_FIELDS; \
  1359. }
  1360. static SCM
  1361. make_exp_vtable (size_t n)
  1362. {
  1363. SCM layout, printer, name, code, fields;
  1364. layout = scm_string_to_symbol
  1365. (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields[n]),
  1366. scm_from_utf8_string ("pw"))));
  1367. printer = SCM_BOOL_F;
  1368. name = scm_from_utf8_symbol (exp_names[n]);
  1369. code = scm_from_size_t (n);
  1370. fields = SCM_EOL;
  1371. {
  1372. size_t m = exp_nfields[n];
  1373. while (m--)
  1374. fields = scm_cons (scm_from_utf8_symbol (exp_field_names[n][m]), fields);
  1375. }
  1376. return scm_c_make_struct (scm_exp_vtable_vtable, 0, 5,
  1377. SCM_UNPACK (layout), SCM_UNPACK (printer), SCM_UNPACK (name),
  1378. SCM_UNPACK (code), SCM_UNPACK (fields));
  1379. }
  1380. void
  1381. scm_init_expand ()
  1382. {
  1383. size_t n;
  1384. SCM exp_vtable_list = SCM_EOL;
  1385. DEFINE_NAMES (VOID);
  1386. DEFINE_NAMES (CONST);
  1387. DEFINE_NAMES (PRIMITIVE_REF);
  1388. DEFINE_NAMES (LEXICAL_REF);
  1389. DEFINE_NAMES (LEXICAL_SET);
  1390. DEFINE_NAMES (MODULE_REF);
  1391. DEFINE_NAMES (MODULE_SET);
  1392. DEFINE_NAMES (TOPLEVEL_REF);
  1393. DEFINE_NAMES (TOPLEVEL_SET);
  1394. DEFINE_NAMES (TOPLEVEL_DEFINE);
  1395. DEFINE_NAMES (CONDITIONAL);
  1396. DEFINE_NAMES (CALL);
  1397. DEFINE_NAMES (PRIMCALL);
  1398. DEFINE_NAMES (SEQ);
  1399. DEFINE_NAMES (LAMBDA);
  1400. DEFINE_NAMES (LAMBDA_CASE);
  1401. DEFINE_NAMES (LET);
  1402. DEFINE_NAMES (LETREC);
  1403. scm_exp_vtable_vtable =
  1404. scm_make_vtable (scm_from_utf8_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"),
  1405. SCM_BOOL_F);
  1406. for (n = 0; n < SCM_NUM_EXPANDED_TYPES; n++)
  1407. exp_vtables[n] = make_exp_vtable (n);
  1408. /* Now walk back down, consing in reverse. */
  1409. while (n--)
  1410. exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list);
  1411. const_unbound =
  1412. CONST_ (SCM_BOOL_F, scm_list_1 (scm_from_latin1_symbol ("unbound")));
  1413. scm_c_define_gsubr ("convert-assignment", 1, 0, 0, scm_convert_assignment);
  1414. scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list));
  1415. #include "expand.x"
  1416. }