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 / conditional.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-07  |  3.8 KB  |  200 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.     conditional.c
  25.  
  26.     conditionals
  27. */
  28.  
  29. #include "include.h"
  30.  
  31. object Sotherwise;
  32.  
  33. Fif(form)
  34. object form;
  35. {
  36.     object *top = vs_top;
  37.  
  38.     if (endp(form) || endp(MMcdr(form)))
  39.         FEtoo_few_argumentsF(form);
  40.     if (!endp(MMcddr(form)) && !endp(MMcdddr(form)))
  41.         FEtoo_many_argumentsF(form);
  42.     eval(MMcar(form));
  43.     if (vs_base[0] == Cnil)
  44.         if (endp(MMcddr(form))) {
  45.             vs_top = vs_base = top;
  46.             vs_push(Cnil);
  47.         } else {
  48.             vs_top = top;
  49.             eval(MMcaddr(form));
  50.         }
  51.     else {
  52.         vs_top = top;
  53.         eval(MMcadr(form));
  54.     }
  55. }
  56.  
  57. Fcond(args)
  58. object args;
  59. {
  60.     object *top = vs_top;
  61.     object clause;
  62.     object conseq;
  63.  
  64.     while (!endp(args)) {
  65.         clause = MMcar(args);
  66.         if (type_of(clause) != t_cons)
  67.             FEerror("~S is an illegal COND clause.",1,clause);
  68.         eval(MMcar(clause));
  69.         if (vs_base[0] != Cnil) {
  70.             conseq = MMcdr(clause);
  71.             if (endp(conseq)) {
  72.                 vs_top = vs_base+1;
  73.                 return;
  74.             }
  75.             while (!endp(conseq)) {
  76.                 vs_top = top;
  77.                 eval(MMcar(conseq));
  78.                 conseq = MMcdr(conseq);
  79.             }
  80.             return;
  81.         }
  82.         vs_top = top;
  83.         args = MMcdr(args);
  84.     }
  85.     vs_base = vs_top = top;
  86.     vs_push(Cnil);
  87. }
  88.  
  89. Fcase(arg)
  90. object arg;
  91. {
  92.     object *top = vs_top;
  93.     object clause;
  94.     object key;
  95.     object conseq;
  96.  
  97.     if (endp(arg))
  98.         FEtoo_few_argumentsF(arg);
  99.     eval(MMcar(arg));
  100.     vs_top = top;
  101.     vs_push(vs_base[0]);
  102.     arg = MMcdr(arg);
  103.     while (!endp(arg)) {
  104.         clause = MMcar(arg);
  105.         if (type_of(clause) != t_cons)
  106.             FEerror("~S is an illegal CASE clause.",1,clause);
  107.         key = MMcar(clause);
  108.         conseq = MMcdr(clause);
  109.         if (type_of(key) == t_cons)
  110.             do {
  111.                 if (eql(MMcar(key),top[0]))
  112.                     goto FOUND;
  113.                 key = MMcdr(key);
  114.             } while (!endp(key));
  115.         else if (key == Cnil)
  116.             ;
  117.         else if (key == Ct || key == Sotherwise || eql(key,top[0]))
  118.             goto FOUND;
  119.         arg = MMcdr(arg);
  120.     }
  121.     vs_base = vs_top = top;
  122.     vs_push(Cnil);
  123.     return;
  124.  
  125. FOUND:
  126.     if (endp(conseq)) {
  127.         vs_base = vs_top = top;
  128.         vs_push(Cnil);
  129.     } else
  130.          do {
  131.             vs_top = top;
  132.             eval(MMcar(conseq));
  133.             conseq = MMcdr(conseq);
  134.         } while (!endp(conseq));
  135.     return;
  136. }
  137.  
  138. Fwhen(form)
  139. object form;
  140. {
  141.     object *top = vs_top;
  142.  
  143.     if (endp(form))
  144.         FEtoo_few_argumentsF(form);
  145.     eval(MMcar(form));
  146.     if (vs_base[0] == Cnil) {
  147.         vs_base = vs_top = top;
  148.         vs_push(Cnil);
  149.     } else {
  150.         form = MMcdr(form);
  151.         if (endp(form)) {
  152.             vs_base = vs_top = top;
  153.             vs_push(Cnil);
  154.         } else
  155.             do {
  156.                 vs_top = top;
  157.                 eval(MMcar(form));
  158.                 form = MMcdr(form);
  159.             } while (!endp(form));
  160.     }
  161. }
  162.  
  163. Funless(form)
  164. object form;
  165. {
  166.     object *top = vs_top;
  167.  
  168.     if (endp(form))
  169.         FEtoo_few_argumentsF(form);
  170.     eval(MMcar(form));
  171.     if (vs_base[0] == Cnil) {
  172.         vs_top = top;
  173.         form = MMcdr(form);
  174.         if (endp(form)) {
  175.             vs_base = vs_top = top;
  176.             vs_push(Cnil);
  177.         } else
  178.             do {
  179.                 vs_top = top;
  180.                 eval(MMcar(form));
  181.                 form = MMcdr(form);
  182.             } while (!endp(form));
  183.     } else {
  184.         vs_base = vs_top = top;
  185.         vs_push(Cnil);
  186.     }
  187. }
  188.  
  189. init_conditional()
  190. {
  191.     make_special_form("IF",Fif);
  192.     make_special_form("COND",Fcond);
  193.     make_special_form("CASE",Fcase);
  194.     make_special_form("WHEN",Fwhen);
  195.     make_special_form("UNLESS",Funless);
  196.  
  197.     Sotherwise = make_ordinary("OTHERWISE");
  198.     enter_mark_origin(&Sotherwise);
  199. }
  200.