/[cvs]/stack/symbols.c
ViewVC logotype

Diff of /stack/symbols.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3 by masse, Mon Aug 4 14:32:27 2003 UTC revision 1.11 by masse, Thu Feb 19 15:35:38 2004 UTC
# Line 1  Line 1 
1    /*
2        stack - an interactive interpreter for a stack-based language
3        Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
4    
5        This program is free software; you can redistribute it and/or modify
6        it under the terms of the GNU General Public License as published by
7        the Free Software Foundation; either version 2 of the License, or
8        (at your option) any later version.
9    
10        This program is distributed in the hope that it will be useful,
11        but WITHOUT ANY WARRANTY; without even the implied warranty of
12        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13        GNU General Public License for more details.
14    
15        You should have received a copy of the GNU General Public License
16        along with this program; if not, write to the Free Software
17        Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
18    
19        Authors: Mats Alritzson <masse@fukt.bth.se>
20                 Teddy Hogeborn <teddy@fukt.bth.se>
21    */
22    
23  #include "stack.h"  #include "stack.h"
24    #include "messages.h"
25    
26  /* Print newline. */  /* Print newline. */
27  extern void nl(environment *env)  extern void nl(environment *env)
# Line 9  extern void nl(environment *env) Line 32  extern void nl(environment *env)
32  /* Print a newline to a port */  /* Print a newline to a port */
33  extern void nlport(environment *env)  extern void nlport(environment *env)
34  {  {
35    if(env->head->type==empty) {    if(check_args(env, 1, port))
36      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
37    
38    if(CAR(env->head)->type!=port) {    if(fprintf(CAR(env->head)->content.p, "\n") < 0) {
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   if(fprintf(CAR(env->head)->content.p, "\n") < 0){  
     perror("nl");  
39      env->err= 5;      env->err= 5;
40      return;      return printerr(env);
41    }    }
42    
43    toss(env);    toss(env);
44  }  }
45    
46  /* Gets the type of a value */  /* Gets the type of a value */
47  extern void type(environment *env)  extern void type(environment *env)
48  {  {
49    if(env->head->type==empty) {  
50      printerr("Too Few Arguments");    if(check_args(env, 1, unknown))
51      env->err= 1;      return printerr(env);
     return;  
   }  
52    
53    switch(CAR(env->head)->type){    switch(CAR(env->head)->type){
54    case empty:    case empty:
55      push_sym(env, "empty");      push_sym(env, "empty");
56      break;      break;
57      case unknown:
58        push_sym(env, "unknown");
59        break;
60    case integer:    case integer:
61      push_sym(env, "integer");      push_sym(env, "integer");
62      break;      break;
# Line 72  extern void type(environment *env) Line 87  extern void type(environment *env)
87  /* Print the top element of the stack but don't discard it */  /* Print the top element of the stack but don't discard it */
88  extern void print_(environment *env)  extern void print_(environment *env)
89  {  {
90    if(env->head->type==empty) {  
91      printerr("Too Few Arguments");    if(check_args(env, 1, unknown))
92      env->err= 1;      return printerr(env);
93      return;  
   }  
94    print_val(env, CAR(env->head), 0, NULL, stdout);    print_val(env, CAR(env->head), 0, NULL, stdout);
95    if(env->err) return;    if(env->err) return;
96    nl(env);    nl(env);
# Line 94  extern void print(environment *env) Line 108  extern void print(environment *env)
108     discard it. */     discard it. */
109  extern void princ_(environment *env)  extern void princ_(environment *env)
110  {  {
111    if(env->head->type==empty) {  
112      printerr("Too Few Arguments");    if(check_args(env, 1, unknown))
113      env->err= 1;      return printerr(env);
114      return;  
   }  
115    print_val(env, CAR(env->head), 1, NULL, stdout);    print_val(env, CAR(env->head), 1, NULL, stdout);
116  }  }
117    
# Line 113  extern void princ(environment *env) Line 126  extern void princ(environment *env)
126  /* Print a value to a port, but don't discard it */  /* Print a value to a port, but don't discard it */
127  extern void printport_(environment *env)  extern void printport_(environment *env)
128  {  {
   if(env->head->type==empty ||  CDR(env->head)->type == empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
129    
130    if(CAR(env->head)->type!=port) {    if(check_args(env, 2, port, unknown))
131      printerr("Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
132    
133    print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);    print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);
134    if(env->err) return;    if(env->err) return;
# Line 141  extern void printport(environment *env) Line 146  extern void printport(environment *env)
146  /* Print, without quotes, to a port, a value, but don't discard it. */  /* Print, without quotes, to a port, a value, but don't discard it. */
147  extern void princport_(environment *env)  extern void princport_(environment *env)
148  {  {
   if(env->head->type==empty ||  CDR(env->head)->type == empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
149    
150    if(CAR(env->head)->type!=port) {    if(check_args(env, 2, port, unknown))
151      printerr("Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
152    
153    print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);    print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);
154    toss(env); if(env->err) return;    toss(env); if(env->err) return;
# Line 169  extern void princport(environment *env) Line 166  extern void princport(environment *env)
166  extern void rot(environment *env)  extern void rot(environment *env)
167  {  {
168    value *temp= env->head;    value *temp= env->head;
169      
170    if(env->head->type == empty || CDR(env->head)->type == empty    if(check_args(env, 3, unknown, unknown, unknown))
171       || CDR(CDR(env->head))->type == empty) {      return printerr(env);
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
172        
173    env->head= CDR(CDR(env->head));    env->head= CDR(CDR(env->head));
174    CDR(CDR(temp))= CDR(env->head);    CDR(CDR(temp))= CDR(env->head);
# Line 187  extern void expand(environment *env) Line 180  extern void expand(environment *env)
180  {  {
181    value *temp, *new_head;    value *temp, *new_head;
182    
183    /* Is top element a list? */    if(check_args(env, 1, tcons))
184    if(env->head->type==empty) {      return printerr(env);
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=tcons) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
185    
186    rev(env);    rev(env);
187    
# Line 210  extern void expand(environment *env) Line 193  extern void expand(environment *env)
193    
194    toss(env);    toss(env);
195    
196      /// XXX
197    /* Find the end of the list */    /* Find the end of the list */
198    while(CDR(temp)->type != empty) {    while(CDR(temp)->type != empty) {
199      if (CDR(temp)->type == tcons)      if (CDR(temp)->type == tcons)
200        temp= CDR(temp);        temp= CDR(temp);
201      else {      else {
202        printerr("Bad Argument Type"); /* Improper list */        env->err= 2; /* Improper list */
203        env->err= 2;        return printerr(env);
       return;  
204      }      }
205    }    }
206    
# Line 232  extern void eq(environment *env) Line 215  extern void eq(environment *env)
215  {  {
216    void *left, *right;    void *left, *right;
217    
218    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, unknown, unknown))
219      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
220    
221    left= CAR(env->head)->content.ptr;    left= CAR(env->head)->content.ptr;
222    right= CAR(CDR(env->head))->content.ptr;    right= CAR(CDR(env->head))->content.ptr;
# Line 250  extern void not(environment *env) Line 230  extern void not(environment *env)
230  {  {
231    int val;    int val;
232    
233    if(env->head->type==empty) {    if(check_args(env, 1, integer))
234      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
235    
236    val= CAR(env->head)->content.i;    val= CAR(env->head)->content.i;
237    toss(env);    toss(env);
# Line 280  extern void def(environment *env) Line 251  extern void def(environment *env)
251    symbol *sym;    symbol *sym;
252    
253    /* Needs two values on the stack, the top one must be a symbol */    /* Needs two values on the stack, the top one must be a symbol */
254    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, symb, unknown))
255      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
256    
257    /* long names are a pain */    /* long names are a pain */
258    sym= CAR(env->head)->content.sym;    sym= CAR(env->head)->content.sym;
# Line 304  extern void def(environment *env) Line 266  extern void def(environment *env)
266  /* Clear stack */  /* Clear stack */
267  extern void clear(environment *env)  extern void clear(environment *env)
268  {  {
269    while(env->head->type != empty)    env->head= new_val(env);
     toss(env);  
270  }  }
271    
272  /* Forgets a symbol (remove it from the hash table) */  /* Forgets a symbol (remove it from the hash table) */
# Line 313  extern void forget(environment *env) Line 274  extern void forget(environment *env)
274  {  {
275    char* sym_id;    char* sym_id;
276    
277    if(env->head->type==empty) {    if(check_args(env, 1, symb))
278      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
279    
280    sym_id= CAR(env->head)->content.sym->id;    sym_id= CAR(env->head)->content.sym->id;
281    toss(env);    toss(env);
# Line 346  extern void sx_2b(environment *env) Line 298  extern void sx_2b(environment *env)
298    char* new_string;    char* new_string;
299    value *a_val, *b_val;    value *a_val, *b_val;
300    
301    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, string, string)==0) {
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type==string  
      && CAR(CDR(env->head))->type==string) {  
302      a_val= CAR(env->head);      a_val= CAR(env->head);
303      b_val= CAR(CDR(env->head));      b_val= CAR(CDR(env->head));
304      protect(a_val); protect(b_val);      protect(a_val); protect(b_val);
# Line 371  extern void sx_2b(environment *env) Line 316  extern void sx_2b(environment *env)
316      return;      return;
317    }    }
318        
319    if(CAR(env->head)->type==integer    if(check_args(env, 2, integer, integer)==0) {
      && CAR(CDR(env->head))->type==integer) {  
320      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
321      toss(env); if(env->err) return;      toss(env); if(env->err) return;
322      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 382  extern void sx_2b(environment *env) Line 326  extern void sx_2b(environment *env)
326      return;      return;
327    }    }
328    
329    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
330      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
331      toss(env); if(env->err) return;      toss(env); if(env->err) return;
332      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 393  extern void sx_2b(environment *env) Line 336  extern void sx_2b(environment *env)
336      return;      return;
337    }    }
338    
339    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, integer)==0) {
      && CAR(CDR(env->head))->type==integer) {  
340      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
341      toss(env); if(env->err) return;      toss(env); if(env->err) return;
342      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 404  extern void sx_2b(environment *env) Line 346  extern void sx_2b(environment *env)
346      return;      return;
347    }    }
348    
349    if(CAR(env->head)->type==integer    if(check_args(env, 2, integer, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
350      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
351      toss(env); if(env->err) return;      toss(env); if(env->err) return;
352      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 415  extern void sx_2b(environment *env) Line 356  extern void sx_2b(environment *env)
356      return;      return;
357    }    }
358    
359    printerr("Bad Argument Type");    return printerr(env);
   env->err=2;  
360  }  }
361    
362  /* "-" */  /* "-" */
# Line 425  extern void sx_2d(environment *env) Line 365  extern void sx_2d(environment *env)
365    int a, b;    int a, b;
366    float fa, fb;    float fa, fb;
367    
368    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, integer, integer)==0) {
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
369      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
370      toss(env); if(env->err) return;      toss(env); if(env->err) return;
371      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 442  extern void sx_2d(environment *env) Line 375  extern void sx_2d(environment *env)
375      return;      return;
376    }    }
377    
378    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
379      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
380      toss(env); if(env->err) return;      toss(env); if(env->err) return;
381      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 453  extern void sx_2d(environment *env) Line 385  extern void sx_2d(environment *env)
385      return;      return;
386    }    }
387    
388    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, integer)==0) {
      && CAR(CDR(env->head))->type==integer) {  
389      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
390      toss(env); if(env->err) return;      toss(env); if(env->err) return;
391      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 464  extern void sx_2d(environment *env) Line 395  extern void sx_2d(environment *env)
395      return;      return;
396    }    }
397    
398    if(CAR(env->head)->type==integer    if(check_args(env, 2, integer, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
399      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
400      toss(env); if(env->err) return;      toss(env); if(env->err) return;
401      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 475  extern void sx_2d(environment *env) Line 405  extern void sx_2d(environment *env)
405      return;      return;
406    }    }
407    
408    printerr("Bad Argument Type");    return printerr(env);
   env->err=2;  
409  }  }
410    
411  /* ">" */  /* ">" */
# Line 485  extern void sx_3e(environment *env) Line 414  extern void sx_3e(environment *env)
414    int a, b;    int a, b;
415    float fa, fb;    float fa, fb;
416    
417    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, integer, integer)==0) {
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
418      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
419      toss(env); if(env->err) return;      toss(env); if(env->err) return;
420      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 502  extern void sx_3e(environment *env) Line 424  extern void sx_3e(environment *env)
424      return;      return;
425    }    }
426    
427    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
428      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
429      toss(env); if(env->err) return;      toss(env); if(env->err) return;
430      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 513  extern void sx_3e(environment *env) Line 434  extern void sx_3e(environment *env)
434      return;      return;
435    }    }
436    
437    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, integer)==0) {
      && CAR(CDR(env->head))->type==integer) {  
438      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
439      toss(env); if(env->err) return;      toss(env); if(env->err) return;
440      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 524  extern void sx_3e(environment *env) Line 444  extern void sx_3e(environment *env)
444      return;      return;
445    }    }
446    
447    if(CAR(env->head)->type==integer    if(check_args(env, 2, integer, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
448      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
449      toss(env); if(env->err) return;      toss(env); if(env->err) return;
450      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 535  extern void sx_3e(environment *env) Line 454  extern void sx_3e(environment *env)
454      return;      return;
455    }    }
456    
457    printerr("Bad Argument Type");    return printerr(env);
   env->err= 2;  
458  }  }
459    
460  /* "<" */  /* "<" */
# Line 563  extern void sx_3e3d(environment *env) Line 481  extern void sx_3e3d(environment *env)
481  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
482  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
483  {  {
484    if(env->head->type==empty) {    if(check_args(env, 1, unknown))
485      printerr("Too Few Arguments");      return printerr(env);
486      env->err= 1;  
     return;  
   }  
487    push_val(env, copy_val(env, CAR(env->head)));    push_val(env, copy_val(env, CAR(env->head)));
488  }  }
489    
# Line 576  extern void sx_6966(environment *env) Line 492  extern void sx_6966(environment *env)
492  {  {
493    int truth;    int truth;
494    
495    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, unknown, integer))
496      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
497    
   if(CAR(CDR(env->head))->type != integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
     
498    swap(env);    swap(env);
499    if(env->err) return;    if(env->err) return;
500        
# Line 607  extern void ifelse(environment *env) Line 514  extern void ifelse(environment *env)
514  {  {
515    int truth;    int truth;
516    
517    if(env->head->type==empty || CDR(env->head)->type==empty    if(check_args(env, 3, unknown, unknown, integer))
518       || CDR(CDR(env->head))->type==empty) {      return printerr(env);
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
519    
   if(CAR(CDR(CDR(env->head)))->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
     
520    rot(env);    rot(env);
521    if(env->err) return;    if(env->err) return;
522        
# Line 641  extern void ifelse(environment *env) Line 538  extern void ifelse(environment *env)
538  /* "else" */  /* "else" */
539  extern void sx_656c7365(environment *env)  extern void sx_656c7365(environment *env)
540  {  {
541    if(env->head->type==empty || CDR(env->head)->type==empty  
542       || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty    if(check_args(env, 5, unknown, symb, unknown, symb, integer))
543       || CDR(CDR(CDR(CDR(env->head))))->type==empty) {      return printerr(env);
544      printerr("Too Few Arguments");  
545      env->err= 1;    /// XXX
     return;  
   }  
546    
547    if(CAR(CDR(env->head))->type!=symb    if(CAR(CDR(env->head))->type!=symb
548       || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0       || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
549       || CAR(CDR(CDR(CDR(env->head))))->type!=symb       || CAR(CDR(CDR(CDR(env->head))))->type!=symb
550       || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {       || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
     printerr("Bad Argument Type");  
551      env->err= 2;      env->err= 2;
552      return;      return printerr(env);
553    }    }
554    
555    swap(env); toss(env); rot(env); toss(env);    swap(env); toss(env); rot(env); toss(env);
# Line 664  extern void sx_656c7365(environment *env Line 558  extern void sx_656c7365(environment *env
558    
559  extern void then(environment *env)  extern void then(environment *env)
560  {  {
561    if(env->head->type==empty || CDR(env->head)->type==empty    
562       || CDR(CDR(env->head))->type==empty) {    if(check_args(env, 3, unknown, symb, integer))
563      printerr("Too Few Arguments");      return printerr(env);
564      env->err= 1;  
565      return;    /// XXX
   }  
566    
567    if(CAR(CDR(env->head))->type!=symb    if(CAR(CDR(env->head))->type!=symb
568       || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {       || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
     printerr("Bad Argument Type");  
569      env->err= 2;      env->err= 2;
570      return;      return printerr(env);
571    }    }
572    
573    swap(env); toss(env);    swap(env); toss(env);
# Line 688  extern void sx_7768696c65(environment *e Line 580  extern void sx_7768696c65(environment *e
580    int truth;    int truth;
581    value *loop, *test;    value *loop, *test;
582    
583    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, unknown, integer))
584      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
585    
586    loop= CAR(env->head);    loop= CAR(env->head);
587    protect(loop);    protect(loop);
# Line 705  extern void sx_7768696c65(environment *e Line 594  extern void sx_7768696c65(environment *e
594    do {    do {
595      push_val(env, test);      push_val(env, test);
596      eval(env);      eval(env);
597    
598        /// XXX
599            
600      if(CAR(env->head)->type != integer) {      if(CAR(env->head)->type != integer) {
       printerr("Bad Argument Type");  
601        env->err= 2;        env->err= 2;
602        return;        return printerr(env);
603      }      }
604            
605      truth= CAR(env->head)->content.i;      truth= CAR(env->head)->content.i;
# Line 734  extern void sx_666f72(environment *env) Line 624  extern void sx_666f72(environment *env)
624    value *loop;    value *loop;
625    int foo1, foo2;    int foo1, foo2;
626    
627    if(env->head->type==empty || CDR(env->head)->type==empty    if(check_args(env, 3, unknown, integer, integer))
628       || CDR(CDR(env->head))->type==empty) {      return printerr(env);
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(CDR(env->head))->type!=integer  
      || CAR(CDR(CDR(env->head)))->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
629    
630    loop= CAR(env->head);    loop= CAR(env->head);
631    protect(loop);    protect(loop);
# Line 782  extern void foreach(environment *env) Line 661  extern void foreach(environment *env)
661  {    {  
662    value *loop, *foo;    value *loop, *foo;
663    value *iterator;    value *iterator;
     
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(CDR(env->head))->type!=tcons) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
664    
665      if(check_args(env, 2, unknown, tcons))
666        return printerr(env);
667      
668    loop= CAR(env->head);    loop= CAR(env->head);
669    protect(loop);    protect(loop);
670    toss(env); if(env->err) return;    toss(env); if(env->err) return;
# Line 809  extern void foreach(environment *env) Line 679  extern void foreach(environment *env)
679      push_val(env, CAR(iterator));      push_val(env, CAR(iterator));
680      push_val(env, loop);      push_val(env, loop);
681      eval(env); if(env->err) return;      eval(env); if(env->err) return;
682    
683        /// XXX
684      if (iterator->type == tcons){      if (iterator->type == tcons){
685        iterator= CDR(iterator);        iterator= CDR(iterator);
686      } else {      } else {
687        printerr("Bad Argument Type"); /* Improper list */        env->err= 2; /* Improper list */
       env->err= 2;  
688        break;        break;
689      }      }
690    }    }
691    unprotect(loop); unprotect(foo);    unprotect(loop); unprotect(foo);
692      
693      return printerr(env);
694  }  }
695    
696  /* "to" */  /* "to" */
# Line 826  extern void to(environment *env) Line 699  extern void to(environment *env)
699    int ending, start, i;    int ending, start, i;
700    value *iterator, *temp, *end;    value *iterator, *temp, *end;
701    
702    end= new_val(env);    if(check_args(env, 2, integer, integer))
703        return printerr(env);
704    
705    if(env->head->type==empty || CDR(env->head)->type==empty) {    end= new_val(env);
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=integer  
      || CAR(CDR(env->head))->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
706    
707    ending= CAR(env->head)->content.i;    ending= CAR(env->head)->content.i;
708    toss(env); if(env->err) return;    toss(env); if(env->err) return;
# Line 894  extern void readlineport(environment *en Line 757  extern void readlineport(environment *en
757  {  {
758    FILE *stream;    FILE *stream;
759    
760    if(env->head->type==empty) {    if(check_args(env, 1, port))
761      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=port) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
762    
763    stream=CAR(env->head)->content.p;    stream=CAR(env->head)->content.p;
764    readlinestream(env, stream); if(env->err) return;    readlinestream(env, stream); if(env->err) return;
# Line 924  extern void readport(environment *env) Line 778  extern void readport(environment *env)
778  {  {
779    FILE *stream;    FILE *stream;
780    
781    if(env->head->type==empty) {    if(check_args(env, 1, port))
782      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=port) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
783    
784    stream=CAR(env->head)->content.p;    stream=CAR(env->head)->content.p;
785    readstream(env, stream); if(env->err) return;    readstream(env, stream); if(env->err) return;
# Line 948  extern void beep(environment *env) Line 793  extern void beep(environment *env)
793  {  {
794    int freq, dur, period, ticks;    int freq, dur, period, ticks;
795    
796    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, integer, integer))
797      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=integer  
      || CAR(CDR(env->head))->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
798    
799    dur= CAR(env->head)->content.i;    dur= CAR(env->head)->content.i;
800    toss(env);    toss(env);
# Line 979  extern void beep(environment *env) Line 814  extern void beep(environment *env)
814      usleep(dur);      usleep(dur);
815      return;      return;
816    case -1:    case -1:
     perror("beep");  
817      env->err= 5;      env->err= 5;
818      return;      return printerr(env);
819    default:    default:
820      abort();      abort();
821    }    }
# Line 993  extern void sx_77616974(environment *env Line 827  extern void sx_77616974(environment *env
827  {  {
828    int dur;    int dur;
829    
830    if(env->head->type==empty) {    if(check_args(env, 1, integer))
831      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
832    
833    dur= CAR(env->head)->content.i;    dur= CAR(env->head)->content.i;
834    toss(env);    toss(env);
# Line 1011  extern void sx_77616974(environment *env Line 836  extern void sx_77616974(environment *env
836    usleep(dur);    usleep(dur);
837  }  }
838    
839    
840  /* "*" */  /* "*" */
841  extern void sx_2a(environment *env)  extern void sx_2a(environment *env)
842  {  {
843    int a, b;    int a, b;
844    float fa, fb;    float fa, fb;
845    
846    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, integer, integer)==0) {
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
847      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
848      toss(env); if(env->err) return;      toss(env); if(env->err) return;
849      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1034  extern void sx_2a(environment *env) Line 853  extern void sx_2a(environment *env)
853      return;      return;
854    }    }
855    
856    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
857      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
858      toss(env); if(env->err) return;      toss(env); if(env->err) return;
859      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1045  extern void sx_2a(environment *env) Line 863  extern void sx_2a(environment *env)
863      return;      return;
864    }    }
865    
866    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, integer)==0) {
      && CAR(CDR(env->head))->type==integer) {  
867      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
868      toss(env); if(env->err) return;      toss(env); if(env->err) return;
869      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1056  extern void sx_2a(environment *env) Line 873  extern void sx_2a(environment *env)
873      return;      return;
874    }    }
875    
876    if(CAR(env->head)->type==integer    if(check_args(env, 2, integer, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
877      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
878      toss(env); if(env->err) return;      toss(env); if(env->err) return;
879      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1067  extern void sx_2a(environment *env) Line 883  extern void sx_2a(environment *env)
883      return;      return;
884    }    }
885    
886    printerr("Bad Argument Type");    return printerr(env);
   env->err= 2;  
887  }  }
888    
889  /* "/" */  /* "/" */
# Line 1077  extern void sx_2f(environment *env) Line 892  extern void sx_2f(environment *env)
892    int a, b;    int a, b;
893    float fa, fb;    float fa, fb;
894    
895    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, integer, integer)==0) {
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
896      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
897      toss(env); if(env->err) return;      toss(env); if(env->err) return;
898      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1094  extern void sx_2f(environment *env) Line 902  extern void sx_2f(environment *env)
902      return;      return;
903    }    }
904    
905    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
906      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
907      toss(env); if(env->err) return;      toss(env); if(env->err) return;
908      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1105  extern void sx_2f(environment *env) Line 912  extern void sx_2f(environment *env)
912      return;      return;
913    }    }
914    
915    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, integer)==0) {
      && CAR(CDR(env->head))->type==integer) {  
916      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
917      toss(env); if(env->err) return;      toss(env); if(env->err) return;
918      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1116  extern void sx_2f(environment *env) Line 922  extern void sx_2f(environment *env)
922      return;      return;
923    }    }
924    
925    if(CAR(env->head)->type==integer    if(check_args(env, 2, integer, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
926      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
927      toss(env); if(env->err) return;      toss(env); if(env->err) return;
928      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1127  extern void sx_2f(environment *env) Line 932  extern void sx_2f(environment *env)
932      return;      return;
933    }    }
934    
935    printerr("Bad Argument Type");    return printerr(env);
   env->err= 2;  
936  }  }
937    
938  /* "mod" */  /* "mod" */
# Line 1136  extern void mod(environment *env) Line 940  extern void mod(environment *env)
940  {  {
941    int a, b;    int a, b;
942    
943    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, integer, integer)==0) {
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
944      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
945      toss(env); if(env->err) return;      toss(env); if(env->err) return;
946      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1153  extern void mod(environment *env) Line 950  extern void mod(environment *env)
950      return;      return;
951    }    }
952    
953    printerr("Bad Argument Type");    return printerr(env);
   env->err= 2;  
954  }  }
955    
956    
957  /* "div" */  /* "div" */
958  extern void sx_646976(environment *env)  extern void sx_646976(environment *env)
959  {  {
960    int a, b;    int a, b;
     
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
     a= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     b= CAR(env->head)->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, (int)b/a);  
   
     return;  
   }  
961    
962    printerr("Bad Argument Type");    if(check_args(env, 2, integer, integer))
963    env->err= 2;      return printerr(env);
964      
965      a= CAR(env->head)->content.i;
966      toss(env); if(env->err) return;
967      b= CAR(env->head)->content.i;
968      toss(env); if(env->err) return;
969      push_int(env, (int)b/a);
970  }  }
971    
972    
973  extern void setcar(environment *env)  extern void setcar(environment *env)
974  {  {
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
975    
976    if(CDR(env->head)->type!=tcons) {    if(check_args(env, 2, tcons, unknown))
977      printerr("Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
978    
979    CAR(CAR(CDR(env->head)))=CAR(env->head);    CAR(CAR(CDR(env->head)))=CAR(env->head);
980    toss(env);    toss(env);
# Line 1203  extern void setcar(environment *env) Line 982  extern void setcar(environment *env)
982    
983  extern void setcdr(environment *env)  extern void setcdr(environment *env)
984  {  {
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
985    
986    if(CDR(env->head)->type!=tcons) {    if(check_args(env, 2, tcons, unknown))
987      printerr("Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
988    
989    CDR(CAR(CDR(env->head)))=CAR(env->head);    CDR(CAR(CDR(env->head)))=CAR(env->head);
990    toss(env);    toss(env);
# Line 1221  extern void setcdr(environment *env) Line 992  extern void setcdr(environment *env)
992    
993  extern void car(environment *env)  extern void car(environment *env)
994  {  {
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
995    
996    if(CAR(env->head)->type!=tcons) {    if(check_args(env, 1, tcons))
997      printerr("Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
998    
999    CAR(env->head)=CAR(CAR(env->head));    CAR(env->head)=CAR(CAR(env->head));
1000  }  }
1001    
1002  extern void cdr(environment *env)  extern void cdr(environment *env)
1003  {  {
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
1004    
1005    if(CAR(env->head)->type!=tcons) {    if(check_args(env, 1, tcons))
1006      printerr("Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
1007    
1008    CAR(env->head)=CDR(CAR(env->head));    CAR(env->head)=CDR(CAR(env->head));
1009  }  }
# Line 1257  extern void cons(environment *env) Line 1012  extern void cons(environment *env)
1012  {  {
1013    value *val;    value *val;
1014    
1015    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, unknown, unknown))
1016      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
1017    
1018    val=new_val(env);    val=new_val(env);
1019    val->content.c= malloc(sizeof(pair));    val->content.c= malloc(sizeof(pair));
# Line 1278  extern void cons(environment *env) Line 1030  extern void cons(environment *env)
1030    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1031    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1032    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1033    toss(env); if(env->err) return;    toss(env);
1034  }  }
1035    
1036    
# Line 1289  void assocgen(environment *env, funcp eq Line 1041  void assocgen(environment *env, funcp eq
1041    
1042    /* Needs two values on the stack, the top one must be an association    /* Needs two values on the stack, the top one must be an association
1043       list */       list */
1044    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, tcons, unknown))
1045      printerr("Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=tcons) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
1046    
1047    key=CAR(CDR(env->head));    key=CAR(CDR(env->head));
1048    item=CAR(env->head);    item=CAR(env->head);
1049    
1050    while(item->type == tcons){    while(item->type == tcons){
1051      if(CAR(item)->type != tcons){      if(CAR(item)->type != tcons){
       printerr("Bad Argument Type");  
1052        env->err= 2;        env->err= 2;
1053        return;        return printerr(env);
1054      }      }
1055    
1056      push_val(env, key);      push_val(env, key);
1057      push_val(env, CAR(CAR(item)));      push_val(env, CAR(CAR(item)));
1058      eqfunc(env); if(env->err) return;      eqfunc((void*)env); if(env->err) return;
1059    
1060      /* Check the result of 'eqfunc' */      /* Check the result of 'eqfunc' */
1061      if(env->head->type==empty) {      if(check_args(env, 1, integer))
1062        printerr("Too Few Arguments");        return printerr(env);
       env->err= 1;  
     return;  
     }  
     if(CAR(env->head)->type!=integer) {  
       printerr("Bad Argument Type");  
       env->err= 2;  
       return;  
     }  
1063    
1064      if(CAR(env->head)->content.i){      if(CAR(env->head)->content.i){
1065        toss(env); if(env->err) return;        toss(env); if(env->err) return;
# Line 1333  void assocgen(environment *env, funcp eq Line 1068  void assocgen(environment *env, funcp eq
1068      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1069    
1070      if(item->type!=tcons) {      if(item->type!=tcons) {
       printerr("Bad Argument Type");  
1071        env->err= 2;        env->err= 2;
1072        return;        return printerr(env);
1073      }      }
1074    
1075      item=CDR(item);      item=CDR(item);
# Line 1357  void assocgen(environment *env, funcp eq Line 1091  void assocgen(environment *env, funcp eq
1091  /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */  /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
1092  extern void assq(environment *env)  extern void assq(environment *env)
1093  {  {
1094    assocgen(env, eq);    assocgen(env, (void*)eq);
1095  }  }
1096    
1097    
# Line 1376  extern void sx_6f70656e(environment *env Line 1110  extern void sx_6f70656e(environment *env
1110    value *new_port;    value *new_port;
1111    FILE *stream;    FILE *stream;
1112    
1113    if(env->head->type == empty || CDR(env->head)->type == empty) {    if(check_args(env, 2, string, string))
1114      printerr("Too Few Arguments");      return printerr(env);
     env->err=1;  
     return;  
   }  
   
   if(CAR(env->head)->type != string  
      || CAR(CDR(env->head))->type != string) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
1115    
1116    stream=fopen(CAR(CDR(env->head))->content.ptr,    stream=fopen(CAR(CDR(env->head))->content.ptr,
1117                 CAR(env->head)->content.ptr);                 CAR(env->head)->content.ptr);
1118    
1119    if(stream == NULL) {    if(stream == NULL) {
     perror("open");  
1120      env->err= 5;      env->err= 5;
1121      return;      return printerr(env);
1122    }    }
1123    
1124    new_port=new_val(env);    new_port=new_val(env);
# Line 1416  extern void sx_636c6f7365(environment *e Line 1139  extern void sx_636c6f7365(environment *e
1139  {  {
1140    int ret;    int ret;
1141    
1142      if(check_args(env, 1, port))
1143        return printerr(env);
1144    
1145      ret= fclose(CAR(env->head)->content.p);
1146    
1147      if(ret != 0){
1148        env->err= 5;
1149        return printerr(env);
1150      }
1151    
1152      toss(env);
1153    }
1154    
1155    
1156    extern void mangle(environment *env)
1157    {
1158      char *new_string;
1159    
1160      if(check_args(env, 1, string))
1161        return printerr(env);
1162    
1163      new_string= mangle_str(CAR(env->head)->content.string);
1164    
1165      toss(env);
1166      if(env->err) return;
1167    
1168      push_cstring(env, new_string);
1169    }
1170    
1171    /* "fork" */
1172    extern void sx_666f726b(environment *env)
1173    {
1174      push_int(env, fork());
1175    }
1176    
1177    /* "waitpid" */
1178    extern void sx_77616974706964(environment *env)
1179    {
1180    
1181      if(check_args(env, 1, integer))
1182        return printerr(env);
1183    
1184      push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0));
1185      swap(env); toss(env);
1186    }
1187    
1188    
1189    /* Discard the top element of the stack. */
1190    extern void toss(environment *env)
1191    {
1192    
1193      if(check_args(env, 1, unknown))
1194        return printerr(env);
1195    
1196      env->head= CDR(env->head); /* Remove the top stack item */
1197    }
1198    
1199    
1200    /* Quit stack. */
1201    extern void quit(environment *env)
1202    {
1203      int i;
1204    
1205      env->head= new_val(env);
1206    
1207      if (env->err) return;
1208      for(i= 0; i<HASHTBLSIZE; i++) {
1209        while(env->symbols[i]!= NULL) {
1210          forget_sym(&(env->symbols[i]));
1211        }
1212        env->symbols[i]= NULL;
1213      }
1214    
1215      env->gc_limit= 0;
1216      gc_maybe(env);
1217    
1218      words(env);
1219    
1220      if(env->free_string!=NULL)
1221        free(env->free_string);
1222      
1223    #ifdef __linux__
1224      muntrace();
1225    #endif
1226    
1227      exit(EXIT_SUCCESS);
1228    }
1229    
1230    
1231    /* List all defined words */
1232    extern void words(environment *env)
1233    {
1234      symbol *temp;
1235      int i;
1236      
1237      for(i= 0; i<HASHTBLSIZE; i++) {
1238        temp= env->symbols[i];
1239        while(temp!=NULL) {
1240    #ifdef DEBUG
1241          if (temp->val != NULL && temp->val->gc.flag.protect)
1242            printf("(protected) ");
1243    #endif /* DEBUG */
1244          printf("%s ", temp->id);
1245          temp= temp->next;
1246        }
1247      }
1248    }
1249    
1250    
1251    /* Only to be called by itself function printstack. */
1252    void print_st(environment *env, value *stack_head, long counter)
1253    {
1254      if(CDR(stack_head)->type != empty)
1255        print_st(env, CDR(stack_head), counter+1);
1256      printf("%ld: ", counter);
1257      print_val(env, CAR(stack_head), 0, NULL, stdout);
1258      printf("\n");
1259    }
1260    
1261    
1262    /* Prints the stack. */
1263    extern void printstack(environment *env)
1264    {
1265    if(env->head->type == empty) {    if(env->head->type == empty) {
1266      printerr("Too Few Arguments");      printf("Stack Empty\n");
     env->err=1;  
1267      return;      return;
1268    }    }
1269    
1270    if(CAR(env->head)->type != port) {    print_st(env, env->head, 1);
1271      printerr("Bad Argument Type");  }
1272      env->err= 2;  
1273    
1274    extern void copying(environment *env)
1275    {
1276      puts(license_message);
1277    }
1278    
1279    
1280    extern void warranty(environment *env)
1281    {
1282      puts(warranty_message);
1283    }
1284    
1285    
1286    /* random */
1287    extern void sx_72616e646f6d(environment *env)
1288    {
1289      push_int(env, (int)rand());
1290    }
1291    
1292    
1293    extern void seed(environment *env)
1294    {
1295      if(check_args(env, 1, integer))
1296        return printerr(env);
1297    
1298      srand(CAR(env->head)->content.i);
1299      toss(env);
1300    }
1301    
1302    
1303    extern void ticks(environment *env)
1304    {
1305      int val;
1306    
1307      val= (int)time(NULL);
1308      if(val<0) {
1309        env->err= 5;
1310        return printerr(env);
1311      }
1312      
1313      return push_int(env, val);
1314    }
1315    
1316    
1317    extern void push(environment *env)
1318    {
1319      symbol *sym;
1320      value *oldval;
1321      value *newval;
1322    
1323      if(check_args(env, 2, symb, unknown)==0) {
1324        sym= CAR(env->head)->content.sym;
1325        oldval= sym->val;
1326      
1327        if(oldval==NULL)
1328          oldval= new_val(env);
1329    
1330        sym->val= new_val(env);
1331        sym->val->content.c= malloc(sizeof(pair));
1332        assert(sym->val->content.c!=NULL);
1333        env->gc_count += sizeof(pair);
1334        sym->val->type= tcons;
1335        CDR(sym->val)= oldval;
1336        CAR(sym->val)= CAR(CDR(env->head));
1337        env->head= CDR(CDR(env->head));
1338    
1339      return;      return;
1340    }    }
1341    
1342    ret= fclose(CAR(env->head)->content.p);    if(check_args(env, 2, tcons, unknown)==0
1343         || check_args(env, 2, empty, unknown)==0) {
1344        oldval= CAR(env->head);
1345        env->head= CDR(env->head);
1346        newval= new_val(env);
1347        newval->content.c= malloc(sizeof(pair));
1348        assert(newval->content.c!=NULL);
1349        env->gc_count += sizeof(pair);
1350        newval->type= tcons;
1351        CDR(newval)= oldval;
1352        CAR(newval)= CAR(env->head);
1353        env->head= CDR(env->head);
1354        push_val(env, newval);
1355        
1356        return;
1357      }
1358    
1359      return printerr(env);
1360    }
1361    
1362    
1363    extern void pop(environment *env)
1364    {
1365      symbol *sym;
1366      value *val;
1367    
1368      if(check_args(env, 1, symb)==0) {
1369        sym= CAR(env->head)->content.sym;
1370    
1371        if(sym->val==NULL) {
1372          env->err= 3;
1373          return printerr(env);
1374        }
1375    
1376        env->head= CDR(env->head);
1377        if(sym->val->type==tcons) {
1378          push_val(env, CAR(sym->val));
1379          sym->val= CDR(sym->val);
1380        } else {
1381          env->err= 2;
1382          return printerr(env);
1383        }
1384    
   if(ret != 0){  
     perror("close");  
     env->err= 5;  
1385      return;      return;
1386    }    }
1387    
1388    toss(env);    if(check_args(env, 1, tcons)==0) {
1389        val= CAR(env->head);
1390        env->head= CDR(env->head);
1391        push_val(env, CAR(val));
1392        return;
1393      }
1394    
1395      return printerr(env);
1396  }  }
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.11
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26