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

Diff of /stack/symbols.c

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

revision 1.6 by masse, Mon Aug 11 14:31:48 2003 UTC revision 1.10 by masse, Mon Aug 18 14:39:16 2003 UTC
# Line 10  extern void nl(environment *env) Line 10  extern void nl(environment *env)
10  /* Print a newline to a port */  /* Print a newline to a port */
11  extern void nlport(environment *env)  extern void nlport(environment *env)
12  {  {
13    switch(check_args(env, port, empty)) {    if(check_args(env, 1, port))
14    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
15    
16    if(fprintf(CAR(env->head)->content.p, "\n") < 0){    if(fprintf(CAR(env->head)->content.p, "\n") < 0) {
     perror("nl");  
17      env->err= 5;      env->err= 5;
18      return;      return printerr(env);
19    }    }
20    
21    toss(env);    toss(env);
22  }  }
23    
# Line 33  extern void nlport(environment *env) Line 25  extern void nlport(environment *env)
25  extern void type(environment *env)  extern void type(environment *env)
26  {  {
27    
28    switch(check_args(env, unknown, empty)) {    if(check_args(env, 1, unknown))
29    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
30    
31    switch(CAR(env->head)->type){    switch(CAR(env->head)->type){
32    case empty:    case empty:
# Line 82  extern void type(environment *env) Line 66  extern void type(environment *env)
66  extern void print_(environment *env)  extern void print_(environment *env)
67  {  {
68    
69    switch(check_args(env, unknown, empty)) {    if(check_args(env, 1, unknown))
70    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
71    
72    print_val(env, CAR(env->head), 0, NULL, stdout);    print_val(env, CAR(env->head), 0, NULL, stdout);
73    if(env->err) return;    if(env->err) return;
# Line 111  extern void print(environment *env) Line 87  extern void print(environment *env)
87  extern void princ_(environment *env)  extern void princ_(environment *env)
88  {  {
89    
90    switch(check_args(env, unknown, empty)) {    if(check_args(env, 1, unknown))
91    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
92    
93    print_val(env, CAR(env->head), 1, NULL, stdout);    print_val(env, CAR(env->head), 1, NULL, stdout);
94  }  }
# Line 137  extern void princ(environment *env) Line 105  extern void princ(environment *env)
105  extern void printport_(environment *env)  extern void printport_(environment *env)
106  {  {
107    
108    switch(check_args(env, port, unknown, empty)) {    if(check_args(env, 2, port, unknown))
109    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
110    
111    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);
112    if(env->err) return;    if(env->err) return;
# Line 165  extern void printport(environment *env) Line 125  extern void printport(environment *env)
125  extern void princport_(environment *env)  extern void princport_(environment *env)
126  {  {
127    
128    switch(check_args(env, port, unknown, empty)) {    if(check_args(env, 2, port, unknown))
129    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
130    
131    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);
132    toss(env); if(env->err) return;    toss(env); if(env->err) return;
# Line 193  extern void rot(environment *env) Line 145  extern void rot(environment *env)
145  {  {
146    value *temp= env->head;    value *temp= env->head;
147    
148    switch(check_args(env, unknown, unknown, unknown, empty)) {    if(check_args(env, 3, unknown, unknown, unknown))
149    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
150        
151    env->head= CDR(CDR(env->head));    env->head= CDR(CDR(env->head));
152    CDR(CDR(temp))= CDR(env->head);    CDR(CDR(temp))= CDR(env->head);
# Line 214  extern void expand(environment *env) Line 158  extern void expand(environment *env)
158  {  {
159    value *temp, *new_head;    value *temp, *new_head;
160    
161    switch(check_args(env, tcons, empty)) {    if(check_args(env, 1, tcons))
162    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
163    
164    rev(env);    rev(env);
165    
# Line 241  extern void expand(environment *env) Line 177  extern void expand(environment *env)
177      if (CDR(temp)->type == tcons)      if (CDR(temp)->type == tcons)
178        temp= CDR(temp);        temp= CDR(temp);
179      else {      else {
180        printerr(env, "Bad Argument Type"); /* Improper list */        env->err= 2; /* Improper list */
181        env->err= 2;        return printerr(env);
       return;  
182      }      }
183    }    }
184    
# Line 258  extern void eq(environment *env) Line 193  extern void eq(environment *env)
193  {  {
194    void *left, *right;    void *left, *right;
195    
196    switch(check_args(env, unknown, unknown, empty)) {    if(check_args(env, 2, unknown, unknown))
197    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
198    
199    left= CAR(env->head)->content.ptr;    left= CAR(env->head)->content.ptr;
200    right= CAR(CDR(env->head))->content.ptr;    right= CAR(CDR(env->head))->content.ptr;
# Line 281  extern void not(environment *env) Line 208  extern void not(environment *env)
208  {  {
209    int val;    int val;
210    
211    switch(check_args(env, integer, empty)) {    if(check_args(env, 1, integer))
212    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
213    
214    val= CAR(env->head)->content.i;    val= CAR(env->head)->content.i;
215    toss(env);    toss(env);
# Line 310  extern void def(environment *env) Line 229  extern void def(environment *env)
229    symbol *sym;    symbol *sym;
230    
231    /* 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 */
232    switch(check_args(env, symb, unknown, empty)) {    if(check_args(env, 2, symb, unknown))
233    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
234    
235    /* long names are a pain */    /* long names are a pain */
236    sym= CAR(env->head)->content.sym;    sym= CAR(env->head)->content.sym;
# Line 341  extern void forget(environment *env) Line 252  extern void forget(environment *env)
252  {  {
253    char* sym_id;    char* sym_id;
254    
255    switch(check_args(env, symb, empty)) {    if(check_args(env, 1, symb))
256    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
257    
258    sym_id= CAR(env->head)->content.sym->id;    sym_id= CAR(env->head)->content.sym->id;
259    toss(env);    toss(env);
# Line 373  extern void sx_2b(environment *env) Line 276  extern void sx_2b(environment *env)
276    char* new_string;    char* new_string;
277    value *a_val, *b_val;    value *a_val, *b_val;
278    
279    if(check_args(env, unknown, unknown, empty)==1) {    if(check_args(env, 2, string, string)==0) {
     printerr(env, "Too Few Arguments");  
     return;  
   }  
   
   if(check_args(env, string, string, empty)==0) {  
280      a_val= CAR(env->head);      a_val= CAR(env->head);
281      b_val= CAR(CDR(env->head));      b_val= CAR(CDR(env->head));
282      protect(a_val); protect(b_val);      protect(a_val); protect(b_val);
# Line 396  extern void sx_2b(environment *env) Line 294  extern void sx_2b(environment *env)
294      return;      return;
295    }    }
296        
297    if(check_args(env, integer, integer, empty)==0) {    if(check_args(env, 2, integer, integer)==0) {
298      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
299      toss(env); if(env->err) return;      toss(env); if(env->err) return;
300      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 406  extern void sx_2b(environment *env) Line 304  extern void sx_2b(environment *env)
304      return;      return;
305    }    }
306    
307    if(check_args(env, tfloat, tfloat, empty)==0) {    if(check_args(env, 2, tfloat, tfloat)==0) {
308      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
309      toss(env); if(env->err) return;      toss(env); if(env->err) return;
310      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 416  extern void sx_2b(environment *env) Line 314  extern void sx_2b(environment *env)
314      return;      return;
315    }    }
316    
317    if(check_args(env, tfloat, integer, empty)==0) {    if(check_args(env, 2, tfloat, integer)==0) {
318      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
319      toss(env); if(env->err) return;      toss(env); if(env->err) return;
320      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 426  extern void sx_2b(environment *env) Line 324  extern void sx_2b(environment *env)
324      return;      return;
325    }    }
326    
327    if(check_args(env, integer, tfloat, empty)==0) {    if(check_args(env, 2, integer, tfloat)==0) {
328      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
329      toss(env); if(env->err) return;      toss(env); if(env->err) return;
330      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 436  extern void sx_2b(environment *env) Line 334  extern void sx_2b(environment *env)
334      return;      return;
335    }    }
336    
337    printerr(env, "Bad Argument Type");    return printerr(env);
   env->err=2;  
338  }  }
339    
340  /* "-" */  /* "-" */
# Line 446  extern void sx_2d(environment *env) Line 343  extern void sx_2d(environment *env)
343    int a, b;    int a, b;
344    float fa, fb;    float fa, fb;
345    
346    if(check_args(env, unknown, unknown, empty)==1) {    if(check_args(env, 2, integer, integer)==0) {
     printerr(env, "Too Few Arguments");  
     return;  
   }  
   
   if(check_args(env, integer, integer, empty)==0) {  
347      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
348      toss(env); if(env->err) return;      toss(env); if(env->err) return;
349      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 461  extern void sx_2d(environment *env) Line 353  extern void sx_2d(environment *env)
353      return;      return;
354    }    }
355    
356    if(check_args(env, tfloat, tfloat, empty)==0) {    if(check_args(env, 2, tfloat, tfloat)==0) {
357      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
358      toss(env); if(env->err) return;      toss(env); if(env->err) return;
359      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 471  extern void sx_2d(environment *env) Line 363  extern void sx_2d(environment *env)
363      return;      return;
364    }    }
365    
366    if(check_args(env, tfloat, integer, empty)==0) {    if(check_args(env, 2, tfloat, integer)==0) {
367      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
368      toss(env); if(env->err) return;      toss(env); if(env->err) return;
369      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 481  extern void sx_2d(environment *env) Line 373  extern void sx_2d(environment *env)
373      return;      return;
374    }    }
375    
376    if(check_args(env, integer, tfloat, empty)==0) {    if(check_args(env, 2, integer, tfloat)==0) {
377      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
378      toss(env); if(env->err) return;      toss(env); if(env->err) return;
379      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 491  extern void sx_2d(environment *env) Line 383  extern void sx_2d(environment *env)
383      return;      return;
384    }    }
385    
386    printerr(env, "Bad Argument Type");    return printerr(env);
   env->err=2;  
387  }  }
388    
389  /* ">" */  /* ">" */
# Line 501  extern void sx_3e(environment *env) Line 392  extern void sx_3e(environment *env)
392    int a, b;    int a, b;
393    float fa, fb;    float fa, fb;
394    
395    if(check_args(env, unknown, unknown, empty)==1) {    if(check_args(env, 2, integer, integer)==0) {
     printerr(env, "Too Few Arguments");  
     return;  
   }  
   
   if(check_args(env, integer, integer, empty)==0) {  
396      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
397      toss(env); if(env->err) return;      toss(env); if(env->err) return;
398      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 516  extern void sx_3e(environment *env) Line 402  extern void sx_3e(environment *env)
402      return;      return;
403    }    }
404    
405    if(check_args(env, tfloat, tfloat, empty)==0) {    if(check_args(env, 2, tfloat, tfloat)==0) {
406      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
407      toss(env); if(env->err) return;      toss(env); if(env->err) return;
408      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 526  extern void sx_3e(environment *env) Line 412  extern void sx_3e(environment *env)
412      return;      return;
413    }    }
414    
415    if(check_args(env, tfloat, integer, empty)==0) {    if(check_args(env, 2, tfloat, integer)==0) {
416      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
417      toss(env); if(env->err) return;      toss(env); if(env->err) return;
418      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 536  extern void sx_3e(environment *env) Line 422  extern void sx_3e(environment *env)
422      return;      return;
423    }    }
424    
425    if(check_args(env, integer, tfloat, empty)==0) {    if(check_args(env, 2, integer, tfloat)==0) {
426      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
427      toss(env); if(env->err) return;      toss(env); if(env->err) return;
428      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 546  extern void sx_3e(environment *env) Line 432  extern void sx_3e(environment *env)
432      return;      return;
433    }    }
434    
435    printerr(env, "Bad Argument Type");    return printerr(env);
   env->err= 2;  
436  }  }
437    
438  /* "<" */  /* "<" */
# Line 574  extern void sx_3e3d(environment *env) Line 459  extern void sx_3e3d(environment *env)
459  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
460  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
461  {  {
462    switch(check_args(env, unknown, empty)) {    if(check_args(env, 1, unknown))
463    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
464    
465    push_val(env, copy_val(env, CAR(env->head)));    push_val(env, copy_val(env, CAR(env->head)));
466  }  }
# Line 593  extern void sx_6966(environment *env) Line 470  extern void sx_6966(environment *env)
470  {  {
471    int truth;    int truth;
472    
473    switch(check_args(env, unknown, integer, empty)) {    if(check_args(env, 2, unknown, integer))
474    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
475    
476    swap(env);    swap(env);
477    if(env->err) return;    if(env->err) return;
# Line 623  extern void ifelse(environment *env) Line 492  extern void ifelse(environment *env)
492  {  {
493    int truth;    int truth;
494    
495    switch(check_args(env, unknown, unknown, integer, empty)) {    if(check_args(env, 3, unknown, unknown, integer))
496    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
497    
498    rot(env);    rot(env);
499    if(env->err) return;    if(env->err) return;
# Line 656  extern void ifelse(environment *env) Line 517  extern void ifelse(environment *env)
517  extern void sx_656c7365(environment *env)  extern void sx_656c7365(environment *env)
518  {  {
519    
520    switch(check_args(env,    if(check_args(env, 5, unknown, symb, unknown, symb, integer))
521                      unknown, symb, unknown, symb, integer,      return printerr(env);
                     empty)) {  
   case 1:  
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
522    
523    /// XXX    /// XXX
524    
# Line 675  extern void sx_656c7365(environment *env Line 526  extern void sx_656c7365(environment *env
526       || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0       || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
527       || CAR(CDR(CDR(CDR(env->head))))->type!=symb       || CAR(CDR(CDR(CDR(env->head))))->type!=symb
528       || 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(env, "Bad Argument Type");  
529      env->err= 2;      env->err= 2;
530      return;      return printerr(env);
531    }    }
532    
533    swap(env); toss(env); rot(env); toss(env);    swap(env); toss(env); rot(env); toss(env);
# Line 687  extern void sx_656c7365(environment *env Line 537  extern void sx_656c7365(environment *env
537  extern void then(environment *env)  extern void then(environment *env)
538  {  {
539        
540    switch(check_args(env, unknown, symb, integer, empty)) {    if(check_args(env, 3, unknown, symb, integer))
541    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
542    
543    /// XXX    /// XXX
544    
545    if(CAR(CDR(env->head))->type!=symb    if(CAR(CDR(env->head))->type!=symb
546       || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {       || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
     printerr(env, "Bad Argument Type");  
547      env->err= 2;      env->err= 2;
548      return;      return printerr(env);
549    }    }
550    
551    swap(env); toss(env);    swap(env); toss(env);
# Line 717  extern void sx_7768696c65(environment *e Line 558  extern void sx_7768696c65(environment *e
558    int truth;    int truth;
559    value *loop, *test;    value *loop, *test;
560    
561    switch(check_args(env, unknown, integer, empty)) {    if(check_args(env, 2, unknown, integer))
562    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
563    
564    loop= CAR(env->head);    loop= CAR(env->head);
565    protect(loop);    protect(loop);
# Line 743  extern void sx_7768696c65(environment *e Line 576  extern void sx_7768696c65(environment *e
576      /// XXX      /// XXX
577            
578      if(CAR(env->head)->type != integer) {      if(CAR(env->head)->type != integer) {
       printerr(env, "Bad Argument Type");  
579        env->err= 2;        env->err= 2;
580        return;        return printerr(env);
581      }      }
582            
583      truth= CAR(env->head)->content.i;      truth= CAR(env->head)->content.i;
# Line 770  extern void sx_666f72(environment *env) Line 602  extern void sx_666f72(environment *env)
602    value *loop;    value *loop;
603    int foo1, foo2;    int foo1, foo2;
604    
605    switch(check_args(env, unknown, integer, integer, empty)) {    if(check_args(env, 3, unknown, integer, integer))
606    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
607    
608    loop= CAR(env->head);    loop= CAR(env->head);
609    protect(loop);    protect(loop);
# Line 816  extern void foreach(environment *env) Line 640  extern void foreach(environment *env)
640    value *loop, *foo;    value *loop, *foo;
641    value *iterator;    value *iterator;
642    
643    switch(check_args(env, unknown, tcons, empty)) {    if(check_args(env, 2, unknown, tcons))
644    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
645        
646    loop= CAR(env->head);    loop= CAR(env->head);
647    protect(loop);    protect(loop);
# Line 846  extern void foreach(environment *env) Line 662  extern void foreach(environment *env)
662      if (iterator->type == tcons){      if (iterator->type == tcons){
663        iterator= CDR(iterator);        iterator= CDR(iterator);
664      } else {      } else {
665        printerr(env, "Bad Argument Type"); /* Improper list */        env->err= 2; /* Improper list */
       env->err= 2;  
666        break;        break;
667      }      }
668    }    }
669    unprotect(loop); unprotect(foo);    unprotect(loop); unprotect(foo);
670      
671      return printerr(env);
672  }  }
673    
674  /* "to" */  /* "to" */
# Line 860  extern void to(environment *env) Line 677  extern void to(environment *env)
677    int ending, start, i;    int ending, start, i;
678    value *iterator, *temp, *end;    value *iterator, *temp, *end;
679    
680    switch(check_args(env, integer, integer, empty)) {    if(check_args(env, 2, integer, integer))
681    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
682    
683    end= new_val(env);    end= new_val(env);
684    
# Line 926  extern void readlineport(environment *en Line 735  extern void readlineport(environment *en
735  {  {
736    FILE *stream;    FILE *stream;
737    
738    switch(check_args(env, port, empty)) {    if(check_args(env, 1, port))
739    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
740    
741    stream=CAR(env->head)->content.p;    stream=CAR(env->head)->content.p;
742    readlinestream(env, stream); if(env->err) return;    readlinestream(env, stream); if(env->err) return;
# Line 955  extern void readport(environment *env) Line 756  extern void readport(environment *env)
756  {  {
757    FILE *stream;    FILE *stream;
758    
759    switch(check_args(env, port, empty)) {    if(check_args(env, 1, port))
760    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
761    
762    stream=CAR(env->head)->content.p;    stream=CAR(env->head)->content.p;
763    readstream(env, stream); if(env->err) return;    readstream(env, stream); if(env->err) return;
# Line 978  extern void beep(environment *env) Line 771  extern void beep(environment *env)
771  {  {
772    int freq, dur, period, ticks;    int freq, dur, period, ticks;
773    
774    switch(check_args(env, integer, integer, empty)) {    if(check_args(env, 2, integer, integer))
775    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
776    
777    dur= CAR(env->head)->content.i;    dur= CAR(env->head)->content.i;
778    toss(env);    toss(env);
# Line 1007  extern void beep(environment *env) Line 792  extern void beep(environment *env)
792      usleep(dur);      usleep(dur);
793      return;      return;
794    case -1:    case -1:
     perror("beep");  
795      env->err= 5;      env->err= 5;
796      return;      return printerr(env);
797    default:    default:
798      abort();      abort();
799    }    }
# Line 1021  extern void sx_77616974(environment *env Line 805  extern void sx_77616974(environment *env
805  {  {
806    int dur;    int dur;
807    
808    switch(check_args(env, integer, empty)) {    if(check_args(env, 1, integer))
809    case 1:      return printerr(env);
     printerr(env, "Too Few Arguments");  
     return;  
   case 2:  
     printerr(env, "Bad Argument Type");  
     return;  
   default:  
     break;  
   }  
810    
811    dur= CAR(env->head)->content.i;    dur= CAR(env->head)->content.i;
812    toss(env);    toss(env);
# Line 1038  extern void sx_77616974(environment *env Line 814  extern void sx_77616974(environment *env
814    usleep(dur);    usleep(dur);
815  }  }
816    
 /// XXXXXX  
   
817    
818  /* "*" */  /* "*" */
819  extern void sx_2a(environment *env)  extern void sx_2a(environment *env)
# Line 1047  extern void sx_2a(environment *env) Line 821  extern void sx_2a(environment *env)
821    int a, b;    int a, b;
822    float fa, fb;    float fa, fb;
823    
824    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, integer, integer)==0) {
     printerr(env, "Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
825      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
826      toss(env); if(env->err) return;      toss(env); if(env->err) return;
827      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1064  extern void sx_2a(environment *env) Line 831  extern void sx_2a(environment *env)
831      return;      return;
832    }    }
833    
834    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
835      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
836      toss(env); if(env->err) return;      toss(env); if(env->err) return;
837      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1075  extern void sx_2a(environment *env) Line 841  extern void sx_2a(environment *env)
841      return;      return;
842    }    }
843    
844    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, integer)==0) {
      && CAR(CDR(env->head))->type==integer) {  
845      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
846      toss(env); if(env->err) return;      toss(env); if(env->err) return;
847      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1086  extern void sx_2a(environment *env) Line 851  extern void sx_2a(environment *env)
851      return;      return;
852    }    }
853    
854    if(CAR(env->head)->type==integer    if(check_args(env, 2, integer, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
855      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
856      toss(env); if(env->err) return;      toss(env); if(env->err) return;
857      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1097  extern void sx_2a(environment *env) Line 861  extern void sx_2a(environment *env)
861      return;      return;
862    }    }
863    
864    printerr(env, "Bad Argument Type");    return printerr(env);
   env->err= 2;  
865  }  }
866    
867  /* "/" */  /* "/" */
# Line 1107  extern void sx_2f(environment *env) Line 870  extern void sx_2f(environment *env)
870    int a, b;    int a, b;
871    float fa, fb;    float fa, fb;
872    
873    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, integer, integer)==0) {
     printerr(env, "Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
874      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
875      toss(env); if(env->err) return;      toss(env); if(env->err) return;
876      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1124  extern void sx_2f(environment *env) Line 880  extern void sx_2f(environment *env)
880      return;      return;
881    }    }
882    
883    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
884      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
885      toss(env); if(env->err) return;      toss(env); if(env->err) return;
886      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1135  extern void sx_2f(environment *env) Line 890  extern void sx_2f(environment *env)
890      return;      return;
891    }    }
892    
893    if(CAR(env->head)->type==tfloat    if(check_args(env, 2, tfloat, integer)==0) {
      && CAR(CDR(env->head))->type==integer) {  
894      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
895      toss(env); if(env->err) return;      toss(env); if(env->err) return;
896      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1146  extern void sx_2f(environment *env) Line 900  extern void sx_2f(environment *env)
900      return;      return;
901    }    }
902    
903    if(CAR(env->head)->type==integer    if(check_args(env, 2, integer, tfloat)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
904      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
905      toss(env); if(env->err) return;      toss(env); if(env->err) return;
906      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1157  extern void sx_2f(environment *env) Line 910  extern void sx_2f(environment *env)
910      return;      return;
911    }    }
912    
913    printerr(env, "Bad Argument Type");    return printerr(env);
   env->err= 2;  
914  }  }
915    
916  /* "mod" */  /* "mod" */
# Line 1166  extern void mod(environment *env) Line 918  extern void mod(environment *env)
918  {  {
919    int a, b;    int a, b;
920    
921    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, integer, integer)==0) {
     printerr(env, "Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(CAR(env->head)->type==integer  
      && CAR(CDR(env->head))->type==integer) {  
922      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
923      toss(env); if(env->err) return;      toss(env); if(env->err) return;
924      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1183  extern void mod(environment *env) Line 928  extern void mod(environment *env)
928      return;      return;
929    }    }
930    
931    printerr(env, "Bad Argument Type");    return printerr(env);
   env->err= 2;  
932  }  }
933    
934    
935  /* "div" */  /* "div" */
936  extern void sx_646976(environment *env)  extern void sx_646976(environment *env)
937  {  {
938    int a, b;    int a, b;
     
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr(env, "Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
939    
940    if(CAR(env->head)->type==integer    if(check_args(env, 2, integer, integer))
941       && CAR(CDR(env->head))->type==integer) {      return printerr(env);
942      a= CAR(env->head)->content.i;    
943      toss(env); if(env->err) return;    a= CAR(env->head)->content.i;
944      b= CAR(env->head)->content.i;    toss(env); if(env->err) return;
945      toss(env); if(env->err) return;    b= CAR(env->head)->content.i;
946      push_int(env, (int)b/a);    toss(env); if(env->err) return;
947      push_int(env, (int)b/a);
     return;  
   }  
   
   printerr(env, "Bad Argument Type");  
   env->err= 2;  
948  }  }
949    
950    
951  extern void setcar(environment *env)  extern void setcar(environment *env)
952  {  {
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr(env, "Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
953    
954    if(CDR(env->head)->type!=tcons) {    if(check_args(env, 2, tcons, unknown))
955      printerr(env, "Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
956    
957    CAR(CAR(CDR(env->head)))=CAR(env->head);    CAR(CAR(CDR(env->head)))=CAR(env->head);
958    toss(env);    toss(env);
# Line 1233  extern void setcar(environment *env) Line 960  extern void setcar(environment *env)
960    
961  extern void setcdr(environment *env)  extern void setcdr(environment *env)
962  {  {
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr(env, "Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
963    
964    if(CDR(env->head)->type!=tcons) {    if(check_args(env, 2, tcons, unknown))
965      printerr(env, "Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
966    
967    CDR(CAR(CDR(env->head)))=CAR(env->head);    CDR(CAR(CDR(env->head)))=CAR(env->head);
968    toss(env);    toss(env);
# Line 1251  extern void setcdr(environment *env) Line 970  extern void setcdr(environment *env)
970    
971  extern void car(environment *env)  extern void car(environment *env)
972  {  {
   if(env->head->type==empty) {  
     printerr(env, "Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
973    
974    if(CAR(env->head)->type!=tcons) {    if(check_args(env, 1, tcons))
975      printerr(env, "Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
976    
977    CAR(env->head)=CAR(CAR(env->head));    CAR(env->head)=CAR(CAR(env->head));
978  }  }
979    
980  extern void cdr(environment *env)  extern void cdr(environment *env)
981  {  {
   if(env->head->type==empty) {  
     printerr(env, "Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
982    
983    if(CAR(env->head)->type!=tcons) {    if(check_args(env, 1, tcons))
984      printerr(env, "Bad Argument Type");      return printerr(env);
     env->err= 2;  
     return;  
   }  
985    
986    CAR(env->head)=CDR(CAR(env->head));    CAR(env->head)=CDR(CAR(env->head));
987  }  }
# Line 1287  extern void cons(environment *env) Line 990  extern void cons(environment *env)
990  {  {
991    value *val;    value *val;
992    
993    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, unknown, unknown))
994      printerr(env, "Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
995    
996    val=new_val(env);    val=new_val(env);
997    val->content.c= malloc(sizeof(pair));    val->content.c= malloc(sizeof(pair));
# Line 1308  extern void cons(environment *env) Line 1008  extern void cons(environment *env)
1008    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1009    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1010    swap(env); if(env->err) return;    swap(env); if(env->err) return;
1011    toss(env); if(env->err) return;    toss(env);
1012  }  }
1013    
1014    
# Line 1319  void assocgen(environment *env, funcp eq Line 1019  void assocgen(environment *env, funcp eq
1019    
1020    /* 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
1021       list */       list */
1022    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, 2, tcons, unknown))
1023      printerr(env, "Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=tcons) {  
     printerr(env, "Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
1024    
1025    key=CAR(CDR(env->head));    key=CAR(CDR(env->head));
1026    item=CAR(env->head);    item=CAR(env->head);
1027    
1028    while(item->type == tcons){    while(item->type == tcons){
1029      if(CAR(item)->type != tcons){      if(CAR(item)->type != tcons){
       printerr(env, "Bad Argument Type");  
1030        env->err= 2;        env->err= 2;
1031        return;        return printerr(env);
1032      }      }
1033    
1034      push_val(env, key);      push_val(env, key);
1035      push_val(env, CAR(CAR(item)));      push_val(env, CAR(CAR(item)));
1036      eqfunc(env); if(env->err) return;      eqfunc((void*)env); if(env->err) return;
1037    
1038      /* Check the result of 'eqfunc' */      /* Check the result of 'eqfunc' */
1039      if(env->head->type==empty) {      if(check_args(env, 1, integer))
1040        printerr(env, "Too Few Arguments");        return printerr(env);
       env->err= 1;  
     return;  
     }  
     if(CAR(env->head)->type!=integer) {  
       printerr(env, "Bad Argument Type");  
       env->err= 2;  
       return;  
     }  
1041    
1042      if(CAR(env->head)->content.i){      if(CAR(env->head)->content.i){
1043        toss(env); if(env->err) return;        toss(env); if(env->err) return;
# Line 1363  void assocgen(environment *env, funcp eq Line 1046  void assocgen(environment *env, funcp eq
1046      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1047    
1048      if(item->type!=tcons) {      if(item->type!=tcons) {
       printerr(env, "Bad Argument Type");  
1049        env->err= 2;        env->err= 2;
1050        return;        return printerr(env);
1051      }      }
1052    
1053      item=CDR(item);      item=CDR(item);
# Line 1387  void assocgen(environment *env, funcp eq Line 1069  void assocgen(environment *env, funcp eq
1069  /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */  /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
1070  extern void assq(environment *env)  extern void assq(environment *env)
1071  {  {
1072    assocgen(env, eq);    assocgen(env, (void*)eq);
1073  }  }
1074    
1075    
# Line 1406  extern void sx_6f70656e(environment *env Line 1088  extern void sx_6f70656e(environment *env
1088    value *new_port;    value *new_port;
1089    FILE *stream;    FILE *stream;
1090    
1091    if(env->head->type == empty || CDR(env->head)->type == empty) {    if(check_args(env, 2, string, string))
1092      printerr(env, "Too Few Arguments");      return printerr(env);
     env->err=1;  
     return;  
   }  
   
   if(CAR(env->head)->type != string  
      || CAR(CDR(env->head))->type != string) {  
     printerr(env, "Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
1093    
1094    stream=fopen(CAR(CDR(env->head))->content.ptr,    stream=fopen(CAR(CDR(env->head))->content.ptr,
1095                 CAR(env->head)->content.ptr);                 CAR(env->head)->content.ptr);
1096    
1097    if(stream == NULL) {    if(stream == NULL) {
     perror("open");  
1098      env->err= 5;      env->err= 5;
1099      return;      return printerr(env);
1100    }    }
1101    
1102    new_port=new_val(env);    new_port=new_val(env);
# Line 1446  extern void sx_636c6f7365(environment *e Line 1117  extern void sx_636c6f7365(environment *e
1117  {  {
1118    int ret;    int ret;
1119    
1120    if(env->head->type == empty) {    if(check_args(env, 1, port))
1121      printerr(env, "Too Few Arguments");      return printerr(env);
     env->err=1;  
     return;  
   }  
   
   if(CAR(env->head)->type != port) {  
     printerr(env, "Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
1122    
1123    ret= fclose(CAR(env->head)->content.p);    ret= fclose(CAR(env->head)->content.p);
1124    
1125    if(ret != 0){    if(ret != 0){
     perror("close");  
1126      env->err= 5;      env->err= 5;
1127      return;      return printerr(env);
1128    }    }
1129    
1130    toss(env);    toss(env);
1131  }  }
1132    
1133    
1134  extern void mangle(environment *env)  extern void mangle(environment *env)
1135  {  {
1136    char *new_string;    char *new_string;
1137    
1138    if(env->head->type==empty) {    if(check_args(env, 1, string))
1139      printerr(env, "Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=string) {  
     printerr(env, "Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
1140    
1141    new_string= mangle_str(CAR(env->head)->content.string);    new_string= mangle_str(CAR(env->head)->content.string);
1142    
# Line 1503  extern void sx_666f726b(environment *env Line 1156  extern void sx_666f726b(environment *env
1156  extern void sx_77616974706964(environment *env)  extern void sx_77616974706964(environment *env)
1157  {  {
1158    
1159    if(env->head->type==empty) {    if(check_args(env, 1, integer))
1160      printerr(env, "Too Few Arguments");      return printerr(env);
     env->err= 1;  
     return;  
   }  
   
   if(CAR(env->head)->type!=integer) {  
     printerr(env, "Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
1161    
1162    push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0));    push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0));
1163    swap(env); toss(env);    swap(env); toss(env);
# Line 1523  extern void sx_77616974706964(environmen Line 1167  extern void sx_77616974706964(environmen
1167  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
1168  extern void toss(environment *env)  extern void toss(environment *env)
1169  {  {
1170    if(env->head->type==empty) {  
1171      printerr(env, "Too Few Arguments");    if(check_args(env, 1, unknown))
1172      env->err= 1;      return printerr(env);
1173      return;  
   }  
     
1174    env->head= CDR(env->head); /* Remove the top stack item */    env->head= CDR(env->head); /* Remove the top stack item */
1175  }  }
1176    
# Line 1609  extern void printstack(environment *env) Line 1251  extern void printstack(environment *env)
1251    
1252  extern void copying(environment *env)  extern void copying(environment *env)
1253  {  {
1254    printf(license_message);    puts(license_message);
1255  }  }
1256    
1257    
1258  extern void warranty(environment *env)  extern void warranty(environment *env)
1259  {  {
1260    printf(warranty_message);    puts(warranty_message);
1261    }
1262    
1263    
1264    /* random */
1265    extern void sx_72616e646f6d(environment *env)
1266    {
1267      push_int(env, (int)rand());
1268    }
1269    
1270    
1271    extern void seed(environment *env)
1272    {
1273      if(check_args(env, 1, integer))
1274        return printerr(env);
1275    
1276      srand(CAR(env->head)->content.i);
1277      toss(env);
1278    }
1279    
1280    
1281    extern void ticks(environment *env)
1282    {
1283      int val;
1284    
1285      val= (int)time(NULL);
1286      if(val<0) {
1287        env->err= 5;
1288        return printerr(env);
1289      }
1290      
1291      return push_int(env, val);
1292    }
1293    
1294    
1295    extern void push(environment *env)
1296    {
1297      symbol *sym;
1298      value *oldval;
1299      value *newval;
1300    
1301      if(check_args(env, 2, symb, unknown)==0) {
1302        sym= CAR(env->head)->content.sym;
1303        oldval= sym->val;
1304      
1305        if(oldval==NULL)
1306          oldval= new_val(env);
1307    
1308        sym->val= new_val(env);
1309        sym->val->content.c= malloc(sizeof(pair));
1310        assert(sym->val->content.c!=NULL);
1311        env->gc_count += sizeof(pair);
1312        sym->val->type= tcons;
1313        CDR(sym->val)= oldval;
1314        CAR(sym->val)= CAR(CDR(env->head));
1315        env->head= CDR(CDR(env->head));
1316    
1317        return;
1318      }
1319    
1320      if(check_args(env, 2, tcons, unknown)==0
1321         || check_args(env, 2, empty, unknown)==0) {
1322        oldval= CAR(env->head);
1323        env->head= CDR(env->head);
1324        newval= new_val(env);
1325        newval->content.c= malloc(sizeof(pair));
1326        assert(newval->content.c!=NULL);
1327        env->gc_count += sizeof(pair);
1328        newval->type= tcons;
1329        CDR(newval)= oldval;
1330        CAR(newval)= CAR(env->head);
1331        env->head= CDR(env->head);
1332        push_val(env, newval);
1333        
1334        return;
1335      }
1336    
1337      return printerr(env);
1338    }
1339    
1340    
1341    extern void pop(environment *env)
1342    {
1343      symbol *sym;
1344      value *val;
1345    
1346      if(check_args(env, 1, symb)==0) {
1347        sym= CAR(env->head)->content.sym;
1348    
1349        if(sym->val==NULL) {
1350          env->err= 3;
1351          return printerr(env);
1352        }
1353    
1354        env->head= CDR(env->head);
1355        if(sym->val->type==tcons) {
1356          push_val(env, CAR(sym->val));
1357          sym->val= CDR(sym->val);
1358        } else {
1359          env->err= 2;
1360          return printerr(env);
1361        }
1362    
1363        return;
1364      }
1365    
1366      if(check_args(env, 1, tcons)==0) {
1367        val= CAR(env->head);
1368        env->head= CDR(env->head);
1369        push_val(env, CAR(val));
1370        return;
1371      }
1372    
1373      return printerr(env);
1374  }  }
Legend:
Removed from v.1.6  
changed lines
  Added in v.1.10
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26