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

Diff of /stack/symbols.c

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

revision 1.1 by masse, Mon Aug 4 11:23:43 2003 UTC revision 1.8 by masse, Wed Aug 13 06:12:26 2003 UTC
# Line 1  Line 1 
 #include <stdio.h>  
1  #include "stack.h"  #include "stack.h"
2    #include "messages.h"
3    
4  /* Print newline. */  /* Print newline. */
5  extern void nl(environment *env)  extern void nl(environment *env)
# 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    if(env->head->type==empty) {    switch(check_args(env, port, empty)) {
14      printerr("Too Few Arguments");    case 1:
15      env->err= 1;      printerr(env, "Too Few Arguments");
16      return;      return;
17    }    case 2:
18        printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type!=port) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
19      return;      return;
20      default:
21        break;
22    }    }
23    
24    if(fprintf(CAR(env->head)->content.p, "\n") < 0){    if(fprintf(CAR(env->head)->content.p, "\n") < 0){
# Line 33  extern void nlport(environment *env) Line 32  extern void nlport(environment *env)
32  /* Gets the type of a value */  /* Gets the type of a value */
33  extern void type(environment *env)  extern void type(environment *env)
34  {  {
35    if(env->head->type==empty) {  
36      printerr("Too Few Arguments");    switch(check_args(env, unknown, empty)) {
37      env->err= 1;    case 1:
38        printerr(env, "Too Few Arguments");
39        return;
40      case 2:
41        printerr(env, "Bad Argument Type");
42      return;      return;
43      default:
44        break;
45    }    }
46    
47    switch(CAR(env->head)->type){    switch(CAR(env->head)->type){
48    case empty:    case empty:
49      push_sym(env, "empty");      push_sym(env, "empty");
50      break;      break;
51      case unknown:
52        push_sym(env, "unknown");
53        break;
54    case integer:    case integer:
55      push_sym(env, "integer");      push_sym(env, "integer");
56      break;      break;
# Line 73  extern void type(environment *env) Line 81  extern void type(environment *env)
81  /* Print the top element of the stack but don't discard it */  /* Print the top element of the stack but don't discard it */
82  extern void print_(environment *env)  extern void print_(environment *env)
83  {  {
84    if(env->head->type==empty) {  
85      printerr("Too Few Arguments");    switch(check_args(env, unknown, empty)) {
86      env->err= 1;    case 1:
87        printerr(env, "Too Few Arguments");
88        return;
89      case 2:
90        printerr(env, "Bad Argument Type");
91      return;      return;
92      default:
93        break;
94    }    }
95    
96    print_val(env, CAR(env->head), 0, NULL, stdout);    print_val(env, CAR(env->head), 0, NULL, stdout);
97    if(env->err) return;    if(env->err) return;
98    nl(env);    nl(env);
# Line 95  extern void print(environment *env) Line 110  extern void print(environment *env)
110     discard it. */     discard it. */
111  extern void princ_(environment *env)  extern void princ_(environment *env)
112  {  {
113    if(env->head->type==empty) {  
114      printerr("Too Few Arguments");    switch(check_args(env, unknown, empty)) {
115      env->err= 1;    case 1:
116        printerr(env, "Too Few Arguments");
117        return;
118      case 2:
119        printerr(env, "Bad Argument Type");
120      return;      return;
121      default:
122        break;
123    }    }
124    
125    print_val(env, CAR(env->head), 1, NULL, stdout);    print_val(env, CAR(env->head), 1, NULL, stdout);
126  }  }
127    
# Line 114  extern void princ(environment *env) Line 136  extern void princ(environment *env)
136  /* Print a value to a port, but don't discard it */  /* Print a value to a port, but don't discard it */
137  extern void printport_(environment *env)  extern void printport_(environment *env)
138  {  {
   if(env->head->type==empty ||  CDR(env->head)->type == empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
139    
140    if(CAR(env->head)->type!=port) {    switch(check_args(env, port, unknown, empty)) {
141      printerr("Bad Argument Type");    case 1:
142      env->err= 2;      printerr(env, "Too Few Arguments");
143      return;      return;
144      case 2:
145        printerr(env, "Bad Argument Type");
146        return;
147      default:
148        break;
149    }    }
150    
151    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);
# Line 142  extern void printport(environment *env) Line 164  extern void printport(environment *env)
164  /* 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. */
165  extern void princport_(environment *env)  extern void princport_(environment *env)
166  {  {
   if(env->head->type==empty ||  CDR(env->head)->type == empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
167    
168    if(CAR(env->head)->type!=port) {    switch(check_args(env, port, unknown, empty)) {
169      printerr("Bad Argument Type");    case 1:
170      env->err= 2;      printerr(env, "Too Few Arguments");
171        return;
172      case 2:
173        printerr(env, "Bad Argument Type");
174      return;      return;
175      default:
176        break;
177    }    }
178    
179    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);
# Line 170  extern void princport(environment *env) Line 192  extern void princport(environment *env)
192  extern void rot(environment *env)  extern void rot(environment *env)
193  {  {
194    value *temp= env->head;    value *temp= env->head;
195      
196    if(env->head->type == empty || CDR(env->head)->type == empty    switch(check_args(env, unknown, unknown, unknown, empty)) {
197       || CDR(CDR(env->head))->type == empty) {    case 1:
198      printerr("Too Few Arguments");      printerr(env, "Too Few Arguments");
199      env->err= 1;      return;
200      case 2:
201        printerr(env, "Bad Argument Type");
202      return;      return;
203      default:
204        break;
205    }    }
206        
207    env->head= CDR(CDR(env->head));    env->head= CDR(CDR(env->head));
# Line 188  extern void expand(environment *env) Line 214  extern void expand(environment *env)
214  {  {
215    value *temp, *new_head;    value *temp, *new_head;
216    
217    /* Is top element a list? */    switch(check_args(env, tcons, empty)) {
218    if(env->head->type==empty) {    case 1:
219      printerr("Too Few Arguments");      printerr(env, "Too Few Arguments");
     env->err= 1;  
220      return;      return;
221    }    case 2:
222        printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type!=tcons) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
223      return;      return;
224      default:
225        break;
226    }    }
227    
228    rev(env);    rev(env);
# Line 211  extern void expand(environment *env) Line 235  extern void expand(environment *env)
235    
236    toss(env);    toss(env);
237    
238      /// XXX
239    /* Find the end of the list */    /* Find the end of the list */
240    while(CDR(temp)->type != empty) {    while(CDR(temp)->type != empty) {
241      if (CDR(temp)->type == tcons)      if (CDR(temp)->type == tcons)
242        temp= CDR(temp);        temp= CDR(temp);
243      else {      else {
244        printerr("Bad Argument Type"); /* Improper list */        printerr(env, "Bad Argument Type"); /* Improper list */
245        env->err= 2;        env->err= 2;
246        return;        return;
247      }      }
# Line 233  extern void eq(environment *env) Line 258  extern void eq(environment *env)
258  {  {
259    void *left, *right;    void *left, *right;
260    
261    if(env->head->type==empty || CDR(env->head)->type==empty) {    switch(check_args(env, unknown, unknown, empty)) {
262      printerr("Too Few Arguments");    case 1:
263      env->err= 1;      printerr(env, "Too Few Arguments");
264      return;      return;
265      case 2:
266        printerr(env, "Bad Argument Type");
267        return;
268      default:
269        break;
270    }    }
271    
272    left= CAR(env->head)->content.ptr;    left= CAR(env->head)->content.ptr;
# Line 251  extern void not(environment *env) Line 281  extern void not(environment *env)
281  {  {
282    int val;    int val;
283    
284    if(env->head->type==empty) {    switch(check_args(env, integer, empty)) {
285      printerr("Too Few Arguments");    case 1:
286      env->err= 1;      printerr(env, "Too Few Arguments");
287      return;      return;
288    }    case 2:
289        printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
290      return;      return;
291      default:
292        break;
293    }    }
294    
295    val= CAR(env->head)->content.i;    val= CAR(env->head)->content.i;
# Line 281  extern void def(environment *env) Line 310  extern void def(environment *env)
310    symbol *sym;    symbol *sym;
311    
312    /* 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 */
313    if(env->head->type==empty || CDR(env->head)->type==empty) {    switch(check_args(env, symb, unknown, empty)) {
314      printerr("Too Few Arguments");    case 1:
315      env->err= 1;      printerr(env, "Too Few Arguments");
316      return;      return;
317    }    case 2:
318        printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
319      return;      return;
320      default:
321        break;
322    }    }
323    
324    /* long names are a pain */    /* long names are a pain */
325    sym= CAR(env->head)->content.ptr;    sym= CAR(env->head)->content.sym;
326    
327    /* Bind the symbol to the value */    /* Bind the symbol to the value */
328    sym->val= CAR(CDR(env->head));    sym->val= CAR(CDR(env->head));
# Line 305  extern void def(environment *env) Line 333  extern void def(environment *env)
333  /* Clear stack */  /* Clear stack */
334  extern void clear(environment *env)  extern void clear(environment *env)
335  {  {
336    while(env->head->type != empty)    env->head= new_val(env);
     toss(env);  
337  }  }
338    
339  /* Forgets a symbol (remove it from the hash table) */  /* Forgets a symbol (remove it from the hash table) */
# Line 314  extern void forget(environment *env) Line 341  extern void forget(environment *env)
341  {  {
342    char* sym_id;    char* sym_id;
343    
344    if(env->head->type==empty) {    switch(check_args(env, symb, empty)) {
345      printerr("Too Few Arguments");    case 1:
346      env->err= 1;      printerr(env, "Too Few Arguments");
347      return;      return;
348    }    case 2:
349          printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
350      return;      return;
351      default:
352        break;
353    }    }
354    
355    sym_id= CAR(env->head)->content.sym->id;    sym_id= CAR(env->head)->content.sym->id;
# Line 347  extern void sx_2b(environment *env) Line 373  extern void sx_2b(environment *env)
373    char* new_string;    char* new_string;
374    value *a_val, *b_val;    value *a_val, *b_val;
375    
376    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, unknown, unknown, empty)==1) {
377      printerr("Too Few Arguments");      printerr(env, "Too Few Arguments");
     env->err= 1;  
378      return;      return;
379    }    }
380    
381    if(CAR(env->head)->type==string    if(check_args(env, string, string, empty)==0) {
      && CAR(CDR(env->head))->type==string) {  
382      a_val= CAR(env->head);      a_val= CAR(env->head);
383      b_val= CAR(CDR(env->head));      b_val= CAR(CDR(env->head));
384      protect(a_val); protect(b_val);      protect(a_val); protect(b_val);
385      toss(env); if(env->err) return;      toss(env); if(env->err) return;
386      toss(env); if(env->err) return;      toss(env); if(env->err) return;
387      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.string)+strlen(b_val->content.string)+1;
388      new_string= malloc(len);      new_string= malloc(len);
389      assert(new_string != NULL);      assert(new_string != NULL);
390      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.string);
391      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.string);
392      push_cstring(env, new_string);      push_cstring(env, new_string);
393      unprotect(a_val); unprotect(b_val);      unprotect(a_val); unprotect(b_val);
394      free(new_string);      free(new_string);
# Line 372  extern void sx_2b(environment *env) Line 396  extern void sx_2b(environment *env)
396      return;      return;
397    }    }
398        
399    if(CAR(env->head)->type==integer    if(check_args(env, integer, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
400      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
401      toss(env); if(env->err) return;      toss(env); if(env->err) return;
402      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 383  extern void sx_2b(environment *env) Line 406  extern void sx_2b(environment *env)
406      return;      return;
407    }    }
408    
409    if(CAR(env->head)->type==tfloat    if(check_args(env, tfloat, tfloat, empty)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
410      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
411      toss(env); if(env->err) return;      toss(env); if(env->err) return;
412      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 394  extern void sx_2b(environment *env) Line 416  extern void sx_2b(environment *env)
416      return;      return;
417    }    }
418    
419    if(CAR(env->head)->type==tfloat    if(check_args(env, tfloat, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
420      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
421      toss(env); if(env->err) return;      toss(env); if(env->err) return;
422      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 405  extern void sx_2b(environment *env) Line 426  extern void sx_2b(environment *env)
426      return;      return;
427    }    }
428    
429    if(CAR(env->head)->type==integer    if(check_args(env, integer, tfloat, empty)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
430      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
431      toss(env); if(env->err) return;      toss(env); if(env->err) return;
432      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 416  extern void sx_2b(environment *env) Line 436  extern void sx_2b(environment *env)
436      return;      return;
437    }    }
438    
439    printerr("Bad Argument Type");    printerr(env, "Bad Argument Type");
440    env->err=2;    env->err=2;
441  }  }
442    
# Line 426  extern void sx_2d(environment *env) Line 446  extern void sx_2d(environment *env)
446    int a, b;    int a, b;
447    float fa, fb;    float fa, fb;
448    
449    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, unknown, unknown, empty)==1) {
450      printerr("Too Few Arguments");      printerr(env, "Too Few Arguments");
     env->err=1;  
451      return;      return;
452    }    }
453      
454    if(CAR(env->head)->type==integer    if(check_args(env, integer, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
455      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
456      toss(env); if(env->err) return;      toss(env); if(env->err) return;
457      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 443  extern void sx_2d(environment *env) Line 461  extern void sx_2d(environment *env)
461      return;      return;
462    }    }
463    
464    if(CAR(env->head)->type==tfloat    if(check_args(env, tfloat, tfloat, empty)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
465      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
466      toss(env); if(env->err) return;      toss(env); if(env->err) return;
467      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 454  extern void sx_2d(environment *env) Line 471  extern void sx_2d(environment *env)
471      return;      return;
472    }    }
473    
474    if(CAR(env->head)->type==tfloat    if(check_args(env, tfloat, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
475      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
476      toss(env); if(env->err) return;      toss(env); if(env->err) return;
477      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 465  extern void sx_2d(environment *env) Line 481  extern void sx_2d(environment *env)
481      return;      return;
482    }    }
483    
484    if(CAR(env->head)->type==integer    if(check_args(env, integer, tfloat, empty)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
485      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
486      toss(env); if(env->err) return;      toss(env); if(env->err) return;
487      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 476  extern void sx_2d(environment *env) Line 491  extern void sx_2d(environment *env)
491      return;      return;
492    }    }
493    
494    printerr("Bad Argument Type");    printerr(env, "Bad Argument Type");
495    env->err=2;    env->err=2;
496  }  }
497    
# Line 486  extern void sx_3e(environment *env) Line 501  extern void sx_3e(environment *env)
501    int a, b;    int a, b;
502    float fa, fb;    float fa, fb;
503    
504    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, unknown, unknown, empty)==1) {
505      printerr("Too Few Arguments");      printerr(env, "Too Few Arguments");
     env->err= 1;  
506      return;      return;
507    }    }
508      
509    if(CAR(env->head)->type==integer    if(check_args(env, integer, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
510      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
511      toss(env); if(env->err) return;      toss(env); if(env->err) return;
512      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 503  extern void sx_3e(environment *env) Line 516  extern void sx_3e(environment *env)
516      return;      return;
517    }    }
518    
519    if(CAR(env->head)->type==tfloat    if(check_args(env, tfloat, tfloat, empty)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
520      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
521      toss(env); if(env->err) return;      toss(env); if(env->err) return;
522      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 514  extern void sx_3e(environment *env) Line 526  extern void sx_3e(environment *env)
526      return;      return;
527    }    }
528    
529    if(CAR(env->head)->type==tfloat    if(check_args(env, tfloat, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
530      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
531      toss(env); if(env->err) return;      toss(env); if(env->err) return;
532      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 525  extern void sx_3e(environment *env) Line 536  extern void sx_3e(environment *env)
536      return;      return;
537    }    }
538    
539    if(CAR(env->head)->type==integer    if(check_args(env, integer, tfloat, empty)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
540      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
541      toss(env); if(env->err) return;      toss(env); if(env->err) return;
542      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 536  extern void sx_3e(environment *env) Line 546  extern void sx_3e(environment *env)
546      return;      return;
547    }    }
548    
549    printerr("Bad Argument Type");    printerr(env, "Bad Argument Type");
550    env->err= 2;    env->err= 2;
551  }  }
552    
# Line 564  extern void sx_3e3d(environment *env) Line 574  extern void sx_3e3d(environment *env)
574  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
575  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
576  {  {
577    if(env->head->type==empty) {    switch(check_args(env, unknown, empty)) {
578      printerr("Too Few Arguments");    case 1:
579      env->err= 1;      printerr(env, "Too Few Arguments");
580        return;
581      case 2:
582        printerr(env, "Bad Argument Type");
583      return;      return;
584      default:
585        break;
586    }    }
587    
588    push_val(env, copy_val(env, CAR(env->head)));    push_val(env, copy_val(env, CAR(env->head)));
589  }  }
590    
# Line 577  extern void sx_6966(environment *env) Line 593  extern void sx_6966(environment *env)
593  {  {
594    int truth;    int truth;
595    
596    if(env->head->type==empty || CDR(env->head)->type==empty) {    switch(check_args(env, unknown, integer, empty)) {
597      printerr("Too Few Arguments");    case 1:
598      env->err= 1;      printerr(env, "Too Few Arguments");
599      return;      return;
600    }    case 2:
601        printerr(env, "Bad Argument Type");
   if(CAR(CDR(env->head))->type != integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
602      return;      return;
603      default:
604        break;
605    }    }
606      
607    swap(env);    swap(env);
608    if(env->err) return;    if(env->err) return;
609        
# Line 608  extern void ifelse(environment *env) Line 623  extern void ifelse(environment *env)
623  {  {
624    int truth;    int truth;
625    
626    if(env->head->type==empty || CDR(env->head)->type==empty    switch(check_args(env, unknown, unknown, integer, empty)) {
627       || CDR(CDR(env->head))->type==empty) {    case 1:
628      printerr("Too Few Arguments");      printerr(env, "Too Few Arguments");
     env->err= 1;  
629      return;      return;
630    }    case 2:
631        printerr(env, "Bad Argument Type");
   if(CAR(CDR(CDR(env->head)))->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
632      return;      return;
633      default:
634        break;
635    }    }
636      
637    rot(env);    rot(env);
638    if(env->err) return;    if(env->err) return;
639        
# Line 642  extern void ifelse(environment *env) Line 655  extern void ifelse(environment *env)
655  /* "else" */  /* "else" */
656  extern void sx_656c7365(environment *env)  extern void sx_656c7365(environment *env)
657  {  {
658    if(env->head->type==empty || CDR(env->head)->type==empty  
659       || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty    switch(check_args(env,
660       || CDR(CDR(CDR(CDR(env->head))))->type==empty) {                      unknown, symb, unknown, symb, integer,
661      printerr("Too Few Arguments");                      empty)) {
662      env->err= 1;    case 1:
663        printerr(env, "Too Few Arguments");
664        return;
665      case 2:
666        printerr(env, "Bad Argument Type");
667      return;      return;
668      default:
669        break;
670    }    }
671    
672      /// XXX
673    
674    if(CAR(CDR(env->head))->type!=symb    if(CAR(CDR(env->head))->type!=symb
675       || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0       || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
676       || CAR(CDR(CDR(CDR(env->head))))->type!=symb       || CAR(CDR(CDR(CDR(env->head))))->type!=symb
677       || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {       || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
678      printerr("Bad Argument Type");      printerr(env, "Bad Argument Type");
679      env->err= 2;      env->err= 2;
680      return;      return;
681    }    }
# Line 665  extern void sx_656c7365(environment *env Line 686  extern void sx_656c7365(environment *env
686    
687  extern void then(environment *env)  extern void then(environment *env)
688  {  {
689    if(env->head->type==empty || CDR(env->head)->type==empty    
690       || CDR(CDR(env->head))->type==empty) {    switch(check_args(env, unknown, symb, integer, empty)) {
691      printerr("Too Few Arguments");    case 1:
692      env->err= 1;      printerr(env, "Too Few Arguments");
693      return;      return;
694      case 2:
695        printerr(env, "Bad Argument Type");
696        return;
697      default:
698        break;
699    }    }
700    
701      /// XXX
702    
703    if(CAR(CDR(env->head))->type!=symb    if(CAR(CDR(env->head))->type!=symb
704       || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {       || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
705      printerr("Bad Argument Type");      printerr(env, "Bad Argument Type");
706      env->err= 2;      env->err= 2;
707      return;      return;
708    }    }
# Line 689  extern void sx_7768696c65(environment *e Line 717  extern void sx_7768696c65(environment *e
717    int truth;    int truth;
718    value *loop, *test;    value *loop, *test;
719    
720    if(env->head->type==empty || CDR(env->head)->type==empty) {    switch(check_args(env, unknown, integer, empty)) {
721      printerr("Too Few Arguments");    case 1:
722      env->err= 1;      printerr(env, "Too Few Arguments");
723        return;
724      case 2:
725        printerr(env, "Bad Argument Type");
726      return;      return;
727      default:
728        break;
729    }    }
730    
731    loop= CAR(env->head);    loop= CAR(env->head);
# Line 706  extern void sx_7768696c65(environment *e Line 739  extern void sx_7768696c65(environment *e
739    do {    do {
740      push_val(env, test);      push_val(env, test);
741      eval(env);      eval(env);
742    
743        /// XXX
744            
745      if(CAR(env->head)->type != integer) {      if(CAR(env->head)->type != integer) {
746        printerr("Bad Argument Type");        printerr(env, "Bad Argument Type");
747        env->err= 2;        env->err= 2;
748        return;        return;
749      }      }
# Line 735  extern void sx_666f72(environment *env) Line 770  extern void sx_666f72(environment *env)
770    value *loop;    value *loop;
771    int foo1, foo2;    int foo1, foo2;
772    
773    if(env->head->type==empty || CDR(env->head)->type==empty    switch(check_args(env, unknown, integer, integer, empty)) {
774       || CDR(CDR(env->head))->type==empty) {    case 1:
775      printerr("Too Few Arguments");      printerr(env, "Too Few Arguments");
     env->err= 1;  
776      return;      return;
777    }    case 2:
778        printerr(env, "Bad Argument Type");
   if(CAR(CDR(env->head))->type!=integer  
      || CAR(CDR(CDR(env->head)))->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
779      return;      return;
780      default:
781        break;
782    }    }
783    
784    loop= CAR(env->head);    loop= CAR(env->head);
# Line 783  extern void foreach(environment *env) Line 815  extern void foreach(environment *env)
815  {    {  
816    value *loop, *foo;    value *loop, *foo;
817    value *iterator;    value *iterator;
     
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
818    
819    if(CAR(CDR(env->head))->type!=tcons) {    switch(check_args(env, unknown, tcons, empty)) {
820      printerr("Bad Argument Type");    case 1:
821      env->err= 2;      printerr(env, "Too Few Arguments");
822        return;
823      case 2:
824        printerr(env, "Bad Argument Type");
825      return;      return;
826      default:
827        break;
828    }    }
829      
830    loop= CAR(env->head);    loop= CAR(env->head);
831    protect(loop);    protect(loop);
832    toss(env); if(env->err) return;    toss(env); if(env->err) return;
# Line 810  extern void foreach(environment *env) Line 841  extern void foreach(environment *env)
841      push_val(env, CAR(iterator));      push_val(env, CAR(iterator));
842      push_val(env, loop);      push_val(env, loop);
843      eval(env); if(env->err) return;      eval(env); if(env->err) return;
844    
845        /// XXX
846      if (iterator->type == tcons){      if (iterator->type == tcons){
847        iterator= CDR(iterator);        iterator= CDR(iterator);
848      } else {      } else {
849        printerr("Bad Argument Type"); /* Improper list */        printerr(env, "Bad Argument Type"); /* Improper list */
850        env->err= 2;        env->err= 2;
851        break;        break;
852      }      }
# Line 827  extern void to(environment *env) Line 860  extern void to(environment *env)
860    int ending, start, i;    int ending, start, i;
861    value *iterator, *temp, *end;    value *iterator, *temp, *end;
862    
863    end= new_val(env);    switch(check_args(env, integer, integer, empty)) {
864      case 1:
865    if(env->head->type==empty || CDR(env->head)->type==empty) {      printerr(env, "Too Few Arguments");
     printerr("Too Few Arguments");  
     env->err= 1;  
866      return;      return;
867    }    case 2:
868        printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type!=integer  
      || CAR(CDR(env->head))->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
869      return;      return;
870      default:
871        break;
872    }    }
873    
874      end= new_val(env);
875    
876    ending= CAR(env->head)->content.i;    ending= CAR(env->head)->content.i;
877    toss(env); if(env->err) return;    toss(env); if(env->err) return;
878    start= CAR(env->head)->content.i;    start= CAR(env->head)->content.i;
# Line 895  extern void readlineport(environment *en Line 926  extern void readlineport(environment *en
926  {  {
927    FILE *stream;    FILE *stream;
928    
929    if(env->head->type==empty) {    switch(check_args(env, port, empty)) {
930      printerr("Too Few Arguments");    case 1:
931      env->err= 1;      printerr(env, "Too Few Arguments");
932      return;      return;
933    }    case 2:
934        printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type!=port) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
935      return;      return;
936      default:
937        break;
938    }    }
939    
940    stream=CAR(env->head)->content.p;    stream=CAR(env->head)->content.p;
# Line 925  extern void readport(environment *env) Line 955  extern void readport(environment *env)
955  {  {
956    FILE *stream;    FILE *stream;
957    
958    if(env->head->type==empty) {    switch(check_args(env, port, empty)) {
959      printerr("Too Few Arguments");    case 1:
960      env->err= 1;      printerr(env, "Too Few Arguments");
961      return;      return;
962    }    case 2:
963        printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type!=port) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
964      return;      return;
965      default:
966        break;
967    }    }
968    
969    stream=CAR(env->head)->content.p;    stream=CAR(env->head)->content.p;
# Line 949  extern void beep(environment *env) Line 978  extern void beep(environment *env)
978  {  {
979    int freq, dur, period, ticks;    int freq, dur, period, ticks;
980    
981    if(env->head->type==empty || CDR(env->head)->type==empty) {    switch(check_args(env, integer, integer, empty)) {
982      printerr("Too Few Arguments");    case 1:
983      env->err= 1;      printerr(env, "Too Few Arguments");
984      return;      return;
985    }    case 2:
986        printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type!=integer  
      || CAR(CDR(env->head))->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
987      return;      return;
988      default:
989        break;
990    }    }
991    
992    dur= CAR(env->head)->content.i;    dur= CAR(env->head)->content.i;
# Line 994  extern void sx_77616974(environment *env Line 1021  extern void sx_77616974(environment *env
1021  {  {
1022    int dur;    int dur;
1023    
1024    if(env->head->type==empty) {    switch(check_args(env, integer, empty)) {
1025      printerr("Too Few Arguments");    case 1:
1026      env->err= 1;      printerr(env, "Too Few Arguments");
1027      return;      return;
1028    }    case 2:
1029        printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
1030      return;      return;
1031      default:
1032        break;
1033    }    }
1034    
1035    dur= CAR(env->head)->content.i;    dur= CAR(env->head)->content.i;
# Line 1012  extern void sx_77616974(environment *env Line 1038  extern void sx_77616974(environment *env
1038    usleep(dur);    usleep(dur);
1039  }  }
1040    
1041    
1042  /* "*" */  /* "*" */
1043  extern void sx_2a(environment *env)  extern void sx_2a(environment *env)
1044  {  {
1045    int a, b;    int a, b;
1046    float fa, fb;    float fa, fb;
1047    
1048    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, unknown, unknown, empty)==1) {
1049      printerr("Too Few Arguments");      printerr(env, "Too Few Arguments");
     env->err= 1;  
1050      return;      return;
1051    }    }
1052      
1053    if(CAR(env->head)->type==integer    if(check_args(env, integer, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
1054      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
1055      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1056      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1035  extern void sx_2a(environment *env) Line 1060  extern void sx_2a(environment *env)
1060      return;      return;
1061    }    }
1062    
1063    if(CAR(env->head)->type==tfloat    if(check_args(env, tfloat, tfloat, empty)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
1064      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
1065      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1066      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1046  extern void sx_2a(environment *env) Line 1070  extern void sx_2a(environment *env)
1070      return;      return;
1071    }    }
1072    
1073    if(CAR(env->head)->type==tfloat    if(check_args(env, tfloat, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
1074      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
1075      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1076      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1057  extern void sx_2a(environment *env) Line 1080  extern void sx_2a(environment *env)
1080      return;      return;
1081    }    }
1082    
1083    if(CAR(env->head)->type==integer    if(check_args(env, integer, tfloat, empty)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
1084      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
1085      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1086      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1068  extern void sx_2a(environment *env) Line 1090  extern void sx_2a(environment *env)
1090      return;      return;
1091    }    }
1092    
1093    printerr("Bad Argument Type");    printerr(env, "Bad Argument Type");
1094    env->err= 2;    env->err= 2;
1095  }  }
1096    
# Line 1078  extern void sx_2f(environment *env) Line 1100  extern void sx_2f(environment *env)
1100    int a, b;    int a, b;
1101    float fa, fb;    float fa, fb;
1102    
1103    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, unknown, unknown, empty)==1) {
1104      printerr("Too Few Arguments");      printerr(env, "Too Few Arguments");
     env->err= 1;  
1105      return;      return;
1106    }    }
1107      
1108    if(CAR(env->head)->type==integer    if(check_args(env, integer, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
1109      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
1110      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1111      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1095  extern void sx_2f(environment *env) Line 1115  extern void sx_2f(environment *env)
1115      return;      return;
1116    }    }
1117    
1118    if(CAR(env->head)->type==tfloat    if(check_args(env, tfloat, tfloat, empty)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
1119      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
1120      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1121      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1106  extern void sx_2f(environment *env) Line 1125  extern void sx_2f(environment *env)
1125      return;      return;
1126    }    }
1127    
1128    if(CAR(env->head)->type==tfloat    if(check_args(env, tfloat, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
1129      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
1130      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1131      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1117  extern void sx_2f(environment *env) Line 1135  extern void sx_2f(environment *env)
1135      return;      return;
1136    }    }
1137    
1138    if(CAR(env->head)->type==integer    if(check_args(env, integer, tfloat, empty)==0) {
      && CAR(CDR(env->head))->type==tfloat) {  
1139      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
1140      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1141      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 1128  extern void sx_2f(environment *env) Line 1145  extern void sx_2f(environment *env)
1145      return;      return;
1146    }    }
1147    
1148    printerr("Bad Argument Type");    printerr(env, "Bad Argument Type");
1149    env->err= 2;    env->err= 2;
1150  }  }
1151    
# Line 1137  extern void mod(environment *env) Line 1154  extern void mod(environment *env)
1154  {  {
1155    int a, b;    int a, b;
1156    
1157    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, unknown, unknown, empty)==1) {
1158      printerr("Too Few Arguments");      printerr(env, "Too Few Arguments");
     env->err= 1;  
1159      return;      return;
1160    }    }
1161      
1162    if(CAR(env->head)->type==integer    if(check_args(env, integer, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
1163      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
1164      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1165      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1154  extern void mod(environment *env) Line 1169  extern void mod(environment *env)
1169      return;      return;
1170    }    }
1171    
1172    printerr("Bad Argument Type");    printerr(env, "Bad Argument Type");
1173    env->err= 2;    env->err= 2;
1174  }  }
1175    
# Line 1162  extern void mod(environment *env) Line 1177  extern void mod(environment *env)
1177  extern void sx_646976(environment *env)  extern void sx_646976(environment *env)
1178  {  {
1179    int a, b;    int a, b;
1180      
1181    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(check_args(env, unknown, unknown, empty)==1) {
1182      printerr("Too Few Arguments");      printerr(env, "Too Few Arguments");
     env->err= 1;  
1183      return;      return;
1184    }    }
1185      
1186    if(CAR(env->head)->type==integer    if(check_args(env, integer, integer, empty)==0) {
      && CAR(CDR(env->head))->type==integer) {  
1187      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
1188      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1189      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 1180  extern void sx_646976(environment *env) Line 1193  extern void sx_646976(environment *env)
1193      return;      return;
1194    }    }
1195    
1196    printerr("Bad Argument Type");    printerr(env, "Bad Argument Type");
1197    env->err= 2;    env->err= 2;
1198  }  }
1199    
1200    
1201  extern void setcar(environment *env)  extern void setcar(environment *env)
1202  {  {
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
1203    
1204    if(CDR(env->head)->type!=tcons) {    switch(check_args(env, tcons, unknown, empty)) {
1205      printerr("Bad Argument Type");    case 1:
1206      env->err= 2;      printerr(env, "Too Few Arguments");
1207      return;      return;
1208      case 2:
1209        printerr(env, "Bad Argument Type");
1210        return;
1211      default:
1212        break;
1213    }    }
1214    
1215    CAR(CAR(CDR(env->head)))=CAR(env->head);    CAR(CAR(CDR(env->head)))=CAR(env->head);
# Line 1204  extern void setcar(environment *env) Line 1218  extern void setcar(environment *env)
1218    
1219  extern void setcdr(environment *env)  extern void setcdr(environment *env)
1220  {  {
   if(env->head->type==empty || CDR(env->head)->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
1221    
1222    if(CDR(env->head)->type!=tcons) {    switch(check_args(env, tcons, unknown, empty)) {
1223      printerr("Bad Argument Type");    case 1:
1224      env->err= 2;      printerr(env, "Too Few Arguments");
1225        return;
1226      case 2:
1227        printerr(env, "Bad Argument Type");
1228      return;      return;
1229      default:
1230        break;
1231    }    }
1232    
1233    CDR(CAR(CDR(env->head)))=CAR(env->head);    CDR(CAR(CDR(env->head)))=CAR(env->head);
# Line 1222  extern void setcdr(environment *env) Line 1236  extern void setcdr(environment *env)
1236    
1237  extern void car(environment *env)  extern void car(environment *env)
1238  {  {
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
1239    
1240    if(CAR(env->head)->type!=tcons) {    switch(check_args(env, tcons, empty)) {
1241      printerr("Bad Argument Type");    case 1:
1242      env->err= 2;      printerr(env, "Too Few Arguments");
1243        return;
1244      case 2:
1245        printerr(env, "Bad Argument Type");
1246      return;      return;
1247      default:
1248        break;
1249    }    }
1250    
1251    CAR(env->head)=CAR(CAR(env->head));    CAR(env->head)=CAR(CAR(env->head));
# Line 1239  extern void car(environment *env) Line 1253  extern void car(environment *env)
1253    
1254  extern void cdr(environment *env)  extern void cdr(environment *env)
1255  {  {
   if(env->head->type==empty) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
1256    
1257    if(CAR(env->head)->type!=tcons) {    switch(check_args(env, tcons, empty)) {
1258      printerr("Bad Argument Type");    case 1:
1259      env->err= 2;      printerr(env, "Too Few Arguments");
1260      return;      return;
1261      case 2:
1262        printerr(env, "Bad Argument Type");
1263        return;
1264      default:
1265        break;
1266    }    }
1267    
1268    CAR(env->head)=CDR(CAR(env->head));    CAR(env->head)=CDR(CAR(env->head));
# Line 1258  extern void cons(environment *env) Line 1272  extern void cons(environment *env)
1272  {  {
1273    value *val;    value *val;
1274    
1275    if(env->head->type==empty || CDR(env->head)->type==empty) {    switch(check_args(env, unknown, unknown, empty)) {
1276      printerr("Too Few Arguments");    case 1:
1277      env->err= 1;      printerr(env, "Too Few Arguments");
1278        return;
1279      case 2:
1280        printerr(env, "Bad Argument Type");
1281      return;      return;
1282      default:
1283        break;
1284    }    }
1285    
1286    val=new_val(env);    val=new_val(env);
# Line 1282  extern void cons(environment *env) Line 1301  extern void cons(environment *env)
1301    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1302  }  }
1303    
1304    
1305    /* General assoc function */
1306    void assocgen(environment *env, funcp eqfunc)
1307    {
1308      value *key, *item;
1309    
1310      /* Needs two values on the stack, the top one must be an association
1311         list */
1312      switch(check_args(env, tcons, unknown, empty)) {
1313      case 1:
1314        printerr(env, "Too Few Arguments");
1315        return;
1316      case 2:
1317        printerr(env, "Bad Argument Type");
1318        return;
1319      default:
1320        break;
1321      }
1322    
1323      key=CAR(CDR(env->head));
1324      item=CAR(env->head);
1325    
1326      while(item->type == tcons){
1327        if(CAR(item)->type != tcons){
1328          printerr(env, "Bad Argument Type");
1329          env->err= 2;
1330          return;
1331        }
1332        push_val(env, key);
1333        push_val(env, CAR(CAR(item)));
1334        eqfunc(env); if(env->err) return;
1335    
1336        /* Check the result of 'eqfunc' */
1337        if(env->head->type==empty) {
1338          printerr(env, "Too Few Arguments");
1339          env->err= 1;
1340        return;
1341        }
1342        if(CAR(env->head)->type!=integer) {
1343          printerr(env, "Bad Argument Type");
1344          env->err= 2;
1345          return;
1346        }
1347    
1348        if(CAR(env->head)->content.i){
1349          toss(env); if(env->err) return;
1350          break;
1351        }
1352        toss(env); if(env->err) return;
1353    
1354        if(item->type!=tcons) {
1355          printerr(env, "Bad Argument Type");
1356          env->err= 2;
1357          return;
1358        }
1359    
1360        item=CDR(item);
1361      }
1362    
1363      if(item->type == tcons){      /* A match was found */
1364        push_val(env, CAR(item));
1365      } else {
1366        push_int(env, 0);
1367      }
1368      swap(env); if(env->err) return;
1369      toss(env); if(env->err) return;
1370      swap(env); if(env->err) return;
1371      toss(env);
1372    }
1373    
1374    
1375  /*  2: 3                        =>                */  /*  2: 3                        =>                */
1376  /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */  /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
1377  extern void assq(environment *env)  extern void assq(environment *env)
# Line 1305  extern void sx_6f70656e(environment *env Line 1395  extern void sx_6f70656e(environment *env
1395    value *new_port;    value *new_port;
1396    FILE *stream;    FILE *stream;
1397    
1398    if(env->head->type == empty || CDR(env->head)->type == empty) {    switch(check_args(env, string, string, empty)) {
1399      printerr("Too Few Arguments");    case 1:
1400      env->err=1;      printerr(env, "Too Few Arguments");
1401      return;      return;
1402    }    case 2:
1403        printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type != string  
      || CAR(CDR(env->head))->type != string) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
1404      return;      return;
1405      default:
1406        break;
1407    }    }
1408    
1409    stream=fopen(CAR(CDR(env->head))->content.ptr,    stream=fopen(CAR(CDR(env->head))->content.ptr,
# Line 1345  extern void sx_636c6f7365(environment *e Line 1433  extern void sx_636c6f7365(environment *e
1433  {  {
1434    int ret;    int ret;
1435    
1436    if(env->head->type == empty) {    switch(check_args(env, port, empty)) {
1437      printerr("Too Few Arguments");    case 1:
1438      env->err=1;      printerr(env, "Too Few Arguments");
1439      return;      return;
1440    }    case 2:
1441        printerr(env, "Bad Argument Type");
   if(CAR(env->head)->type != port) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
1442      return;      return;
1443      default:
1444        break;
1445    }    }
1446    
1447    ret= fclose(CAR(env->head)->content.p);    ret= fclose(CAR(env->head)->content.p);
# Line 1367  extern void sx_636c6f7365(environment *e Line 1454  extern void sx_636c6f7365(environment *e
1454    
1455    toss(env);    toss(env);
1456  }  }
1457    
1458    
1459    extern void mangle(environment *env)
1460    {
1461      char *new_string;
1462    
1463      switch(check_args(env, string, empty)) {
1464      case 1:
1465        printerr(env, "Too Few Arguments");
1466        return;
1467      case 2:
1468        printerr(env, "Bad Argument Type");
1469        return;
1470      default:
1471        break;
1472      }
1473    
1474      new_string= mangle_str(CAR(env->head)->content.string);
1475    
1476      toss(env);
1477      if(env->err) return;
1478    
1479      push_cstring(env, new_string);
1480    }
1481    
1482    /* "fork" */
1483    extern void sx_666f726b(environment *env)
1484    {
1485      push_int(env, fork());
1486    }
1487    
1488    /* "waitpid" */
1489    extern void sx_77616974706964(environment *env)
1490    {
1491    
1492      switch(check_args(env, integer, empty)) {
1493      case 1:
1494        printerr(env, "Too Few Arguments");
1495        return;
1496      case 2:
1497        printerr(env, "Bad Argument Type");
1498        return;
1499      default:
1500        break;
1501      }
1502    
1503      push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0));
1504      swap(env); toss(env);
1505    }
1506    
1507    
1508    /* Discard the top element of the stack. */
1509    extern void toss(environment *env)
1510    {
1511    
1512      switch(check_args(env, unknown, empty)) {
1513      case 1:
1514        printerr(env, "Too Few Arguments");
1515        return;
1516      case 2:
1517        printerr(env, "Bad Argument Type");
1518        return;
1519      default:
1520        break;
1521      }
1522    
1523      env->head= CDR(env->head); /* Remove the top stack item */
1524    }
1525    
1526    
1527    /* Quit stack. */
1528    extern void quit(environment *env)
1529    {
1530      int i;
1531    
1532      env->head= new_val(env);
1533    
1534      if (env->err) return;
1535      for(i= 0; i<HASHTBLSIZE; i++) {
1536        while(env->symbols[i]!= NULL) {
1537          forget_sym(&(env->symbols[i]));
1538        }
1539        env->symbols[i]= NULL;
1540      }
1541    
1542      env->gc_limit= 0;
1543      gc_maybe(env);
1544    
1545      words(env);
1546    
1547      if(env->free_string!=NULL)
1548        free(env->free_string);
1549      
1550    #ifdef __linux__
1551      muntrace();
1552    #endif
1553    
1554      exit(EXIT_SUCCESS);
1555    }
1556    
1557    
1558    /* List all defined words */
1559    extern void words(environment *env)
1560    {
1561      symbol *temp;
1562      int i;
1563      
1564      for(i= 0; i<HASHTBLSIZE; i++) {
1565        temp= env->symbols[i];
1566        while(temp!=NULL) {
1567    #ifdef DEBUG
1568          if (temp->val != NULL && temp->val->gc.flag.protect)
1569            printf("(protected) ");
1570    #endif /* DEBUG */
1571          printf("%s ", temp->id);
1572          temp= temp->next;
1573        }
1574      }
1575    }
1576    
1577    
1578    /* Only to be called by itself function printstack. */
1579    void print_st(environment *env, value *stack_head, long counter)
1580    {
1581      if(CDR(stack_head)->type != empty)
1582        print_st(env, CDR(stack_head), counter+1);
1583      printf("%ld: ", counter);
1584      print_val(env, CAR(stack_head), 0, NULL, stdout);
1585      printf("\n");
1586    }
1587    
1588    
1589    /* Prints the stack. */
1590    extern void printstack(environment *env)
1591    {
1592      if(env->head->type == empty) {
1593        printf("Stack Empty\n");
1594        return;
1595      }
1596    
1597      print_st(env, env->head, 1);
1598    }
1599    
1600    
1601    extern void copying(environment *env)
1602    {
1603      puts(license_message);
1604    }
1605    
1606    
1607    extern void warranty(environment *env)
1608    {
1609      puts(warranty_message);
1610    }
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.8
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26