home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / gcl-1.000 / gcl-1 / gcl-1.0 / c / let.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  6.7 KB  |  314 lines
  1. /*
  2.  Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
  3.  
  4. This file is part of GNU Common Lisp, herein referred to as GCL
  5.  
  6. GCL is free software; you can redistribute it and/or modify it under
  7. the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. GCL is distributed in the hope that it will be useful, but WITHOUT
  12. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  13. FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
  14. License for more details.
  15.  
  16. You should have received a copy of the GNU Library General Public License 
  17. along with GCL; see the file COPYING.  If not, write to the Free Software
  18. Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  19.  
  20. */
  21.  
  22. /*
  23.     let.c
  24. */
  25.  
  26. #include "include.h"
  27.  
  28. let_var_list(var_list)
  29. object var_list;
  30. {
  31.     object x, y;
  32.  
  33.     for (x = var_list;  !endp(x);  x = x->c.c_cdr) {
  34.         y = x->c.c_car;
  35.         if (type_of(y) == t_symbol) {
  36.             check_var(y);
  37.             vs_push(y);
  38.             vs_push(Cnil);
  39.             vs_push(Cnil);
  40.             vs_push(Cnil);
  41.         } else {
  42.             endp(y);
  43.             check_var(y->c.c_car);
  44.             vs_push(y->c.c_car);
  45.             vs_push(Cnil);
  46.             y = y->c.c_cdr;
  47.             if (endp(y)) /*
  48.                 FEerror("No initial form to the variable ~S.",
  49.                     1, vs_top[-2]) */ ;
  50.             else if (!endp(y->c.c_cdr))
  51.              FEerror("Too many initial forms to the variable ~S.",
  52.                  1, vs_top[-2]);
  53.             vs_push(y->c.c_car);
  54.             vs_push(Cnil);
  55.         }
  56.     }
  57. }
  58.  
  59. Flet(form)
  60. object form;
  61. {
  62.     object body;
  63.     struct bind_temp *start;
  64.     object *old_lex;
  65.     bds_ptr old_bds_top;
  66.     
  67.     if (endp(form))
  68.         FEerror("No argument to LET.", 0);
  69.  
  70.     old_lex = lex_env;
  71.     lex_copy();
  72.     old_bds_top = bds_top;
  73.  
  74.     start = (struct bind_temp *)vs_top;
  75.     let_var_list(form->c.c_car);
  76.     body = let_bind(form->c.c_cdr, start, (struct bind_temp *)vs_top);
  77.     vs_top = (object *)start;
  78.     vs_push(body);
  79.  
  80.     Fprogn(body);
  81.  
  82.     lex_env = old_lex;
  83.     bds_unwind(old_bds_top);
  84. }
  85.  
  86. FletA(form)
  87. object form;
  88. {
  89.     object body;
  90.     struct bind_temp *start;
  91.     object *old_lex;
  92.     bds_ptr old_bds_top;
  93.     
  94.     if (endp(form))
  95.         FEerror("No argument to LET*.", 0);
  96.  
  97.     old_lex = lex_env;
  98.     lex_copy();
  99.     old_bds_top = bds_top;
  100.  
  101.     start = (struct bind_temp *)vs_top;
  102.     let_var_list(form->c.c_car);
  103.     body = letA_bind(form->c.c_cdr, start, (struct bind_temp *)vs_top);
  104.     vs_top = (object *)start;
  105.     vs_push(body);
  106.  
  107.     Fprogn(body);
  108.  
  109.     lex_env = old_lex;
  110.     bds_unwind(old_bds_top);
  111. }
  112.  
  113. Fmultiple_value_bind(form)
  114. object form;
  115. {
  116.     object body, values_form, x, y;
  117.         int n, m, i;
  118.     object *base;
  119.     object *old_lex;
  120.     bds_ptr old_bds_top;
  121.     struct bind_temp *start;
  122.     
  123.     if (endp(form))
  124.         FEerror("No argument to MULTIPLE-VALUE-BIND.", 0);
  125.     body = form->c.c_cdr;
  126.     if (endp(body))
  127.         FEerror("No values-form to MULTIPLE-VALUE-BIND.", 0);
  128.     values_form = body->c.c_car;
  129.     body = body->c.c_cdr;
  130.  
  131.     old_lex = lex_env;
  132.     lex_copy();
  133.     old_bds_top = bds_top;
  134.  
  135.     eval(values_form);
  136.     base = vs_base;
  137.     m = vs_top - vs_base;
  138.  
  139.     start = (struct bind_temp *)vs_top;
  140.     for (n = 0, x = form->c.c_car;  !endp(x);  n++, x = x->c.c_cdr) {
  141.         y = x->c.c_car;
  142.         check_var(y);
  143.         vs_push(y);
  144.         vs_push(Cnil);
  145.         vs_push(Cnil);
  146.         vs_push(Cnil);
  147.     }
  148.     {
  149.      object *vt = vs_top;
  150.      vs_push(find_special(body, start, (struct bind_temp *)vt));
  151.     }
  152.     for (i = 0;  i < n;  i++)
  153.         bind_var(start[i].bt_var,
  154.              (i < m ? base[i] : Cnil),
  155.              start[i].bt_spp);
  156.     body = vs_pop;
  157.  
  158.     vs_top = vs_base = base;
  159.  
  160.     vs_push(body);
  161.     Fprogn(body);
  162.     lex_env = old_lex;
  163.     bds_unwind(old_bds_top);
  164. }
  165.  
  166. Fcompiler_let(form)
  167. object form;
  168. {
  169.     object body, x, y;
  170.     object *old_lex;
  171.     bds_ptr old_bds_top;
  172.     struct bind_temp *start, *end, *bt;
  173.     
  174.     if (endp(form))
  175.         FEerror("No argument to COMPILER-LET.", 0);
  176.  
  177.     body = form->c.c_cdr;
  178.  
  179.     old_lex = lex_env;
  180.     lex_copy();
  181.     old_bds_top = bds_top;
  182.  
  183.     start = (struct bind_temp *)vs_top;
  184.     let_var_list(form->c.c_car);
  185.     end = (struct bind_temp *)vs_top;
  186.     for (bt = start;  bt < end;  bt++) {
  187.         eval_assign(bt->bt_init, bt->bt_init);
  188.     }
  189.     for (bt = start;  bt < end;  bt++)
  190.         bind_var(bt->bt_var, bt->bt_init, Ct);
  191.  
  192.     vs_top = (object *)start;
  193.  
  194.     Fprogn(body);
  195.  
  196.     lex_env = old_lex;
  197.     bds_unwind(old_bds_top);
  198. }
  199.  
  200. Fflet(args)
  201. object args;
  202. {
  203.     object def_list;
  204.     object def;
  205.     object *lex = lex_env;
  206.     object *top = vs_top;
  207.  
  208.     vs_push(Cnil);            /*  space for each closure  */
  209.     if (endp(args))
  210.         FEtoo_few_argumentsF(args);
  211.     def_list = MMcar(args);
  212.     lex_copy();
  213.     while (!endp(def_list)) {
  214.         def = MMcar(def_list);
  215.         if (endp(def) || endp(MMcdr(def)) ||
  216.             type_of(MMcar(def)) != t_symbol)
  217.             FEerror("~S~%\
  218. is an illegal function definition in FLET.",
  219.                 1, def);
  220.         top[0] = MMcons(lex[2], def);
  221.         top[0] = MMcons(lex[1], top[0]);
  222.         top[0] = MMcons(lex[0], top[0]);
  223.         top[0] = MMcons(Slambda_block_closure, top[0]);
  224.         lex_fun_bind(MMcar(def), top[0]);
  225.         def_list = MMcdr(def_list);
  226.     }
  227.     vs_push(find_special(MMcdr(args), NULL, NULL));
  228.     Fprogn(vs_head);
  229.     lex_env = lex;
  230. }
  231.  
  232. Flabels(args)
  233. object args;
  234. {
  235.     object def_list;
  236.     object def;
  237.     object closure_list;
  238.     object *lex = lex_env;
  239.     object *top = vs_top;
  240.  
  241.         vs_push(Cnil);            /*  space for each closure  */
  242.     vs_push(Cnil);            /*  space for closure-list  */
  243.     if (endp(args))
  244.         FEtoo_few_argumentsF(args);
  245.     def_list = MMcar(args);
  246.     lex_copy();
  247.     while (!endp(def_list)) {
  248.         def = MMcar(def_list);
  249.         if (endp(def) || endp(MMcdr(def)) ||
  250.             type_of(MMcar(def)) != t_symbol)
  251.             FEerror("~S~%\
  252. is an illegal function definition in LABELS.",
  253.                 1, def);
  254.         top[0] = MMcons(lex[2], def);
  255.         top[0] = MMcons(Cnil, top[0]);
  256.         top[1] = MMcons(top[0], top[1]);
  257.         top[0] = MMcons(lex[0], top[0]);
  258.         top[0] = MMcons(Slambda_block_closure, top[0]);
  259.         lex_fun_bind(MMcar(def), top[0]);
  260.         def_list = MMcdr(def_list);
  261.     }
  262.     closure_list = top[1];
  263.     while (!endp(closure_list)) {
  264.         MMcaar(closure_list) = lex_env[1];
  265.         closure_list = MMcdr(closure_list);
  266.     }
  267.     vs_push(find_special(MMcdr(args), NULL, NULL));
  268.     Fprogn(vs_head);
  269.     lex_env = lex;
  270. }
  271.  
  272. Fmacrolet(args)
  273. object args;
  274. {
  275.     object def_list;
  276.     object def;
  277.     object *lex = lex_env;
  278.     object *top = vs_top;
  279.  
  280.     vs_push(Cnil);            /*  space for each macrodef  */
  281.     if (endp(args))
  282.         FEtoo_few_argumentsF(args);
  283.     def_list = MMcar(args);
  284.     lex_copy();
  285.     while (!endp(def_list)) {
  286.         def = MMcar(def_list);
  287.         if (endp(def) || endp(MMcdr(def)) ||
  288.             type_of(MMcar(def)) != t_symbol)
  289.             FEerror("~S~%\
  290. is an illegal macro definition in MACROFLET.",
  291.                 1, def);
  292.         top[0] = ifuncall3(siSdefmacroA,
  293.                    MMcar(def),
  294.                    MMcadr(def),
  295.                    MMcddr(def));
  296.         lex_macro_bind(MMcar(def), MMcaddr(top[0]));
  297.         def_list = MMcdr(def_list);
  298.     }
  299.     vs_push(find_special(MMcdr(args), NULL, NULL));
  300.     Fprogn(vs_head);
  301.     lex_env = lex;
  302. }
  303.  
  304. init_let()
  305. {
  306.     make_special_form("LET", Flet);
  307.     make_special_form("LET*", FletA);
  308.     make_special_form("MULTIPLE-VALUE-BIND", Fmultiple_value_bind);
  309.     make_special_form("COMPILER-LET", Fcompiler_let);
  310.     make_special_form("FLET",Fflet);
  311.     make_special_form("LABELS",Flabels);
  312.     make_special_form("MACROLET",Fmacrolet);
  313. }
  314.