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 / Extensions / when.c < prev   
Encoding:
C/C++ Source or Header  |  1995-02-25  |  810 b   |  38 lines
  1. #include <stk.h>
  2.  
  3. static PRIMITIVE STk_when(SCM l, SCM env)
  4. {
  5.   SCM res = UNDEFINED;
  6.  
  7.   if (NULLP(l)) Err("when: no argument list given", NIL);
  8.   if (STk_eval(CAR(l), env) != Ntruth) {
  9.     if (NULLP(l = CDR(l))) Err("when: null body", NIL);
  10.     
  11.     /* Argument list is well formed. Evaluates each expression of the body */
  12.     for (  ; !NULLP(l); l = CDR(l))
  13.       res = STk_eval(CAR(l), env);
  14.   }
  15.   return res;
  16. }
  17.  
  18. static PRIMITIVE STk_unless(SCM l, SCM env)
  19. {
  20.   SCM res = UNDEFINED;
  21.  
  22.   if (!NULLP(l)) {
  23.     if (STk_eval(CAR(l), env) == Ntruth) {
  24.       for (l = CDR(l); !NULLP(l); l = CDR(l)) {
  25.     res = STk_eval(CAR(l), env);
  26.       }
  27.     }
  28.   }
  29.   return res;
  30. }
  31.  
  32.   
  33. void STk_init_when(void)
  34. {
  35.   STk_add_new_primitive("when",        tc_fsubr, STk_when);
  36.   STk_add_new_primitive("unless",       tc_fsubr, STk_unless);
  37. }
  38.