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

Diff of /stack/stack.c

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

revision 1.100 by teddy, Sun Mar 10 12:05:20 2002 UTC revision 1.110 by teddy, Sat Mar 16 09:12:39 2002 UTC
# Line 20  Line 20 
20               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
21  */  */
22    
23    #define CAR(X) X->content.c->car
24    #define CDR(X) X->content.c->cdr
25    
26  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
27  #include <stdio.h>  #include <stdio.h>
28  /* exit, EXIT_SUCCESS, malloc, free */  /* exit, EXIT_SUCCESS, malloc, free */
# Line 34  Line 37 
37  #include <unistd.h>  #include <unistd.h>
38  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
39  #include <sysexits.h>  #include <sysexits.h>
40    /* assert */
41    #include <assert.h>
42    
43    #ifdef __linux__
44  /* mtrace, muntrace */  /* mtrace, muntrace */
45  #include <mcheck.h>  #include <mcheck.h>
46  /* ioctl */  /* ioctl */
47  #include <sys/ioctl.h>  #include <sys/ioctl.h>
48  /* KDMKTONE */  /* KDMKTONE */
49  #include <linux/kd.h>  #include <linux/kd.h>
50    #endif /* __linux__ */
51    
52  #include "stack.h"  #include "stack.h"
53    
# Line 70  void printerr(const char* in_string) Line 78  void printerr(const char* in_string)
78  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
79  extern void toss(environment *env)  extern void toss(environment *env)
80  {  {
81    stackitem *temp= env->head;    if(env->head==NULL) {
   
   if((env->head)==NULL) {  
82      printerr("Too Few Arguments");      printerr("Too Few Arguments");
83      env->err= 1;      env->err= 1;
84      return;      return;
85    }    }
86        
87    env->head= env->head->next;   /* Remove the top stack item */    env->head= CDR(env->head); /* Remove the top stack item */
   free(temp);                   /* Free the old top stack item */  
88  }  }
89    
90  /* Returns a pointer to a pointer to an element in the hash table. */  /* Returns a pointer to a pointer to an element in the hash table. */
# Line 118  value* new_val(environment *env) Line 123  value* new_val(environment *env)
123    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
124    
125    nval->content.ptr= NULL;    nval->content.ptr= NULL;
126      nval->type= integer;
127    
128    nitem->item= nval;    nitem->item= nval;
129    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
130    
131    env->gc_ref= nitem;    env->gc_ref= nitem;
132    
133    env->gc_count+=sizeof(value);    env->gc_count += sizeof(value);
134    nval->gc.flag.mark= 0;    nval->gc.flag.mark= 0;
135    nval->gc.flag.protect= 0;    nval->gc.flag.protect= 0;
136    
# Line 134  value* new_val(environment *env) Line 141  value* new_val(environment *env)
141     Marked values are not collected by the GC. */     Marked values are not collected by the GC. */
142  inline void gc_mark(value *val)  inline void gc_mark(value *val)
143  {  {
144    stackitem *iterator;    if(val==NULL || val->gc.flag.mark)
   
   if(val->gc.flag.mark)  
145      return;      return;
146    
147    val->gc.flag.mark= 1;    val->gc.flag.mark= 1;
148    
149    if(val->type==list) {    if(val->type==tcons) {
150      iterator= val->content.ptr;      gc_mark(CAR(val));
151        gc_mark(CDR(val));
     while(iterator!=NULL) {  
       gc_mark(iterator->item);  
       iterator= iterator->next;  
     }  
152    }    }
153  }  }
154    
# Line 162  inline void gc_maybe(environment *env) Line 163  inline void gc_maybe(environment *env)
163  /* Start GC */  /* Start GC */
164  extern void gc_init(environment *env)  extern void gc_init(environment *env)
165  {  {
166    stackitem *new_head= NULL, *titem, *iterator;    stackitem *new_head= NULL, *titem;
167      cons *iterator;
168    symbol *tsymb;    symbol *tsymb;
169    int i;    int i;
170    
171    if(env->interactive){    if(env->interactive)
172      printf("Garbage collecting.", env->gc_count, env->gc_limit);      printf("Garbage collecting.");
   }  
173    
174    /* Mark values on stack */    /* Mark values on stack */
175    iterator= env->head;    gc_mark(env->head);
   while(iterator!=NULL) {  
     gc_mark(iterator->item);  
     iterator= iterator->next;  
   }  
176    
177    if(env->interactive){    if(env->interactive)
178      printf(".");      printf(".");
179    }  
180    
181    /* Mark values in hashtable */    /* Mark values in hashtable */
182    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++)
183      tsymb= env->symbols[i];      for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
     while(tsymb!=NULL) {  
184        if (tsymb->val != NULL)        if (tsymb->val != NULL)
185          gc_mark(tsymb->val);          gc_mark(tsymb->val);
       tsymb= tsymb->next;  
     }  
   }  
186    
187    if(env->interactive){  
188      if(env->interactive)
189      printf(".");      printf(".");
   }  
190    
191    env->gc_count= 0;    env->gc_count= 0;
192    
# Line 201  extern void gc_init(environment *env) Line 194  extern void gc_init(environment *env)
194    
195      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
196    
197        switch(env->gc_ref->item->type) { /* Remove content */        if(env->gc_ref->item->type==string) /* Remove content */
       case string:  
198          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
199          break;  
       case list:  
         while(env->gc_ref->item->content.ptr!=NULL) {  
           titem= env->gc_ref->item->content.ptr;  
           env->gc_ref->item->content.ptr= titem->next;  
           free(titem);  
         }  
       default:  
       }  
200        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
201        titem= env->gc_ref->next;        titem= env->gc_ref->next;
202        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
203        env->gc_ref= titem;        env->gc_ref= titem;
204        continue;        continue;
     } else {  
       env->gc_count += sizeof(value);  
205      }      }
206    #ifdef DEBUG
207        printf("Kept value (%p)", env->gc_ref->item);
208        if(env->gc_ref->item->gc.flag.mark)
209          printf(" (marked)");
210        if(env->gc_ref->item->gc.flag.protect)
211          printf(" (protected)");
212        switch(env->gc_ref->item->type){
213        case integer:
214          printf(" integer: %d", env->gc_ref->item->content.i);
215          break;
216        case func:
217          printf(" func: %p", env->gc_ref->item->content.ptr);
218          break;
219        case symb:
220          printf(" symb: %s", env->gc_ref->item->content.sym->id);
221          break;
222        case tcons:
223          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
224                 env->gc_ref->item->content.c->cdr);
225          break;
226        default:
227          printf(" <unknown %d>", (env->gc_ref->item->type));
228        }
229        printf("\n");
230    #endif /* DEBUG */
231    
232        /* Keep values */    
233        env->gc_count += sizeof(value);
234        if(env->gc_ref->item->type==string)
235          env->gc_count += strlen(env->gc_ref->item->content.ptr);
236            
     /* Keep values */  
237      titem= env->gc_ref->next;      titem= env->gc_ref->next;
238      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
239      new_head= env->gc_ref;      new_head= env->gc_ref;
# Line 232  extern void gc_init(environment *env) Line 243  extern void gc_init(environment *env)
243    
244    if (env->gc_limit < env->gc_count*2)    if (env->gc_limit < env->gc_count*2)
245      env->gc_limit= env->gc_count*2;      env->gc_limit= env->gc_count*2;
246    
247    env->gc_ref= new_head;    env->gc_ref= new_head;
248    
249    if(env->interactive){    if(env->interactive)
250      printf("done\n");      printf("done (%d bytes still allocated)\n", env->gc_count);
   }  
251    
252  }  }
253    
254  /* Protect values from GC */  /* Protect values from GC */
255  void protect(value *val)  void protect(value *val)
256  {  {
257    stackitem *iterator;    if(val==NULL || val->gc.flag.protect)
   
   if(val->gc.flag.protect)  
258      return;      return;
259    
260    val->gc.flag.protect= 1;    val->gc.flag.protect= 1;
261    
262    if(val->type==list) {    if(val->type==tcons) {
263      iterator= val->content.ptr;      protect(CAR(val));
264        protect(CDR(val));
     while(iterator!=NULL) {  
       protect(iterator->item);  
       iterator= iterator->next;  
     }  
265    }    }
266  }  }
267    
268  /* Unprotect values from GC */  /* Unprotect values from GC */
269  void unprotect(value *val)  void unprotect(value *val)
270  {  {
271    stackitem *iterator;    if(val==NULL || !(val->gc.flag.protect))
   
   if(!(val->gc.flag.protect))  
272      return;      return;
273    
274    val->gc.flag.protect= 0;    val->gc.flag.protect= 0;
275    
276    if(val->type==list) {    if(val->type==tcons) {
277      iterator= val->content.ptr;      unprotect(CAR(val));
278        unprotect(CDR(val));
     while(iterator!=NULL) {  
       unprotect(iterator->item);  
       iterator= iterator->next;  
     }  
279    }    }
280  }  }
281    
282  /* Push a value onto the stack */  /* Push a value onto the stack */
283  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
284  {  {
285    stackitem *new_item= malloc(sizeof(stackitem));    value *new_value= new_val(env);
286    new_item->item= val;  
287    new_item->next= env->head;    new_value->content.c= malloc(sizeof(cons));
288    env->head= new_item;    assert(new_value->content.c!=NULL);
289      new_value->type= tcons;
290      CAR(new_value)= val;
291      CDR(new_value)= env->head;
292      env->head= new_value;
293  }  }
294    
295  /* Push an integer onto the stack */  /* Push an integer onto the stack */
# Line 315  void push_float(environment *env, float Line 318  void push_float(environment *env, float
318  void push_cstring(environment *env, const char *in_string)  void push_cstring(environment *env, const char *in_string)
319  {  {
320    value *new_value= new_val(env);    value *new_value= new_val(env);
321      int length= strlen(in_string)+1;
322    
323    new_value->content.ptr= malloc(strlen(in_string)+1);    new_value->content.ptr= malloc(length);
324      env->gc_count += length;
325    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
326    new_value->type= string;    new_value->type= string;
327    
# Line 347  extern void mangle(environment *env) Line 352  extern void mangle(environment *env)
352  {  {
353    char *new_string;    char *new_string;
354    
355    if((env->head)==NULL) {    if(env->head==NULL) {
356      printerr("Too Few Arguments");      printerr("Too Few Arguments");
357      env->err= 1;      env->err= 1;
358      return;      return;
359    }    }
360    
361    if(env->head->item->type!=string) {    if(CAR(env->head)->type!=string) {
362      printerr("Bad Argument Type");      printerr("Bad Argument Type");
363      env->err= 2;      env->err= 2;
364      return;      return;
365    }    }
366    
367    new_string= mangle_str((const char *)(env->head->item->content.ptr));    new_string=
368        mangle_str((const char *)(CAR(env->head)->content.ptr));
369    
370    toss(env);    toss(env);
371    if(env->err) return;    if(env->err) return;
# Line 445  extern void type(environment *env) Line 451  extern void type(environment *env)
451  {  {
452    int typenum;    int typenum;
453    
454    if((env->head)==NULL) {    if(env->head==NULL) {
455      printerr("Too Few Arguments");      printerr("Too Few Arguments");
456      env->err=1;      env->err= 1;
457      return;      return;
458    }    }
459    typenum=env->head->item->type;  
460      typenum= CAR(env->head)->type;
461    toss(env);    toss(env);
462    switch(typenum){    switch(typenum){
463    case integer:    case integer:
# Line 468  extern void type(environment *env) Line 475  extern void type(environment *env)
475    case func:    case func:
476      push_sym(env, "function");      push_sym(env, "function");
477      break;      break;
478    case list:    case tcons:
479      push_sym(env, "list");      push_sym(env, "list");
480      break;      break;
481    }    }
482  }      }    
483    
484  /* Prints the top element of the stack. */  /* Prints the top element of the stack. */
485  void print_h(stackitem *stack_head, int noquote)  void print_h(value *stack_head, int noquote)
486  {  {
487    switch(stack_head->item->type) {    switch(CAR(stack_head)->type) {
488    case integer:    case integer:
489      printf("%d", stack_head->item->content.i);      printf("%d", CAR(stack_head)->content.i);
490      break;      break;
491    case tfloat:    case tfloat:
492      printf("%f", stack_head->item->content.f);      printf("%f", CAR(stack_head)->content.f);
493      break;      break;
494    case string:    case string:
495      if(noquote)      if(noquote)
496        printf("%s", (char*)stack_head->item->content.ptr);        printf("%s", (char*)CAR(stack_head)->content.ptr);
497      else      else
498        printf("\"%s\"", (char*)stack_head->item->content.ptr);        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);
499      break;      break;
500    case symb:    case symb:
501      printf("%s", ((symbol *)(stack_head->item->content.ptr))->id);      printf("%s", CAR(stack_head)->content.sym->id);
502      break;      break;
503    case func:    case func:
504      printf("#<function %p>", (funcp)(stack_head->item->content.ptr));      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));
505      break;      break;
506    case list:    case tcons:
507      /* A list is just a stack, so make stack_head point to it */      /* A list is just a stack, so make stack_head point to it */
508      stack_head=(stackitem *)(stack_head->item->content.ptr);      stack_head= CAR(stack_head);
509      printf("[ ");      printf("[ ");
510      while(stack_head != NULL) {      while(stack_head != NULL) {
511        print_h(stack_head, noquote);        print_h(stack_head, noquote);
512        printf(" ");        printf(" ");
513        stack_head=stack_head->next;        stack_head= CDR(stack_head);
514      }      }
515      printf("]");      printf("]");
516      break;      break;
# Line 514  extern void print_(environment *env) Line 521  extern void print_(environment *env)
521  {  {
522    if(env->head==NULL) {    if(env->head==NULL) {
523      printerr("Too Few Arguments");      printerr("Too Few Arguments");
524      env->err=1;      env->err= 1;
525      return;      return;
526    }    }
527    print_h(env->head, 0);    print_h(env->head, 0);
# Line 533  extern void princ_(environment *env) Line 540  extern void princ_(environment *env)
540  {  {
541    if(env->head==NULL) {    if(env->head==NULL) {
542      printerr("Too Few Arguments");      printerr("Too Few Arguments");
543      env->err=1;      env->err= 1;
544      return;      return;
545    }    }
546    print_h(env->head, 1);    print_h(env->head, 1);
# Line 548  extern void princ(environment *env) Line 555  extern void princ(environment *env)
555  }  }
556    
557  /* Only to be called by function printstack. */  /* Only to be called by function printstack. */
558  void print_st(stackitem *stack_head, long counter)  void print_st(value *stack_head, long counter)
559  {  {
560    if(stack_head->next != NULL)    if(CDR(stack_head) != NULL)
561      print_st(stack_head->next, counter+1);      print_st(CDR(stack_head), counter+1);
562    printf("%ld: ", counter);    printf("%ld: ", counter);
563    print_h(stack_head, 0);    print_h(stack_head, 0);
564    nl();    nl();
# Line 571  extern void printstack(environment *env) Line 578  extern void printstack(environment *env)
578  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
579  extern void swap(environment *env)  extern void swap(environment *env)
580  {  {
581    stackitem *temp= env->head;    value *temp= env->head;
582        
583    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
584      printerr("Too Few Arguments");      printerr("Too Few Arguments");
585      env->err=1;      env->err=1;
586      return;      return;
587    }    }
588    
589    env->head= env->head->next;    env->head= CDR(env->head);
590    temp->next= env->head->next;    CDR(temp)= CDR(env->head);
591    env->head->next= temp;    CDR(env->head)= temp;
592  }  }
593    
594  /* Rotate the first three elements on the stack. */  /* Rotate the first three elements on the stack. */
595  extern void rot(environment *env)  extern void rot(environment *env)
596  {  {
597    stackitem *temp= env->head;    value *temp= env->head;
598        
599    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
600        || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
601      printerr("Too Few Arguments");      printerr("Too Few Arguments");
602      env->err=1;      env->err= 1;
603      return;      return;
604    }    }
605      
606    env->head= env->head->next->next;    env->head= CDR(CDR(env->head));
607    temp->next->next= env->head->next;    CDR(CDR(temp))= CDR(env->head);
608    env->head->next= temp;    CDR(env->head)= temp;
609  }  }
610    
611  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
# Line 606  extern void rcl(environment *env) Line 613  extern void rcl(environment *env)
613  {  {
614    value *val;    value *val;
615    
616    if(env->head == NULL) {    if(env->head==NULL) {
617      printerr("Too Few Arguments");      printerr("Too Few Arguments");
618      env->err=1;      env->err= 1;
619      return;      return;
620    }    }
621    
622    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
623      printerr("Bad Argument Type");      printerr("Bad Argument Type");
624      env->err=2;      env->err= 2;
625      return;      return;
626    }    }
627    
628    val=((symbol *)(env->head->item->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
629    if(val == NULL){    if(val == NULL){
630      printerr("Unbound Variable");      printerr("Unbound Variable");
631      env->err=3;      env->err= 3;
632      return;      return;
633    }    }
634    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
635    toss(env);            /* toss the symbol */    swap(env);
636      if(env->err) return;
637      toss(env);                    /* toss the symbol */
638    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
639  }  }
640    
641  /* If the top element is a symbol, determine if it's bound to a  /* If the top element is a symbol, determine if it's bound to a
# Line 638  extern void eval(environment *env) Line 645  extern void eval(environment *env)
645  {  {
646    funcp in_func;    funcp in_func;
647    value* temp_val;    value* temp_val;
648    stackitem* iterator;    value* iterator;
649    
650   eval_start:   eval_start:
651    
# Line 646  extern void eval(environment *env) Line 653  extern void eval(environment *env)
653    
654    if(env->head==NULL) {    if(env->head==NULL) {
655      printerr("Too Few Arguments");      printerr("Too Few Arguments");
656      env->err=1;      env->err= 1;
657      return;      return;
658    }    }
659    
660    switch(env->head->item->type) {    switch(CAR(env->head)->type) {
661      /* if it's a symbol */      /* if it's a symbol */
662    case symb:    case symb:
663      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
664      if(env->err) return;      if(env->err) return;
665      if(env->head->item->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
666        goto eval_start;        goto eval_start;
667      }      }
668      return;      return;
669    
670      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
671    case func:    case func:
672      in_func= (funcp)(env->head->item->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
673      toss(env);      toss(env);
674      if(env->err) return;      if(env->err) return;
675      return in_func(env);      return in_func(env);
676    
677      /* If it's a list */      /* If it's a list */
678    case list:    case tcons:
679      temp_val= env->head->item;      temp_val= CAR(env->head);
680      protect(temp_val);      protect(temp_val);
681    
682      toss(env); if(env->err) return;      toss(env); if(env->err) return;
683      iterator= (stackitem*)temp_val->content.ptr;      iterator= temp_val;
684            
685      while(iterator!=NULL) {      while(iterator!=NULL) {
686        push_val(env, iterator->item);        push_val(env, CAR(iterator));
687                
688        if(env->head->item->type==symb        if(CAR(env->head)->type==symb
689           && (((symbol*)(env->head->item->content.ptr))->id[0] == ';')) {           && CAR(env->head)->content.sym->id[0]==';') {
690          toss(env);          toss(env);
691          if(env->err) return;          if(env->err) return;
692                    
693          if(iterator->next == NULL){          if(CDR(iterator)==NULL){
694            goto eval_start;            goto eval_start;
695          }          }
696          eval(env);          eval(env);
697          if(env->err) return;          if(env->err) return;
698        }        }
699        iterator= iterator->next;        if (CDR(iterator)==NULL || CDR(iterator)->type == tcons)
700            iterator= CDR(iterator);
701          else {
702            printerr("Bad Argument Type"); /* Improper list */
703            env->err= 2;
704            return;
705          }
706      }      }
707      unprotect(temp_val);      unprotect(temp_val);
708      return;      return;
# Line 702  extern void eval(environment *env) Line 715  extern void eval(environment *env)
715  /* Reverse (flip) a list */  /* Reverse (flip) a list */
716  extern void rev(environment *env)  extern void rev(environment *env)
717  {  {
718    stackitem *old_head, *new_head, *item;    value *old_head, *new_head, *item;
719    
720    if((env->head)==NULL) {    if(env->head==NULL) {
721      printerr("Too Few Arguments");      printerr("Too Few Arguments");
722      env->err= 1;      env->err= 1;
723      return;      return;
724    }    }
725    
726    if(env->head->item->type!=list) {    if(CAR(env->head)->type!=tcons) {
727      printerr("Bad Argument Type");      printerr("Bad Argument Type");
728      env->err= 2;      env->err= 2;
729      return;      return;
730    }    }
731    
732    old_head= (stackitem *)(env->head->item->content.ptr);    old_head= CAR(env->head);
733    new_head= NULL;    new_head= NULL;
734    while(old_head != NULL){    while(old_head!=NULL) {
735      item= old_head;      item= old_head;
736      old_head= old_head->next;      old_head= CDR(old_head);
737      item->next= new_head;      CDR(item)= new_head;
738      new_head= item;      new_head= item;
739    }    }
740    env->head->item->content.ptr= new_head;    CAR(env->head)= new_head;
741  }  }
742    
743  /* Make a list. */  /* Make a list. */
744  extern void pack(environment *env)  extern void pack(environment *env)
745  {  {
746    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
747    
748    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(pack);  
   
749    if(iterator==NULL    if(iterator==NULL
750       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
751       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
752      temp= NULL;      temp= NULL;
753      toss(env);      toss(env);
754    } else {    } else {
755      /* Search for first delimiter */      /* Search for first delimiter */
756      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
757            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
758            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
759        iterator= iterator->next;        iterator= CDR(iterator);
760            
761      /* Extract list */      /* Extract list */
762      temp= env->head;      temp= env->head;
763      env->head= iterator->next;      env->head= CDR(iterator);
764      iterator->next= NULL;      CDR(iterator)= NULL;
765    
     pack->type= list;  
     pack->content.ptr= temp;  
       
766      if(env->head!=NULL)      if(env->head!=NULL)
767        toss(env);        toss(env);
768    }    }
769    
770    /* Push list */    /* Push list */
771    
772    push_val(env, pack);    push_val(env, temp);
773    rev(env);    rev(env);
   
   unprotect(pack);  
774  }  }
775    
776  /* Relocate elements of the list on the stack. */  /* Relocate elements of the list on the stack. */
777  extern void expand(environment *env)  extern void expand(environment *env)
778  {  {
779    stackitem *temp, *new_head;    value *temp, *new_head;
780    
781    /* Is top element a list? */    /* Is top element a list? */
782    if(env->head==NULL) {    if(env->head==NULL) {
# Line 780  extern void expand(environment *env) Line 784  extern void expand(environment *env)
784      env->err= 1;      env->err= 1;
785      return;      return;
786    }    }
787    if(env->head->item->type!=list) {  
788      if(CAR(env->head)->type!=tcons) {
789      printerr("Bad Argument Type");      printerr("Bad Argument Type");
790      env->err= 2;      env->err= 2;
791      return;      return;
# Line 792  extern void expand(environment *env) Line 797  extern void expand(environment *env)
797      return;      return;
798    
799    /* The first list element is the new stack head */    /* The first list element is the new stack head */
800    new_head= temp= env->head->item->content.ptr;    new_head= temp= CAR(env->head);
801    
802    toss(env);    toss(env);
803    
804    /* Find the end of the list */    /* Find the end of the list */
805    while(temp->next!=NULL)    while(CDR(temp)->content.ptr != NULL) {
806      temp= temp->next;      if (CDR(temp)->type == tcons)
807          temp= CDR(temp);
808        else {
809          printerr("Bad Argument Type"); /* Improper list */
810          env->err= 2;
811          return;
812        }
813      }
814    
815    /* Connect the tail of the list with the old stack head */    /* Connect the tail of the list with the old stack head */
816    temp->next= env->head;    CDR(temp)= env->head;
817    env->head= new_head;          /* ...and voila! */    env->head= new_head;          /* ...and voila! */
818    
819  }  }
# Line 810  extern void expand(environment *env) Line 822  extern void expand(environment *env)
822  extern void eq(environment *env)  extern void eq(environment *env)
823  {  {
824    void *left, *right;    void *left, *right;
   int result;  
825    
826    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
827      printerr("Too Few Arguments");      printerr("Too Few Arguments");
828      env->err= 1;      env->err= 1;
829      return;      return;
830    }    }
831    
832    left= env->head->item->content.ptr;    left= CAR(env->head)->content.ptr;
833    swap(env);    right= CAR(CDR(env->head))->content.ptr;
   right= env->head->item->content.ptr;  
   result= (left==right);  
     
834    toss(env); toss(env);    toss(env); toss(env);
835    push_int(env, result);  
836      push_int(env, left==right);
837  }  }
838    
839  /* Negates the top element on the stack. */  /* Negates the top element on the stack. */
# Line 832  extern void not(environment *env) Line 841  extern void not(environment *env)
841  {  {
842    int val;    int val;
843    
844    if((env->head)==NULL) {    if(env->head==NULL) {
845      printerr("Too Few Arguments");      printerr("Too Few Arguments");
846      env->err= 1;      env->err= 1;
847      return;      return;
848    }    }
849    
850    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
851      printerr("Bad Argument Type");      printerr("Bad Argument Type");
852      env->err= 2;      env->err= 2;
853      return;      return;
854    }    }
855    
856    val= env->head->item->content.i;    val= CAR(env->head)->content.i;
857    toss(env);    toss(env);
858    push_int(env, !val);    push_int(env, !val);
859  }  }
# Line 863  extern void def(environment *env) Line 872  extern void def(environment *env)
872    symbol *sym;    symbol *sym;
873    
874    /* 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 */
875    if(env->head==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
876      printerr("Too Few Arguments");      printerr("Too Few Arguments");
877      env->err= 1;      env->err= 1;
878      return;      return;
879    }    }
880    
881    if(env->head->item->type!=symb) {    if(CAR(env->head)->type!=symb) {
882      printerr("Bad Argument Type");      printerr("Bad Argument Type");
883      env->err= 2;      env->err= 2;
884      return;      return;
885    }    }
886    
887    /* long names are a pain */    /* long names are a pain */
888    sym= env->head->item->content.ptr;    sym= CAR(env->head)->content.ptr;
889    
890    /* Bind the symbol to the value */    /* Bind the symbol to the value */
891    sym->val= env->head->next->item;    sym->val= CAR(CDR(env->head));
892    
893    toss(env); toss(env);    toss(env); toss(env);
894  }  }
# Line 902  extern void quit(environment *env) Line 911  extern void quit(environment *env)
911    env->gc_limit= 0;    env->gc_limit= 0;
912    gc_maybe(env);    gc_maybe(env);
913    
914      words(env);
915    
916    if(env->free_string!=NULL)    if(env->free_string!=NULL)
917      free(env->free_string);      free(env->free_string);
918        
919    #ifdef __linux__
920    muntrace();    muntrace();
921    #endif
922    
923    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
924  }  }
# Line 926  extern void words(environment *env) Line 939  extern void words(environment *env)
939    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
940      temp= env->symbols[i];      temp= env->symbols[i];
941      while(temp!=NULL) {      while(temp!=NULL) {
942    #ifdef DEBUG
943          if (temp->val != NULL && temp->val->gc.flag.protect)
944            printf("(protected) ");
945    #endif /* DEBUG */
946        printf("%s\n", temp->id);        printf("%s\n", temp->id);
947        temp= temp->next;        temp= temp->next;
948      }      }
# Line 948  void forget_sym(symbol **hash_entry) Line 965  void forget_sym(symbol **hash_entry)
965  extern void forget(environment *env)  extern void forget(environment *env)
966  {  {
967    char* sym_id;    char* sym_id;
968    stackitem *stack_head= env->head;    value *stack_head= env->head;
969    
970    if(stack_head==NULL) {    if(stack_head==NULL) {
971      printerr("Too Few Arguments");      printerr("Too Few Arguments");
972      env->err=1;      env->err= 1;
973      return;      return;
974    }    }
975        
976    if(stack_head->item->type!=symb) {    if(CAR(stack_head)->type!=symb) {
977      printerr("Bad Argument Type");      printerr("Bad Argument Type");
978      env->err=2;      env->err= 2;
979      return;      return;
980    }    }
981    
982    sym_id= ((symbol*)(stack_head->item->content.ptr))->id;    sym_id= CAR(stack_head)->content.sym->id;
983    toss(env);    toss(env);
984    
985    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 980  int main(int argc, char **argv) Line 997  int main(int argc, char **argv)
997    
998    int c;                        /* getopt option character */    int c;                        /* getopt option character */
999    
1000    #ifdef __linux__
1001    mtrace();    mtrace();
1002    #endif
1003    
1004    init_env(&myenv);    init_env(&myenv);
1005    
# Line 994  int main(int argc, char **argv) Line 1013  int main(int argc, char **argv)
1013          break;          break;
1014        case '?':        case '?':
1015          fprintf (stderr,          fprintf (stderr,
1016                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1017                   optopt);                   optopt);
1018          return EX_USAGE;          return EX_USAGE;
1019        default:        default:
# Line 1013  int main(int argc, char **argv) Line 1032  int main(int argc, char **argv)
1032    if(myenv.interactive) {    if(myenv.interactive) {
1033      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1034  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1035  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1036  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1037  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1038    }    }
1039    
1040    while(1) {    while(1) {
# Line 1030  under certain conditions; type `copying; Line 1049  under certain conditions; type `copying;
1049        }        }
1050        myenv.err=0;        myenv.err=0;
1051      }      }
1052      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1053      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1054        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1055          quit(&myenv);
1056      } else if(myenv.head!=NULL      } else if(myenv.head!=NULL
1057                && myenv.head->item->type==symb                && CAR(myenv.head)->type==symb
1058                && ((symbol*)(myenv.head->item->content.ptr))->id[0]==';') {                && CAR(myenv.head)->content.sym->id[0]
1059                  ==';') {
1060        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1061        eval(&myenv);        eval(&myenv);
1062      }      }
# Line 1054  extern void sx_2b(environment *env) Line 1075  extern void sx_2b(environment *env)
1075    char* new_string;    char* new_string;
1076    value *a_val, *b_val;    value *a_val, *b_val;
1077    
1078    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1079      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1080      env->err= 1;      env->err= 1;
1081      return;      return;
1082    }    }
1083    
1084    if(env->head->item->type==string    if(CAR(env->head)->type==string
1085       && env->head->next->item->type==string) {       && CAR(CDR(env->head))->type==string) {
1086      a_val= env->head->item;      a_val= CAR(env->head);
1087      b_val= env->head->next->item;      b_val= CAR(CDR(env->head));
1088      protect(a_val); protect(b_val);      protect(a_val); protect(b_val);
1089      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1090      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1078  extern void sx_2b(environment *env) Line 1099  extern void sx_2b(environment *env)
1099      return;      return;
1100    }    }
1101        
1102    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1103       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1104      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1105      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1106      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1107      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1108      push_int(env, b+a);      push_int(env, b+a);
1109    
1110      return;      return;
1111    }    }
1112    
1113    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1114       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1115      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1116      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1117      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1118      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1119      push_float(env, fb+fa);      push_float(env, fb+fa);
1120            
1121      return;      return;
1122    }    }
1123    
1124    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1125       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1126      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1127      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1128      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1129      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1130      push_float(env, b+fa);      push_float(env, b+fa);
1131            
1132      return;      return;
1133    }    }
1134    
1135    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1136       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1137      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1138      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1139      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1140      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1141      push_float(env, fb+a);      push_float(env, fb+a);
1142    
# Line 1132  extern void sx_2d(environment *env) Line 1153  extern void sx_2d(environment *env)
1153    int a, b;    int a, b;
1154    float fa, fb;    float fa, fb;
1155    
1156    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1157      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1158      env->err=1;      env->err=1;
1159      return;      return;
1160    }    }
1161        
1162    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1163       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1164      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1165      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1166      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1167      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1168      push_int(env, b-a);      push_int(env, b-a);
1169    
1170      return;      return;
1171    }    }
1172    
1173    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1174       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1175      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1176      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1177      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1178      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1179      push_float(env, fb-fa);      push_float(env, fb-fa);
1180            
1181      return;      return;
1182    }    }
1183    
1184    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1185       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1186      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1187      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1188      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1189      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1190      push_float(env, b-fa);      push_float(env, b-fa);
1191            
1192      return;      return;
1193    }    }
1194    
1195    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1196       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1197      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1198      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1199      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1200      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1201      push_float(env, fb-a);      push_float(env, fb-a);
1202    
# Line 1192  extern void sx_3e(environment *env) Line 1213  extern void sx_3e(environment *env)
1213    int a, b;    int a, b;
1214    float fa, fb;    float fa, fb;
1215    
1216    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1217      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1218      env->err=1;      env->err= 1;
1219      return;      return;
1220    }    }
1221        
1222    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1223       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1224      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
1225      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1226      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
1227      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1228      push_int(env, b>a);      push_int(env, b>a);
1229    
1230      return;      return;
1231    }    }
1232    
1233    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1234       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1235      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1236      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1237      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1238      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1239      push_int(env, fb>fa);      push_int(env, fb>fa);
1240            
1241      return;      return;
1242    }    }
1243    
1244    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
1245       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
1246      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
1247      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1248      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
1249      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1250      push_int(env, b>fa);      push_int(env, b>fa);
1251            
1252      return;      return;
1253    }    }
1254    
1255    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
1256       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
1257      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
1258      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1259      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
1260      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1261      push_int(env, fb>a);      push_int(env, fb>a);
1262    
# Line 1243  extern void sx_3e(environment *env) Line 1264  extern void sx_3e(environment *env)
1264    }    }
1265    
1266    printerr("Bad Argument Type");    printerr("Bad Argument Type");
1267    env->err=2;    env->err= 2;
1268  }  }
1269    
1270  /* "<" */  /* "<" */
# Line 1270  extern void sx_3e3d(environment *env) Line 1291  extern void sx_3e3d(environment *env)
1291  /* Return copy of a value */  /* Return copy of a value */
1292  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
1293  {  {
   stackitem *old_item, *new_item, *prev_item;  
1294    value *new_value;    value *new_value;
1295    
1296      if(old_value==NULL)
1297        return NULL;
1298    
1299    protect(old_value);    protect(old_value);
1300    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
1301    new_value->type= old_value->type;    new_value->type= old_value->type;
1302    
1303    switch(old_value->type){    switch(old_value->type){
# Line 1289  value *copy_val(environment *env, value Line 1311  value *copy_val(environment *env, value
1311      (char *)(new_value->content.ptr)=      (char *)(new_value->content.ptr)=
1312        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1313      break;      break;
1314    case list:    case tcons:
     new_value->content.ptr= NULL;  
1315    
1316      prev_item= NULL;      new_value->content.c= malloc(sizeof(cons));
1317      old_item= (stackitem*)(old_value->content.ptr);      assert(new_value->content.c!=NULL);
1318    
1319      while(old_item != NULL) {   /* While list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1320        new_item= malloc(sizeof(stackitem));      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
       new_item->item= copy_val(env, old_item->item); /* recurse */  
       new_item->next= NULL;  
       if(prev_item != NULL)     /* If this wasn't the first item */  
         prev_item->next= new_item; /* point the previous item to the  
                                      new item */  
       else  
         new_value->content.ptr= new_item;  
       old_item= old_item->next;  
       prev_item= new_item;  
     }      
1321      break;      break;
1322    }    }
1323    
1324    unprotect(old_value); unprotect(new_value);    unprotect(old_value);
1325    
1326    return new_value;    return new_value;
1327  }  }
# Line 1318  value *copy_val(environment *env, value Line 1329  value *copy_val(environment *env, value
1329  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1330  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1331  {  {
1332    if((env->head)==NULL) {    if(env->head==NULL) {
1333      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1334      env->err= 1;      env->err= 1;
1335      return;      return;
1336    }    }
1337    push_val(env, copy_val(env, env->head->item));    push_val(env, copy_val(env, CAR(env->head)));
1338  }  }
1339    
1340  /* "if", If-Then */  /* "if", If-Then */
# Line 1331  extern void sx_6966(environment *env) Line 1342  extern void sx_6966(environment *env)
1342  {  {
1343    int truth;    int truth;
1344    
1345    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1346      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1347      env->err= 1;      env->err= 1;
1348      return;      return;
1349    }    }
1350    
1351    if(env->head->next->item->type != integer) {    if(CAR(CDR(env->head))->type != integer) {
1352      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1353      env->err=2;      env->err= 2;
1354      return;      return;
1355    }    }
1356        
1357    swap(env);    swap(env);
1358    if(env->err) return;    if(env->err) return;
1359        
1360    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1361    
1362    toss(env);    toss(env);
1363    if(env->err) return;    if(env->err) return;
# Line 1362  extern void ifelse(environment *env) Line 1373  extern void ifelse(environment *env)
1373  {  {
1374    int truth;    int truth;
1375    
1376    if((env->head)==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1377       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1378      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1379      env->err=1;      env->err= 1;
1380      return;      return;
1381    }    }
1382    
1383    if(env->head->next->next->item->type != integer) {    if(CAR(CDR(CDR(env->head)))->type!=integer) {
1384      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1385      env->err=2;      env->err= 2;
1386      return;      return;
1387    }    }
1388        
1389    rot(env);    rot(env);
1390    if(env->err) return;    if(env->err) return;
1391        
1392    truth=env->head->item->content.i;    truth= CAR(env->head)->content.i;
1393    
1394    toss(env);    toss(env);
1395    if(env->err) return;    if(env->err) return;
# Line 1393  extern void ifelse(environment *env) Line 1404  extern void ifelse(environment *env)
1404    eval(env);    eval(env);
1405  }  }
1406    
1407    extern void sx_656c7365(environment *env)
1408    {
1409      if(env->head==NULL || CDR(env->head)==NULL
1410         || CDR(CDR(env->head))==NULL || CDR(CDR(CDR(env->head)))==NULL
1411         || CDR(CDR(CDR(CDR(env->head))))==NULL) {
1412        printerr("Too Few Arguments");
1413        env->err= 1;
1414        return;
1415      }
1416    
1417      if(CAR(CDR(env->head))->type!=symb
1418         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1419         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1420         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1421        printerr("Bad Argument Type");
1422        env->err= 2;
1423        return;
1424      }
1425    
1426      swap(env); toss(env); rot(env); toss(env);
1427      ifelse(env);
1428    }
1429    
1430    extern void then(environment *env)
1431    {
1432      if(env->head==NULL || CDR(env->head)==NULL
1433         || CDR(CDR(env->head))==NULL) {
1434        printerr("Too Few Arguments");
1435        env->err= 1;
1436        return;
1437      }
1438    
1439      if(CAR(CDR(env->head))->type!=symb
1440         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1441        printerr("Bad Argument Type");
1442        env->err= 2;
1443        return;
1444      }
1445    
1446      swap(env); toss(env);
1447      sx_6966(env);
1448    }
1449    
1450  /* "while" */  /* "while" */
1451  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1452  {  {
1453    int truth;    int truth;
1454    value *loop, *test;    value *loop, *test;
1455    
1456    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1457      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1458      env->err=1;      env->err= 1;
1459      return;      return;
1460    }    }
1461    
1462    loop= env->head->item;    loop= CAR(env->head);
1463    protect(loop);    protect(loop);
1464    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1465    
1466    test= env->head->item;    test= CAR(env->head);
1467    protect(test);    protect(test);
1468    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1469    
# Line 1417  extern void sx_7768696c65(environment *e Line 1471  extern void sx_7768696c65(environment *e
1471      push_val(env, test);      push_val(env, test);
1472      eval(env);      eval(env);
1473            
1474      if(env->head->item->type != integer) {      if(CAR(env->head)->type != integer) {
1475        printerr("Bad Argument Type");        printerr("Bad Argument Type");
1476        env->err= 2;        env->err= 2;
1477        return;        return;
1478      }      }
1479            
1480      truth= env->head->item->content.i;      truth= CAR(env->head)->content.i;
1481      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1482            
1483      if(truth) {      if(truth) {
# Line 1445  extern void sx_666f72(environment *env) Line 1499  extern void sx_666f72(environment *env)
1499    value *loop;    value *loop;
1500    int foo1, foo2;    int foo1, foo2;
1501    
1502    if(env->head==NULL || env->head->next==NULL    if(env->head==NULL || CDR(env->head)==NULL
1503       || env->head->next->next==NULL) {       || CDR(CDR(env->head))==NULL) {
1504      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1505      env->err= 1;      env->err= 1;
1506      return;      return;
1507    }    }
1508    
1509    if(env->head->next->item->type!=integer    if(CAR(CDR(env->head))->type!=integer
1510       || env->head->next->next->item->type!=integer) {       || CAR(CDR(CDR(env->head)))->type!=integer) {
1511      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1512      env->err= 2;      env->err= 2;
1513      return;      return;
1514    }    }
1515    
1516    loop= env->head->item;    loop= CAR(env->head);
1517    protect(loop);    protect(loop);
1518    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1519    
1520    foo2= env->head->item->content.i;    foo2= CAR(env->head)->content.i;
1521    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1522    
1523    foo1= env->head->item->content.i;    foo1= CAR(env->head)->content.i;
1524    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1525    
1526    if(foo1<=foo2) {    if(foo1<=foo2) {
# Line 1491  extern void sx_666f72(environment *env) Line 1545  extern void sx_666f72(environment *env)
1545  extern void foreach(environment *env)  extern void foreach(environment *env)
1546  {    {  
1547    value *loop, *foo;    value *loop, *foo;
1548    stackitem *iterator;    value *iterator;
1549        
1550    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1551      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1552      env->err= 1;      env->err= 1;
1553      return;      return;
1554    }    }
1555    
1556    if(env->head->next->item->type != list) {    if(CAR(CDR(env->head))->type!=tcons) {
1557      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1558      env->err= 2;      env->err= 2;
1559      return;      return;
1560    }    }
1561    
1562    loop= env->head->item;    loop= CAR(env->head);
1563    protect(loop);    protect(loop);
1564    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1565    
1566    foo= env->head->item;    foo= CAR(env->head);
1567    protect(foo);    protect(foo);
1568    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1569    
1570    iterator= foo->content.ptr;    iterator= foo;
1571    
1572    while(iterator!=NULL) {    while(iterator!=NULL) {
1573      push_val(env, iterator->item);      push_val(env, CAR(iterator));
1574      push_val(env, loop);      push_val(env, loop);
1575      eval(env); if(env->err) return;      eval(env); if(env->err) return;
1576      iterator= iterator->next;      if (iterator->type == tcons){
1577          iterator= CDR(iterator);
1578        } else {
1579          printerr("Bad Argument Type"); /* Improper list */
1580          env->err= 2;
1581          break;
1582        }
1583    }    }
1584    unprotect(loop); unprotect(foo);    unprotect(loop); unprotect(foo);
1585  }  }
# Line 1528  extern void foreach(environment *env) Line 1588  extern void foreach(environment *env)
1588  extern void to(environment *env)  extern void to(environment *env)
1589  {  {
1590    int ending, start, i;    int ending, start, i;
1591    stackitem *iterator, *temp;    value *iterator, *temp;
   value *pack;  
1592    
1593    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1594      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1595      env->err=1;      env->err= 1;
1596      return;      return;
1597    }    }
1598    
1599    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1600       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1601      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1602      env->err=2;      env->err= 2;
1603      return;      return;
1604    }    }
1605    
1606    ending= env->head->item->content.i;    ending= CAR(env->head)->content.i;
1607    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1608    start= env->head->item->content.i;    start= CAR(env->head)->content.i;
1609    toss(env); if(env->err) return;    toss(env); if(env->err) return;
1610    
1611    push_sym(env, "[");    push_sym(env, "[");
# Line 1560  extern void to(environment *env) Line 1619  extern void to(environment *env)
1619    }    }
1620    
1621    iterator= env->head;    iterator= env->head;
   pack= new_val(env);  
   protect(pack);  
1622    
1623    if(iterator==NULL    if(iterator==NULL
1624       || (iterator->item->type==symb       || (CAR(iterator)->type==symb
1625       && ((symbol*)(iterator->item->content.ptr))->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1626      temp= NULL;      temp= NULL;
1627      toss(env);      toss(env);
1628    } else {    } else {
1629      /* Search for first delimiter */      /* Search for first delimiter */
1630      while(iterator->next!=NULL      while(CDR(iterator)!=NULL
1631            && (iterator->next->item->type!=symb            && (CAR(CDR(iterator))->type!=symb
1632            || ((symbol*)(iterator->next->item->content.ptr))->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1633        iterator= iterator->next;        iterator= CDR(iterator);
1634            
1635      /* Extract list */      /* Extract list */
1636      temp= env->head;      temp= env->head;
1637      env->head= iterator->next;      env->head= CDR(iterator);
1638      iterator->next= NULL;      CDR(iterator)= NULL;
1639    
     pack->type= list;  
     pack->content.ptr= temp;  
       
1640      if(env->head!=NULL)      if(env->head!=NULL)
1641        toss(env);        toss(env);
1642    }    }
1643    
1644    /* Push list */    /* Push list */
1645      push_val(env, temp);
   push_val(env, pack);  
   
   unprotect(pack);  
1646  }  }
1647    
1648  /* Read a string */  /* Read a string */
# Line 1630  extern void sx_72656164(environment *env Line 1681  extern void sx_72656164(environment *env
1681      }      }
1682      readline(env); if(env->err) return;      readline(env); if(env->err) return;
1683    
1684      if(((char *)(env->head->item->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1685        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1686        return;        return;
1687      }      }
1688            
1689      env->in_string= malloc(strlen(env->head->item->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1690      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1691      strcpy(env->in_string, env->head->item->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1692      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1693    }    }
1694        
# Line 1686  extern void sx_72656164(environment *env Line 1737  extern void sx_72656164(environment *env
1737      return sx_72656164(env);      return sx_72656164(env);
1738  }  }
1739    
1740    #ifdef __linux__
1741  extern void beep(environment *env)  extern void beep(environment *env)
1742  {  {
1743    int freq, dur, period, ticks;    int freq, dur, period, ticks;
1744    
1745    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
1746      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1747      env->err=1;      env->err= 1;
1748      return;      return;
1749    }    }
1750    
1751    if(env->head->item->type!=integer    if(CAR(env->head)->type!=integer
1752       || env->head->next->item->type!=integer) {       || CAR(CDR(env->head))->type!=integer) {
1753      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1754      env->err=2;      env->err= 2;
1755      return;      return;
1756    }    }
1757    
1758    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1759    toss(env);    toss(env);
1760    freq=env->head->item->content.i;    freq= CAR(env->head)->content.i;
1761    toss(env);    toss(env);
1762    
1763    period=1193180/freq;          /* convert freq from Hz to period    period= 1193180/freq;         /* convert freq from Hz to period
1764                                     length */                                     length */
1765    ticks=dur*.001193180;         /* convert duration from µseconds to    ticks= dur*.001193180;        /* convert duration from µseconds to
1766                                     timer ticks */                                     timer ticks */
1767    
1768  /*    ticks=dur/1000; */  /*    ticks=dur/1000; */
1769    
1770    /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */        /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */
1771    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){    switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){
1772    case 0:    case 0:
1773      usleep(dur);      usleep(dur);
1774      return;      return;
1775    case -1:    case -1:
1776      perror("beep");      perror("beep");
1777      env->err=5;      env->err= 5;
1778      return;      return;
1779    default:    default:
1780      abort();      abort();
1781    }    }
1782  }  }
1783    #endif /* __linux__ */
1784    
1785  /* "wait" */  /* "wait" */
1786  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
1787  {  {
1788    int dur;    int dur;
1789    
1790    if((env->head)==NULL) {    if(env->head==NULL) {
1791      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1792      env->err=1;      env->err= 1;
1793      return;      return;
1794    }    }
1795    
1796    if(env->head->item->type!=integer) {    if(CAR(env->head)->type!=integer) {
1797      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1798      env->err=2;      env->err= 2;
1799      return;      return;
1800    }    }
1801    
1802    dur=env->head->item->content.i;    dur= CAR(env->head)->content.i;
1803    toss(env);    toss(env);
1804    
1805    usleep(dur);    usleep(dur);
# Line 2043  extern void sx_2a(environment *env) Line 2096  extern void sx_2a(environment *env)
2096    int a, b;    int a, b;
2097    float fa, fb;    float fa, fb;
2098    
2099    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2100      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2101      env->err=1;      env->err= 1;
2102      return;      return;
2103    }    }
2104        
2105    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2106       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2107      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2108      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2109      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2110      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2111      push_int(env, b*a);      push_int(env, b*a);
2112    
2113      return;      return;
2114    }    }
2115    
2116    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2117       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2118      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2119      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2120      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2121      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2122      push_float(env, fb*fa);      push_float(env, fb*fa);
2123            
2124      return;      return;
2125    }    }
2126    
2127    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2128       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2129      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2130      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2131      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2132      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2133      push_float(env, b*fa);      push_float(env, b*fa);
2134            
2135      return;      return;
2136    }    }
2137    
2138    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2139       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2140      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2141      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2142      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2143      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2144      push_float(env, fb*a);      push_float(env, fb*a);
2145    
# Line 2094  extern void sx_2a(environment *env) Line 2147  extern void sx_2a(environment *env)
2147    }    }
2148    
2149    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2150    env->err=2;    env->err= 2;
2151  }  }
2152    
2153  /* "/" */  /* "/" */
# Line 2103  extern void sx_2f(environment *env) Line 2156  extern void sx_2f(environment *env)
2156    int a, b;    int a, b;
2157    float fa, fb;    float fa, fb;
2158    
2159    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2160      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2161      env->err=1;      env->err= 1;
2162      return;      return;
2163    }    }
2164        
2165    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2166       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2167      a=env->head->item->content.i;      a= CAR(env->head)->content.i;
2168      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2169      b=env->head->item->content.i;      b= CAR(env->head)->content.i;
2170      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2171      push_float(env, b/a);      push_float(env, b/a);
2172    
2173      return;      return;
2174    }    }
2175    
2176    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2177       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2178      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2179      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2180      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2181      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2182      push_float(env, fb/fa);      push_float(env, fb/fa);
2183            
2184      return;      return;
2185    }    }
2186    
2187    if(env->head->item->type==tfloat    if(CAR(env->head)->type==tfloat
2188       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2189      fa= env->head->item->content.f;      fa= CAR(env->head)->content.f;
2190      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2191      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2192      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2193      push_float(env, b/fa);      push_float(env, b/fa);
2194            
2195      return;      return;
2196    }    }
2197    
2198    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2199       && env->head->next->item->type==tfloat) {       && CAR(CDR(env->head))->type==tfloat) {
2200      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2201      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2202      fb= env->head->item->content.f;      fb= CAR(env->head)->content.f;
2203      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2204      push_float(env, fb/a);      push_float(env, fb/a);
2205    
# Line 2154  extern void sx_2f(environment *env) Line 2207  extern void sx_2f(environment *env)
2207    }    }
2208    
2209    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2210    env->err=2;    env->err= 2;
2211  }  }
2212    
2213  /* "mod" */  /* "mod" */
# Line 2162  extern void mod(environment *env) Line 2215  extern void mod(environment *env)
2215  {  {
2216    int a, b;    int a, b;
2217    
2218    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2219      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2220      env->err= 1;      env->err= 1;
2221      return;      return;
2222    }    }
2223        
2224    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2225       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2226      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2227      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2228      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2229      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2230      push_int(env, b%a);      push_int(env, b%a);
2231    
# Line 2180  extern void mod(environment *env) Line 2233  extern void mod(environment *env)
2233    }    }
2234    
2235    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2236    env->err=2;    env->err= 2;
2237  }  }
2238    
2239  /* "div" */  /* "div" */
# Line 2188  extern void sx_646976(environment *env) Line 2241  extern void sx_646976(environment *env)
2241  {  {
2242    int a, b;    int a, b;
2243        
2244    if((env->head)==NULL || env->head->next==NULL) {    if(env->head==NULL || CDR(env->head)==NULL) {
2245      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2246      env->err= 1;      env->err= 1;
2247      return;      return;
2248    }    }
2249    
2250    if(env->head->item->type==integer    if(CAR(env->head)->type==integer
2251       && env->head->next->item->type==integer) {       && CAR(CDR(env->head))->type==integer) {
2252      a= env->head->item->content.i;      a= CAR(env->head)->content.i;
2253      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2254      b= env->head->item->content.i;      b= CAR(env->head)->content.i;
2255      toss(env); if(env->err) return;      toss(env); if(env->err) return;
2256      push_int(env, (int)b/a);      push_int(env, (int)b/a);
2257    
Legend:
Removed from v.1.100  
changed lines
  Added in v.1.110
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26