home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / syntax.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-05-17  |  11.1 KB  |  408 lines
  1. /*
  2.  *
  3.  * s y n t a x . c            -- Syntaxic forms implementation
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date: 25-Oct-1993 23:39
  22.  * Last file update: 19-Sep-1995 11:49
  23.  */
  24.  
  25. /* Notes:
  26.  * ------ 
  27.  * C functions syntax_xxx implement the scheme syntax xxx. A syntax function 
  28.  * returns its work in its first argument (SCM *pform). The function result
  29.  * is a boolean. If false, it indicates to eval that this result is 
  30.  * a final one (eval can return it unmodified). Otherwise, the eval function 
  31.  * take the result stored in *pform and evaluates it again (in the same eval 
  32.  * frame). This mechanaism permits to treat tail recursive calls as jump in
  33.  * the eval function.
  34.  *
  35.  * Syntax function which returns EVALCAR(zzzz) are not tail recursive in debug 
  36.  * mode (in normal mode only the first call is non tail recursive, since this 
  37.  * first call will replace the original code by an equivalent code which is 
  38.  * clean on tail recursive calls.
  39.  *
  40.  */
  41.  
  42. #include "stk.h"
  43.  
  44.  
  45. #ifdef COMPACT_SMALL_CST
  46. #   define makecell(type) ((SCM) MAKE_SMALL_CST(0, type))
  47. #else
  48. static SCM makecell(int type)
  49. {
  50.   register SCM z;
  51.   NEWCELL(z, type);
  52.   return z;
  53. }
  54. #endif
  55.  
  56.  
  57. static SCM define2lambda(SCM l, int len)
  58. {
  59.   /* transform (define (f p) b) in (define f (lambda (p) b)) */
  60.   if (CONSP(l) && CONSP(CAR(l))){
  61.     if (len < 2) goto Error;
  62.     return Cons(CAR(CAR(l)), Cons(Cons(Sym_lambda,
  63.                        Cons(CDR(CAR(l)), CDR(l))),
  64.                   NIL));
  65.   }
  66.   else 
  67.     if (len == 2) return l;
  68. Error:
  69.   Err("define: bad parameter list", l);
  70. }
  71.  
  72. PRIMITIVE STk_syntax_quote(SCM *pform, SCM env, int len)
  73. {
  74.   SCM args = CDR(*pform);
  75.  
  76.   if (len != 1) Err("quote: Bad syntax", *pform);
  77.   if (ModifyCode()) CAR(*pform) = makecell(tc_quote);
  78.   SYNTAX_RETURN(CAR(args), Ntruth);
  79. }
  80.  
  81. PRIMITIVE STk_syntax_lambda(SCM *pform, SCM env, int len)
  82. {
  83.   register SCM z, args=CDR(*pform);
  84.  
  85.   if (len < 2) Err("lambda: bad syntax", *pform);
  86.  
  87.   if(ModifyCode()) CAR(*pform) = makecell(tc_lambda);
  88.  
  89.   NEWCELL(z, tc_closure);
  90.   z->storage_as.closure.env  = env;
  91.   z->storage_as.closure.code = args;
  92.   SYNTAX_RETURN(z, Ntruth);
  93. }
  94.  
  95.  
  96. PRIMITIVE STk_syntax_if(SCM *pform, SCM env, int len)
  97. {
  98.   SCM args = CDR(*pform);
  99.   
  100.   switch (len) {
  101.     case 2:  args = LIST3(CAR(args), CAR(CDR(args)), UNDEFINED);
  102.     case 3:  break;
  103.     default: Err("if: bad syntax", *pform);
  104.   }
  105.  
  106.   if (ModifyCode()) {
  107.     CAR(*pform) = makecell(tc_if);
  108.     CDR(*pform) = args; /* will always contain a else part */
  109.   }
  110.  
  111.   SYNTAX_RETURN(NEQ(EVALCAR(args), Ntruth) ? CAR(CDR(args)):CAR(CDR(CDR(args))), 
  112.         Truth);
  113. }
  114.  
  115. PRIMITIVE STk_syntax_setq(SCM *pform, SCM env, int len)
  116. {
  117.   SCM var, *tmp, args = CDR(*pform);
  118.  
  119.   if (len != 2)             Err("set!: bad assignement", args);
  120.   if (NSYMBOLP(var=CAR(args))) Err("set!: first argument is not a symbol", var);
  121.  
  122.   tmp = STk_varlookup(var, env, 0);
  123.   if (*tmp == UNBOUND) {
  124.     /* C variables are always seen as unbound variables. This tends to 
  125.      * make them slower than standard variables but, in counterpart, this
  126.      * doesn't slow down accesses to Scheme variables 
  127.      */
  128.     if (var->cell_info & CELL_INFO_C_VAR) {
  129.       /* This is not an unbound variable but rather a C variable */
  130.       STk_apply_setter_C_variable(PNAME(var), EVALCAR(CDR(args)));
  131.       goto Out;
  132.     }
  133.     else
  134.       Err("set!: variable not defined", var);
  135.   }
  136.   if (ModifyCode()) CAR(*pform) = makecell(tc_setq);
  137.   *tmp = EVALCAR(CDR(args));
  138.  
  139. Out:
  140.   if (TRACED_VARP(var)) STk_change_value(var, env);
  141.  
  142.   SYNTAX_RETURN(UNDEFINED, Ntruth);
  143. }
  144.  
  145. PRIMITIVE STk_syntax_cond(SCM *pform, SCM env, int len) /* len unused here */
  146. {
  147.   SCM l, tmp;
  148.   
  149.   for (l=CDR(*pform); CONSP(l); l=CDR(l)) {
  150.     if (NCONSP(CAR(l))) Err("cond: malformed clause", CAR(l));
  151.     if (EQ(CAR(CAR(l)), Sym_else) && NNULLP(CDR(l)))
  152.       Err("cond: else clause must be the last", *pform);
  153.   }
  154.   if (NNULLP(l)) Err("cond: malformed clauses list", CDR(*pform));
  155.  
  156.   tmp = Cons(makecell(tc_cond), CDR(*pform));
  157.   if (ModifyCode()) CAR(*pform) = CAR(tmp);
  158.  
  159.   SYNTAX_RETURN(tmp, Truth);
  160. }
  161.  
  162. PRIMITIVE STk_syntax_and(SCM *pform, SCM env, int len)
  163. {
  164.   SCM l   = CDR(*pform);
  165.  
  166.   if (ModifyCode()) CAR(*pform) = makecell(tc_and);
  167.  
  168.   if (len == 0) SYNTAX_RETURN(Truth, Ntruth);
  169.  
  170.   for (--len; len; len--, l=CDR(l)) {
  171.     if (EVALCAR(l) == Ntruth) SYNTAX_RETURN(Ntruth, Ntruth);
  172.   }
  173.   SYNTAX_RETURN(CAR(l), Truth);
  174. }
  175.  
  176. PRIMITIVE STk_syntax_or(SCM *pform, SCM env, int len)
  177. {
  178.   SCM l   = CDR(*pform);
  179.   SCM val;
  180.  
  181.   if (ModifyCode()) CAR(*pform) = makecell(tc_or);
  182.  
  183.   if (len == 0) SYNTAX_RETURN(Ntruth, Ntruth);
  184.  
  185.   for (--len; len; len--, l=CDR(l)) {
  186.     if ((val=EVALCAR(l)) != Ntruth) SYNTAX_RETURN(val, Ntruth);
  187.   }
  188.   SYNTAX_RETURN(CAR(l), Truth);
  189. }
  190.  
  191. static SCM syntax_let_family(SCM *pform, SCM env, char *who, int type, int len)
  192. {
  193.   register SCM p, tmp, fl=NIL, al=NIL;
  194.   char buffer[100];
  195.   int named_let = 0;
  196.  
  197.   if (len < 2) goto Error;
  198.  
  199.   p = CAR(CDR(*pform));
  200.   if (SYMBOLP(p) && type == tc_let) {
  201.     /* It's a named let. Re-initialize to a correct value */ 
  202.     if (len < 3) goto Error;
  203.     named_let = 1;
  204.     p = CAR(CDR(CDR(*pform)));
  205.   }
  206.  
  207.   for(  ; NNULLP(p); p=CDR(p)) {
  208.     if (STk_llength(tmp=CAR(p)) != 2 || NSYMBOLP(CAR(tmp))) {
  209.       sprintf(buffer, "%s: badly formed binding", who);
  210.       Err(buffer, CONSP(p)? tmp: p);
  211.     }
  212.     /* Verify that this binding doesn't already exist in fl 
  213.      * except for let* which aloows it (at least the formal semantics 
  214.      * given in R4RS). Problem shown by Brent Knight <knight@CS.Cornell.EDU>
  215.      */
  216.     if (type!=tc_letstar && STk_memv(CAR(tmp),fl)!=Ntruth) {
  217.       sprintf(buffer, "%s: duplicate binding", who);
  218.       Err(buffer, CAR(CDR(*pform)));
  219.     }
  220.     fl = Cons(CAR(tmp),fl); 
  221.     al = Cons(CAR(CDR(tmp)),al);
  222.   }
  223.  
  224.   tmp = named_let ?
  225.            /* named let */
  226.            LIST4(makecell(tc_letrec), 
  227.          LIST1(CAR(CDR(*pform))),
  228.          LIST1(Cons(Sym_lambda, 
  229.                 Cons(Reverse(fl), CDR(CDR(CDR(*pform)))))),
  230.          Cons(CAR(CDR(*pform)), Reverse(al))) :
  231.        /* normal case */
  232.        Cons(makecell(type), 
  233.         Cons(Reverse(fl), 
  234.              Cons(Reverse(al), 
  235.               CDR(CDR(*pform)))));
  236.  
  237.   if (ModifyCode()) {
  238.     CAR(*pform) = CAR(tmp); 
  239.     CDR(*pform) = CDR(tmp); 
  240.   }
  241.   SYNTAX_RETURN(tmp, Truth);
  242.  
  243. Error:
  244.   sprintf(buffer, "%s: incorrect number of subforms", who);
  245.   Err(buffer, *pform);
  246. }
  247.  
  248.  
  249. PRIMITIVE STk_syntax_let(SCM *pform, SCM env, int len)
  250. {
  251.   return syntax_let_family(pform, env, "let", tc_let, len);
  252. }
  253.  
  254. PRIMITIVE STk_syntax_letstar(SCM *pform, SCM env, int len)
  255. {
  256.   return syntax_let_family(pform, env, "let*", tc_letstar, len);
  257. }
  258.  
  259. PRIMITIVE STk_syntax_letrec(SCM *pform, SCM env, int len)
  260. {
  261.   return syntax_let_family(pform, env, "letrec", tc_letrec, len);
  262. }
  263.  
  264. PRIMITIVE STk_syntax_begin(SCM *pform, SCM env, int len)
  265. {
  266.   register SCM l = CDR(*pform);
  267.  
  268.   if (len == 0) Err("begin: no subform in sequence", l);
  269.   for ( ; NNULLP(CDR(l));  l = CDR(l))
  270.     EVALCAR(l);
  271.   if (ModifyCode()) CAR(*pform) = makecell(tc_begin);
  272.   SYNTAX_RETURN(CAR(l), Truth);;
  273. }
  274.  
  275. PRIMITIVE STk_syntax_delay(SCM *pform, SCM env, int len)
  276. {
  277.   SCM z, tmp;
  278.  
  279.   if (len != 1) Err("delay: Bad expression", *pform);
  280.  
  281.   /* Build (lambda () expr) in tmp */
  282.   NEWCELL(tmp, tc_closure);
  283.   tmp->storage_as.closure.env = env;
  284.   tmp->storage_as.closure.code = Cons(NIL, CDR(*pform));
  285.  
  286.   /* save this closure in the promise */
  287.   NEWCELL(z, tc_promise);
  288.   z->storage_as.promise.expr = tmp;
  289.   z->storage_as.promise.resultknown = 0;
  290.   SYNTAX_RETURN(z, Ntruth);
  291. }
  292.  
  293. static SCM backquotify(SCM x, SCM env, int level)
  294. {
  295.   if (VECTORP(x)) 
  296.     return STk_list2vector(backquotify(STk_vector2list(x), env, level));
  297.  
  298.   if (NCONSP(x)) return x;
  299.  
  300.   if (EQ(CAR(x), Sym_quasiquote))
  301.     return LIST2(Sym_quasiquote,
  302.          backquotify(CAR(CDR(x)), env, level+1));
  303.  
  304.   if (EQ(CAR(x), Sym_unquote))
  305.     return (level == 1) ? EVALCAR(CDR(x))
  306.                   : LIST2(Sym_unquote,
  307.                 backquotify(CAR(CDR(x)), env, level-1));
  308.  
  309.   if (CONSP(CAR(x)) && EQ(CAR(CAR(x)), Sym_unq_splicing))
  310.     return NULLP(CDR(x)) ? EVALCAR(CDR(CAR(x)))
  311.                  : STk_append(LIST2(EVALCAR(CDR(CAR(x))),
  312.                         backquotify(CDR(x), env, level)),
  313.                       2);
  314.   /* Otherwise */
  315.   return Cons(backquotify(CAR(x), env, level), backquotify(CDR(x), env, level));
  316. }
  317.  
  318.  
  319. PRIMITIVE STk_syntax_quasiquote(SCM *pform, SCM env, int len)
  320. {
  321.   if (len == 0) Err("quasiquote: no form", NIL);
  322.   SYNTAX_RETURN(backquotify(CAR(CDR(*pform)), env, 1), Ntruth);
  323. }
  324.  
  325. PRIMITIVE STk_syntax_define(SCM *pform, SCM env, int len)
  326. {
  327.   SCM *tmp, var, args;
  328.  
  329.   args = define2lambda(CDR(*pform), len);
  330.   var  = CAR(args); if (NSYMBOLP(var)) Err("define: bad variable name", var);
  331.  
  332.   if (NULLP(env)) {
  333.     /* Global var */
  334.     if (VCELL(var) == UNBOUND && (var->cell_info&CELL_INFO_C_VAR)) {
  335.       /* This is not an unbound variable but rather a C variable */
  336.       STk_apply_setter_C_variable(PNAME(var), EVALCAR(CDR(args)));
  337.     }
  338.     else {
  339.       tmp  = STk_varlookup(var, env, 0);
  340.       *tmp = EVALCAR(CDR(args));
  341.     }
  342.   }
  343.   else {
  344.     /* Local var */
  345.     tmp = STk_value_in_env(var, env);
  346.     if (tmp != &UNBOUND) {
  347.       /* This symbol was already defined at current level. Just do an assignment */
  348.       *tmp = EVALCAR(CDR(args));
  349.     }
  350.     else {
  351.       /* Extend current environment for that definition 
  352.       /* We should add new definition at the end of current environment (since some 
  353.       /* code as possbly be re-written usin tc_localvar). This avoid re-numbering 
  354.       /* acual code is FALSE */
  355.       SCM  tmp = CAR(env);
  356.     
  357.       tmp = Cons(Cons(var,           CAR(tmp)),
  358.          Cons(EVALCAR(CDR(args)), CDR(tmp)));
  359.       CAR(CAR(env)) = CAR(tmp);
  360.       CDR(CAR(env)) = CDR(tmp);
  361.     }
  362.   }
  363.   if (TRACED_VARP(var)) STk_change_value(var, env);
  364.  
  365.   SYNTAX_RETURN(UNDEFINED, Ntruth);
  366. }
  367.  
  368. /*
  369.  *
  370.  * STk special syntaxic forms
  371.  *
  372.  */
  373.  
  374. PRIMITIVE STk_syntax_extend_env(SCM *pform, SCM env, int len)
  375. {
  376.   if (len < 2) Err("extend-current-env: Bad syntax", *pform);
  377.   SYNTAX_RETURN(Cons(makecell(tc_extend_env), STk_copy_tree(CDR(*pform))),
  378.         Truth);
  379. }
  380.  
  381. PRIMITIVE STk_while(SCM l, SCM env, int len)
  382. {
  383.   register SCM test, body;
  384.  
  385.   if (len < 2) Err("while: bad argument list", NIL);
  386.   
  387.   for (test = EVALCAR(l); test != Ntruth; test = EVAL(CAR(l))) {
  388.     /* Evaluate each expression of the body */
  389.     for (body = CDR(l); !NULLP(body); body = CDR(body))
  390.       EVALCAR(body);
  391.   }
  392.   return UNDEFINED;
  393. }
  394.  
  395. PRIMITIVE STk_until(SCM l, SCM env, int len)
  396. {
  397.   register SCM test, body;
  398.  
  399.   if (len < 2) Err("until: bad argument list", NIL);
  400.   
  401.   for (test = EVALCAR(l); test == Ntruth; test = EVAL(CAR(l))) {
  402.     /* Evaluate each expression of the body */
  403.     for (body = CDR(l); !NULLP(body); body = CDR(body))
  404.       EVALCAR(body);
  405.   }
  406.   return UNDEFINED;
  407. }
  408.