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 / assignment.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  12.7 KB  |  593 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.  
  24.     assignment.c
  25.  
  26.     Assignment
  27. */
  28.  
  29. #include "include.h"
  30.  
  31. object Ssetf;
  32.  
  33. object Sget;
  34. object Saref;
  35. object Ssvref;
  36. object Selt;
  37. object Schar;
  38. object Sschar;
  39. object Sfill_pointer;
  40. object Sgethash;
  41. object Scar;
  42. object Scdr;
  43.  
  44. object Spush;
  45. object Spop;
  46. object Sincf;
  47. object Sdecf;
  48.  
  49. object siSstructure_access;
  50. object siSsetf_lambda;
  51.  
  52.  
  53.  
  54. object siSclear_compiler_properties;
  55.  
  56. object Swarn;
  57.  
  58. object siVinhibit_macro_special;
  59.  
  60.  
  61. setq(sym, val)
  62. object sym, val;
  63. {
  64.     object vd;
  65.     enum stype type;
  66.  
  67.     if(type_of(sym) != t_symbol)
  68.         not_a_symbol(sym);
  69.     type = (enum stype)sym->s.s_stype;
  70.     if(type == stp_special)
  71.         sym->s.s_dbind = val;
  72.     else
  73.     if (type == stp_constant)
  74.         FEinvalid_variable("Cannot assign to the constant ~S.", sym);
  75.     else {
  76.         vd = lex_var_sch(sym);
  77.         if(MMnull(vd) || endp(MMcdr(vd)))
  78.             sym->s.s_dbind = val;
  79.         else
  80.             MMcadr(vd) = val;
  81.     }
  82. }
  83.  
  84. Fsetq(form)
  85. object form;
  86. {
  87.     if (endp(form)) {
  88.         vs_base = vs_top;
  89.         vs_push(Cnil);
  90.     } else {
  91.         object *top = vs_top;
  92.         do {
  93.             vs_top = top;
  94.             if (endp(MMcdr(form)))
  95.             FEinvalid_form("No value for ~S.", form->c.c_car);
  96.             eval(MMcadr(form));
  97.             setq(MMcar(form), vs_base[0]);
  98.             form = MMcddr(form);
  99.         } while (!endp(form));
  100.         vs_top = vs_base+1;
  101.     }
  102. }
  103.  
  104. Fpsetq(arg)
  105. object arg;
  106. {
  107.     object *old_top = vs_top;
  108.     object *top;
  109.     object argsv = arg;
  110.     for (top = old_top;  !endp(arg);  arg = MMcddr(arg), top++) {
  111.         if(endp(MMcdr(arg)))
  112.             FEinvalid_form("No value for ~S.", arg->c.c_car);
  113.         eval(MMcadr(arg));
  114.         top[0] = vs_base[0];
  115.         vs_top = top + 1;
  116.     }
  117.     for (arg = argsv, top = old_top; !endp(arg); arg = MMcddr(arg), top++)
  118.         setq(MMcar(arg),top[0]);
  119.     vs_base = vs_top = old_top;
  120.     vs_push(Cnil);
  121. }
  122.  
  123. Lset()
  124. {
  125.     check_arg(2);
  126.     if (type_of(vs_base[0]) != t_symbol)
  127.         not_a_symbol(vs_base[0]);
  128.     if ((enum stype)vs_base[0]->s.s_stype == stp_constant)
  129.         FEinvalid_variable("Cannot assign to the constant ~S.",
  130.                    vs_base[0]);
  131.     vs_base[0]->s.s_dbind = vs_base[1];
  132.     vs_base++;
  133. }
  134.  
  135. siLfset()
  136. {
  137.     check_arg(2);
  138.     if (type_of(vs_base[0]) != t_symbol)
  139.         not_a_symbol(vs_base[0]);
  140.     if (vs_base[0]->s.s_sfdef != NOT_SPECIAL) {
  141.         if (vs_base[0]->s.s_mflag) {
  142.             if (symbol_value(siVinhibit_macro_special) != Cnil)
  143.                 vs_base[0]->s.s_sfdef = NOT_SPECIAL;
  144.         } else if (symbol_value(siVinhibit_macro_special) != Cnil)
  145.             FEerror("~S, a special form, cannot be redefined.",
  146.                 1, vs_base[0]);
  147.     }
  148.     vs_base[0] = clear_compiler_properties(vs_base[0],vs_base[1]);
  149.     if (vs_base[0]->s.s_hpack == lisp_package &&
  150.         vs_base[0]->s.s_gfdef != OBJNULL && initflag) {
  151.         vs_push(make_simple_string(
  152.             "~S is being redefined."));
  153.         ifuncall2(Swarn, vs_head, vs_base[0]);
  154.         vs_pop;
  155.     }
  156.     if (type_of(vs_base[1]) == t_cfun ||
  157.         type_of(vs_base[1]) == t_sfun ||
  158.         type_of(vs_base[1]) == t_vfun ||
  159.         type_of(vs_base[1]) == t_gfun ||
  160.         type_of(vs_base[1]) == t_cclosure
  161.         ) {
  162.         vs_base[0]->s.s_gfdef = vs_base[1];
  163.         vs_base[0]->s.s_mflag = FALSE;
  164.     } else if (car(vs_base[1]) == Sspecial)
  165.         FEerror("Cannot define a special form.", 0);
  166.     else if (vs_base[1]->c.c_car == Smacro) {
  167.         vs_base[0]->s.s_gfdef = vs_base[1]->c.c_cdr;
  168.         vs_base[0]->s.s_mflag = TRUE;
  169.     } else {
  170.         vs_base[0]->s.s_gfdef = vs_base[1];
  171.         vs_base[0]->s.s_mflag = FALSE;
  172.     }
  173.     vs_base++;
  174. }
  175.  
  176. Fmultiple_value_setq(form)
  177. object form;
  178. {
  179.     object vars;
  180.     int n, i;
  181.  
  182.     if (endp(form) || endp(form->c.c_cdr) ||
  183.         !endp(form->c.c_cdr->c.c_cdr))
  184.         FEinvalid_form("~S is an illegal argument to MULTIPLE-VALUE-SETQ",
  185.                form);
  186.     vars = form->c.c_car;
  187.     vs_push(vars);
  188.     eval(form->c.c_cdr->c.c_car);
  189.     n = vs_top - vs_base;
  190.     for (i = 0;  !endp(vars);  i++, vars = vars->c.c_cdr)
  191.         if (i < n)
  192.             setq(vars->c.c_car, vs_base[i]);
  193.         else
  194.             setq(vars->c.c_car, Cnil);
  195.     vs_top = vs_base+1;
  196. }
  197.  
  198. Lmakunbound()
  199. {
  200.     check_arg(1);
  201.     if (type_of(vs_base[0]) != t_symbol)
  202.         not_a_symbol(vs_base[0]);
  203.     if ((enum stype)vs_base[0]->s.s_stype == stp_constant)
  204.         FEinvalid_variable("Cannot unbind the constant ~S.",
  205.                    vs_base[0]);
  206.     vs_base[0]->s.s_dbind = OBJNULL;
  207. }
  208.  
  209. object siLtraced;
  210.  
  211. Lfmakunbound()
  212. {
  213.     check_arg(1);
  214.     if(type_of(vs_base[0]) != t_symbol)
  215.         not_a_symbol(vs_base[0]);
  216.     if (vs_base[0]->s.s_sfdef != NOT_SPECIAL) {
  217.         if (vs_base[0]->s.s_mflag) {
  218.             if (symbol_value(siVinhibit_macro_special) != Cnil)
  219.                 vs_base[0]->s.s_sfdef = NOT_SPECIAL;
  220.         } else if (symbol_value(siVinhibit_macro_special) != Cnil)
  221.             FEerror("~S, a special form, cannot be redefined.",
  222.                 1, vs_base[0]);
  223.     }
  224.     remf(&(vs_base[0]->s.s_plist),siLtraced);
  225.     clear_compiler_properties(vs_base[0],Cnil);
  226.     if (vs_base[0]->s.s_hpack == lisp_package &&
  227.         vs_base[0]->s.s_gfdef != OBJNULL && initflag) {
  228.         vs_push(make_simple_string(
  229.             "~S is being redefined."));
  230.         ifuncall2(Swarn, vs_head, vs_base[0]);
  231.         vs_pop;
  232.     }
  233.     vs_base[0]->s.s_gfdef = OBJNULL;
  234.     vs_base[0]->s.s_mflag = FALSE;
  235. }
  236.  
  237. Fsetf(form)
  238. object form;
  239. {
  240.     if (endp(form)) {
  241.         vs_base = vs_top;
  242.         vs_push(Cnil);
  243.     } else {
  244.         object *top = vs_top;
  245.         do {
  246.             vs_top = top;
  247.             if (endp(MMcdr(form)))
  248.             FEinvalid_form("No value for ~S.", form->c.c_car);
  249.             setf(MMcar(form), MMcadr(form));
  250.             form = MMcddr(form);
  251.         } while (!endp(form));
  252.         vs_top = vs_base+1;
  253.     }
  254. }
  255.  
  256. #define    eval_push(form)  \
  257. {  \
  258.     object *old_top = vs_top;  \
  259.   \
  260.     eval(form);  \
  261.     *old_top = vs_base[0];  \
  262.     vs_top = old_top + 1;  \
  263. }
  264.  
  265. setf(place, form)
  266. object place, form;
  267. {
  268.     object fun;
  269.     object *vs = vs_top;
  270.     int (*f)();
  271.     object args;
  272.     object x;
  273.     int i;
  274.     extern siLaset();
  275.     extern siLsvset();
  276.     extern siLelt_set();
  277.     extern siLchar_set();
  278.     extern siLfill_pointer_set();
  279.     extern siLhash_set();
  280.  
  281.     if (type_of(place) != t_cons) {
  282.         eval(form);
  283.         setq(place, vs_base[0]);
  284.         return;
  285.     }
  286.     fun = place->c.c_car;
  287.     if (type_of(fun) != t_symbol)
  288.         goto OTHERWISE;
  289.     args = place->c.c_cdr;
  290.     if (fun == Sget) {
  291.         eval_push(car(args));
  292.         eval_push(form);
  293.         eval_push(car(args->c.c_cdr));
  294.         vs_base = vs;
  295.         siLputprop();
  296.         return;
  297.     }
  298.     if (fun == Saref) { f = siLaset; goto EVAL; }
  299.     if (fun == Ssvref) { f = siLsvset; goto EVAL; }
  300.     if (fun == Selt) { f = siLelt_set; goto EVAL; }
  301.     if (fun == Schar) { f = siLchar_set; goto EVAL; }
  302.     if (fun == Sschar) { f = siLchar_set; goto EVAL; }
  303.     if (fun == Sfill_pointer) { f = siLfill_pointer_set; goto EVAL; }
  304.     if (fun == Sgethash) { f = siLhash_set; goto EVAL; }
  305.     if (fun == Scar) {
  306.         eval_push(args->c.c_car);
  307.         eval(form);
  308.         if (type_of(*vs) != t_cons)
  309.             FEerror("~S is not a cons.", 1, *vs);
  310.         (*vs)->c.c_car = vs_base[0];
  311.         return;
  312.     }
  313.     if (fun == Scdr) {
  314.         eval_push(args->c.c_car);
  315.         eval(form);
  316.         if (type_of(*vs) != t_cons)
  317.             FEerror("~S is not a cons.", 1, *vs);
  318.         (*vs)->c.c_cdr = vs_base[0];
  319.         return;
  320.     }
  321.     x = getf(fun->s.s_plist, siSstructure_access, Cnil);
  322.     if (x == Cnil || type_of(x) != t_cons)
  323.         goto OTHERWISE;
  324.     if (getf(fun->s.s_plist, siSsetf_lambda, Cnil) == Cnil)
  325.         goto OTHERWISE;
  326.     if (type_of(x->c.c_cdr) != t_fixnum)
  327.         goto OTHERWISE;
  328.     i = fix(x->c.c_cdr);
  329. /*
  330.     if (i < 0)
  331.         goto OTHERWISE;
  332. */
  333.     x = x->c.c_car;
  334.     if (x == Svector) {
  335.         eval_push(args->c.c_car);
  336.         x = *vs;
  337.         if (type_of(x) != t_vector || i >= x->v.v_fillp)
  338.             goto OTHERWISE;
  339.         eval(form);
  340.         x->v.v_self[i] = vs_base[0];
  341.     } else if (x == Slist) {
  342.         eval_push(args->c.c_car);
  343.         for (x = *vs;  i > 0;  --i)
  344.             x = cdr(x);
  345.         if (type_of(x) != t_cons)
  346.             goto OTHERWISE;
  347.         eval(form);
  348.         x->c.c_car = vs_base[0];
  349.     } else {
  350.         eval_push(args->c.c_car);
  351.         eval(form);
  352.         structure_set(*vs, x, i, vs_base[0]);
  353.     }
  354.     return;
  355.  
  356. EVAL:
  357.     for (;  !endp(args);  args = args->c.c_cdr) {
  358.         eval_push(args->c.c_car);
  359.     }
  360.     eval_push(form);
  361.     vs_base = vs;
  362.     (*f)();
  363.     return;
  364.  
  365. OTHERWISE:
  366.     vs_base = vs_top;
  367.     vs_push(Ssetf);
  368.     vs_push(place);
  369.     vs_push(form);
  370.     vs_push(Cnil);
  371.     stack_cons();
  372.     stack_cons();
  373.     stack_cons();
  374. /***/
  375. #define VS_PUSH_ENV \
  376.     if(lex_env[1]){ \
  377.       vs_push(list(3,lex_env[0],lex_env[1],lex_env[2]));} \
  378.     else {vs_push(Cnil);}
  379.         VS_PUSH_ENV ;
  380. /***/
  381.     if (!Ssetf->s.s_mflag || Ssetf->s.s_gfdef == OBJNULL)
  382.         FEerror("Where is SETF?", 0);
  383.     funcall(Ssetf->s.s_gfdef);
  384.     eval(vs_base[0]);
  385. }
  386.  
  387. Fpush(form)
  388. object form;
  389. {
  390.     object var;
  391.  
  392.     if (endp(form) || endp(MMcdr(form)))
  393.         FEtoo_few_argumentsF(form);
  394.     if (!endp(MMcddr(form)))
  395.         FEtoo_many_argumentsF(form);
  396.     var = MMcadr(form);
  397.     if (type_of(var) != t_cons) {
  398.         eval(MMcar(form));
  399.         form = vs_base[0];
  400.         eval(var);
  401.         vs_base[0] = MMcons(form, vs_base[0]);
  402.         setq(var, vs_base[0]);
  403.         return;
  404.     }
  405.     vs_base = vs_top;
  406.     vs_push(Spush);
  407.     vs_push(form);
  408.     stack_cons();
  409. /***/
  410.          VS_PUSH_ENV ;
  411. /***/
  412.     if (!Spush->s.s_mflag || Spush->s.s_gfdef == OBJNULL)
  413.         FEerror("Where is PUSH?", 0);
  414.     funcall(Spush->s.s_gfdef);
  415.     eval(vs_base[0]);
  416. }
  417.  
  418. Fpop(form)
  419. object form;
  420. {
  421.     object var;
  422.  
  423.     if (endp(form))
  424.         FEtoo_few_argumentsF(form);
  425.     if (!endp(MMcdr(form)))
  426.         FEtoo_many_argumentsF(form);
  427.     var = MMcar(form);
  428.     if (type_of(var) != t_cons) {
  429.         eval(var);
  430.         setq(var, cdr(vs_base[0]));
  431.         vs_base[0] = car(vs_base[0]);
  432.         return;
  433.     }
  434.     vs_base = vs_top;
  435.     vs_push(Spop);
  436.     vs_push(form);
  437.     stack_cons();
  438. /***/
  439.     VS_PUSH_ENV ;
  440. /***/
  441.     if (!Spop->s.s_mflag || Spop->s.s_gfdef == OBJNULL)
  442.         FEerror("Where is POP?", 0);
  443.     funcall(Spop->s.s_gfdef);
  444.     eval(vs_base[0]);
  445. }
  446.  
  447. Fincf(form)
  448. object form;
  449. {
  450.     object var;
  451.     object one_plus(), number_plus();
  452.  
  453.     if (endp(form))
  454.         FEtoo_few_argumentsF(form);
  455.     if (!endp(MMcdr(form)) && !endp(MMcddr(form)))
  456.         FEtoo_many_argumentsF(form);
  457.     var = MMcar(form);
  458.     if (type_of(var) != t_cons) {
  459.         if (endp(MMcdr(form))) {
  460.             eval(var);
  461.             vs_base[0] = one_plus(vs_base[0]);
  462.             setq(var, vs_base[0]);
  463.             return;
  464.         }
  465.         eval(MMcadr(form));
  466.         form = vs_base[0];
  467.         eval(var);
  468.         vs_base[0] = number_plus(vs_base[0], form);
  469.         setq(var, vs_base[0]);
  470.         return;
  471.     }
  472.     vs_base = vs_top;
  473.     vs_push(Sincf);
  474.     vs_push(form);
  475.     stack_cons();
  476. /***/
  477.     VS_PUSH_ENV ;
  478. /***/
  479.     if (!Sincf->s.s_mflag || Sincf->s.s_gfdef == OBJNULL)
  480.         FEerror("Where is INCF?", 0);
  481.     funcall(Sincf->s.s_gfdef);
  482.     eval(vs_base[0]);
  483. }
  484.  
  485. Fdecf(form)
  486. object form;
  487. {
  488.     object var;
  489.     object one_minus(), number_minus();
  490.  
  491.     if (endp(form))
  492.         FEtoo_few_argumentsF(form);
  493.     if (!endp(MMcdr(form)) && !endp(MMcddr(form)))
  494.         FEtoo_many_argumentsF(form);
  495.     var = MMcar(form);
  496.     if (type_of(var) != t_cons) {
  497.         if (endp(MMcdr(form))) {
  498.             eval(var);
  499.             vs_base[0] = one_minus(vs_base[0]);
  500.             setq(var, vs_base[0]);
  501.             return;
  502.         }
  503.         eval(MMcadr(form));
  504.         form = vs_base[0];
  505.         eval(var);
  506.         vs_base[0] = number_minus(vs_base[0], form);
  507.         setq(var, vs_base[0]);
  508.         return;
  509.     }
  510.     vs_base = vs_top;
  511.     vs_push(Sdecf);
  512.     vs_push(form);
  513.     stack_cons();
  514. /***/
  515.     VS_PUSH_ENV ;
  516. /***/
  517.     if (!Sdecf->s.s_mflag || Sdecf->s.s_gfdef == OBJNULL)
  518.         FEerror("Where is DECF?", 0);
  519.     funcall(Sdecf->s.s_gfdef);
  520.     eval(vs_base[0]);
  521. }
  522.  
  523.  
  524. object
  525. clear_compiler_properties(sym,code)
  526. object sym;
  527. object code;
  528. { object tem;
  529.   use_fast_links(2,Cnil,sym);
  530.   tem = getf(sym->s.s_plist,siLtraced,Cnil);
  531.   if (symbol_value(siVinhibit_macro_special) != Cnil)
  532.     (void)ifuncall2(siSclear_compiler_properties, sym,code);
  533.   if (tem != Cnil) return tem;
  534.   return sym;
  535.   
  536. }
  537.  
  538. siLclear_compiler_properties()
  539. {
  540.     check_arg(2);
  541. }
  542.  
  543.  
  544. init_assignment()
  545. {
  546.     make_special_form("SETQ", Fsetq);
  547.     make_special_form("PSETQ", Fpsetq);
  548.     make_function("SET", Lset);
  549.     make_si_function("FSET", siLfset);
  550.  
  551.     make_special_form("MULTIPLE-VALUE-SETQ", Fmultiple_value_setq);
  552.  
  553.     make_function("MAKUNBOUND", Lmakunbound);
  554.     make_function("FMAKUNBOUND", Lfmakunbound);
  555.  
  556.     Ssetf = make_ordinary("SETF");
  557.  
  558.     Sget = make_ordinary("GET");
  559.     Saref = make_ordinary("AREF");
  560.     Ssvref = make_ordinary("SVREF");
  561.     Selt = make_ordinary("ELT");
  562.     Schar = make_ordinary("CHAR");
  563.     Sschar = make_ordinary("SCHAR");
  564.     Sfill_pointer = make_ordinary("FILL-POINTER");
  565.     Sgethash = make_ordinary("GETHASH");
  566.     Scar = make_ordinary("CAR");
  567.     Scdr = make_ordinary("CDR");
  568.  
  569.     make_special_form("SETF", Fsetf);
  570.  
  571.     Spush = make_ordinary("PUSH");
  572.     Spop = make_ordinary("POP");
  573.     Sincf = make_ordinary("INCF");
  574.     Sdecf = make_ordinary("DECF");
  575.  
  576.     make_special_form("PUSH", Fpush);
  577.     make_special_form("POP", Fpop);
  578.     make_special_form("INCF", Fincf);
  579.     make_special_form("DECF", Fdecf);
  580.  
  581.     siSstructure_access = make_si_ordinary("STRUCTURE-ACCESS");
  582.     siLtraced = make_si_ordinary("TRACED");
  583.     enter_mark_origin(&siSstructure_access);
  584.     siSsetf_lambda = make_si_ordinary("SETF-LAMBDA");
  585.     enter_mark_origin(&siSsetf_lambda);
  586.     Svector = make_ordinary("VECTOR");
  587.     Slist = make_ordinary("LIST");
  588.  
  589.     siSclear_compiler_properties
  590.     = make_si_function("CLEAR-COMPILER-PROPERTIES",
  591.                siLclear_compiler_properties);
  592. }
  593.