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

Diff of /stack/stack.c

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

revision 1.105 by masse, Tue Mar 12 14:53:19 2002 UTC revision 1.124 by teddy, Sat Mar 30 02:31:24 2002 UTC
# Line 1  Line 1 
1    /* -*- coding: utf-8; -*- */
2  /*  /*
3      stack - an interactive interpreter for a stack-based language      stack - an interactive interpreter for a stack-based language
4      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn      Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
# Line 20  Line 21 
21               Teddy Hogeborn <teddy@fukt.bth.se>               Teddy Hogeborn <teddy@fukt.bth.se>
22  */  */
23    
24  #define CAR(X) X->content.c->car  #define CAR(X) ((X)->content.c->car)
25  #define CDR(X) X->content.c->cdr  #define CDR(X) ((X)->content.c->cdr)
26    
27  /* printf, sscanf, fgets, fprintf, fopen, perror */  /* printf, sscanf, fgets, fprintf, fopen, perror */
28  #include <stdio.h>  #include <stdio.h>
# Line 37  Line 38 
38  #include <unistd.h>  #include <unistd.h>
39  /* EX_NOINPUT, EX_USAGE */  /* EX_NOINPUT, EX_USAGE */
40  #include <sysexits.h>  #include <sysexits.h>
41    /* assert */
42    #include <assert.h>
43    
44    #ifdef __linux__
45  /* mtrace, muntrace */  /* mtrace, muntrace */
46  #include <mcheck.h>  #include <mcheck.h>
47  /* ioctl */  /* ioctl */
48  #include <sys/ioctl.h>  #include <sys/ioctl.h>
49  /* KDMKTONE */  /* KDMKTONE */
50  #include <linux/kd.h>  #include <linux/kd.h>
51    #endif /* __linux__ */
52    
53  #include "stack.h"  #include "stack.h"
54    
# Line 55  void init_env(environment *env) Line 61  void init_env(environment *env)
61    env->gc_count= 0;    env->gc_count= 0;
62    env->gc_ref= NULL;    env->gc_ref= NULL;
63    
64    env->head= NULL;    env->head= new_val(env);
65    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
66      env->symbols[i]= NULL;      env->symbols[i]= NULL;
67    env->err= 0;    env->err= 0;
# Line 73  void printerr(const char* in_string) Line 79  void printerr(const char* in_string)
79  /* Discard the top element of the stack. */  /* Discard the top element of the stack. */
80  extern void toss(environment *env)  extern void toss(environment *env)
81  {  {
82    if(env->head==NULL) {    if(env->head->type==empty) {
83      printerr("Too Few Arguments");      printerr("Too Few Arguments");
84      env->err= 1;      env->err= 1;
85      return;      return;
# Line 117  value* new_val(environment *env) Line 123  value* new_val(environment *env)
123    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
124    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
125    
126      assert(nval != NULL);
127      assert(nitem != NULL);
128    
129    nval->content.ptr= NULL;    nval->content.ptr= NULL;
130      nval->type= empty;
131    
132    nitem->item= nval;    nitem->item= nval;
133    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# Line 158  inline void gc_maybe(environment *env) Line 168  inline void gc_maybe(environment *env)
168  extern void gc_init(environment *env)  extern void gc_init(environment *env)
169  {  {
170    stackitem *new_head= NULL, *titem;    stackitem *new_head= NULL, *titem;
   cons *iterator;  
171    symbol *tsymb;    symbol *tsymb;
172    int i;    int i;
173    
# Line 182  extern void gc_init(environment *env) Line 191  extern void gc_init(environment *env)
191    if(env->interactive)    if(env->interactive)
192      printf(".");      printf(".");
193    
   
194    env->gc_count= 0;    env->gc_count= 0;
195    
196    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
197    
198      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
199    
200        if(env->gc_ref->item->type==string) /* Remove content */        /* Remove content */
201          switch(env->gc_ref->item->type){
202          case string:
203          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
204            break;
205          case tcons:
206            free(env->gc_ref->item->content.c);
207            break;
208          case port:
209          case empty:
210          case integer:
211          case tfloat:
212          case func:
213          case symb:
214            /* Symbol strings are freed when walking the hash table */
215          }
216    
217        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
218        titem= env->gc_ref->next;        titem= env->gc_ref->next;
219        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
220        env->gc_ref= titem;        env->gc_ref= titem;
221        continue;        continue;
222      }      }
223    #ifdef DEBUG
224        printf("Kept value (%p)", env->gc_ref->item);
225        if(env->gc_ref->item->gc.flag.mark)
226          printf(" (marked)");
227        if(env->gc_ref->item->gc.flag.protect)
228          printf(" (protected)");
229        switch(env->gc_ref->item->type){
230        case integer:
231          printf(" integer: %d", env->gc_ref->item->content.i);
232          break;
233        case func:
234          printf(" func: %p", env->gc_ref->item->content.ptr);
235          break;
236        case symb:
237          printf(" symb: %s", env->gc_ref->item->content.sym->id);
238          break;
239        case tcons:
240          printf(" tcons: %p\t%p", env->gc_ref->item->content.c->car,
241                 env->gc_ref->item->content.c->cdr);
242          break;
243        default:
244          printf(" <unknown %d>", (env->gc_ref->item->type));
245        }
246        printf("\n");
247    #endif /* DEBUG */
248    
249      /* Keep values */          /* Keep values */    
250      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
251      if(env->gc_ref->item->type==string)      if(env->gc_ref->item->type==string)
252        env->gc_count += strlen(env->gc_ref->item->content.ptr);        env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
253            
254      titem= env->gc_ref->next;      titem= env->gc_ref->next;
255      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
# Line 217  extern void gc_init(environment *env) Line 264  extern void gc_init(environment *env)
264    env->gc_ref= new_head;    env->gc_ref= new_head;
265    
266    if(env->interactive)    if(env->interactive)
267      printf("done\n");      printf("done (%d bytes still allocated)\n", env->gc_count);
268    
269  }  }
270    
# Line 254  void push_val(environment *env, value *v Line 301  void push_val(environment *env, value *v
301  {  {
302    value *new_value= new_val(env);    value *new_value= new_val(env);
303    
304    new_value->content.c= malloc(sizeof(cons));    new_value->content.c= malloc(sizeof(pair));
305      assert(new_value->content.c!=NULL);
306      env->gc_count += sizeof(pair);
307    new_value->type= tcons;    new_value->type= tcons;
308    CAR(new_value)= val;    CAR(new_value)= val;
309    CDR(new_value)= env->head;    CDR(new_value)= env->head;
# Line 290  void push_cstring(environment *env, cons Line 339  void push_cstring(environment *env, cons
339    int length= strlen(in_string)+1;    int length= strlen(in_string)+1;
340    
341    new_value->content.ptr= malloc(length);    new_value->content.ptr= malloc(length);
342      assert(new_value != NULL);
343    env->gc_count += length;    env->gc_count += length;
344    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
345    new_value->type= string;    new_value->type= string;
# Line 304  char *mangle_str(const char *old_string) Line 354  char *mangle_str(const char *old_string)
354    char *new_string, *current;    char *new_string, *current;
355    
356    new_string= malloc((strlen(old_string)*2)+4);    new_string= malloc((strlen(old_string)*2)+4);
357      assert(new_string != NULL);
358    strcpy(new_string, "sx_");    /* Stack eXternal */    strcpy(new_string, "sx_");    /* Stack eXternal */
359    current= new_string+3;    current= new_string+3;
360    while(old_string[0] != '\0'){    while(old_string[0] != '\0'){
# Line 321  extern void mangle(environment *env) Line 372  extern void mangle(environment *env)
372  {  {
373    char *new_string;    char *new_string;
374    
375    if(env->head==NULL) {    if(env->head->type==empty) {
376      printerr("Too Few Arguments");      printerr("Too Few Arguments");
377      env->err= 1;      env->err= 1;
378      return;      return;
# Line 373  void push_sym(environment *env, const ch Line 424  void push_sym(environment *env, const ch
424    
425      /* Create a new symbol */      /* Create a new symbol */
426      (*new_symbol)= malloc(sizeof(symbol));      (*new_symbol)= malloc(sizeof(symbol));
427        assert((*new_symbol) != NULL);
428      (*new_symbol)->val= NULL;   /* undefined value */      (*new_symbol)->val= NULL;   /* undefined value */
429      (*new_symbol)->next= NULL;      (*new_symbol)->next= NULL;
430      (*new_symbol)->id= malloc(strlen(in_string)+1);      (*new_symbol)->id= malloc(strlen(in_string)+1);
431        assert((*new_symbol)->id != NULL);
432      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
433    
434      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
# Line 410  void push_sym(environment *env, const ch Line 463  void push_sym(environment *env, const ch
463  }  }
464    
465  /* Print newline. */  /* Print newline. */
466  extern void nl()  extern void nl(environment *env)
467  {  {
468    printf("\n");    printf("\n");
469  }  }
470    
471    /* Print a newline to a port */
472    extern void nlport(environment *env)
473    {
474      if(env->head->type==empty) {
475        printerr("Too Few Arguments");
476        env->err= 1;
477        return;
478      }
479    
480      if(CAR(env->head)->type!=port) {
481        printerr("Bad Argument Type");
482        env->err= 2;
483        return;
484      }
485    
486      if(fprintf(CAR(env->head)->content.p, "\n") < 0){
487        perror("nl");
488        env->err= 5;
489        return;
490      }
491      toss(env);
492    }
493    
494  /* Gets the type of a value */  /* Gets the type of a value */
495  extern void type(environment *env)  extern void type(environment *env)
496  {  {
497    int typenum;    if(env->head->type==empty) {
   
   if(env->head==NULL) {  
498      printerr("Too Few Arguments");      printerr("Too Few Arguments");
499      env->err= 1;      env->err= 1;
500      return;      return;
501    }    }
502    
503    typenum= CAR(env->head)->type;    switch(CAR(env->head)->type){
504    toss(env);    case empty:
505    switch(typenum){      push_sym(env, "empty");
506        break;
507    case integer:    case integer:
508      push_sym(env, "integer");      push_sym(env, "integer");
509      break;      break;
# Line 445  extern void type(environment *env) Line 520  extern void type(environment *env)
520      push_sym(env, "function");      push_sym(env, "function");
521      break;      break;
522    case tcons:    case tcons:
523      push_sym(env, "list");      push_sym(env, "pair");
524        break;
525      case port:
526        push_sym(env, "port");
527      break;      break;
528    }    }
529  }        swap(env);
530      if (env->err) return;
531      toss(env);
532    }
533    
534  /* Prints the top element of the stack. */  /* Print a value */
535  void print_h(value *stack_head, int noquote)  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
536  {  {
537    switch(CAR(stack_head)->type) {    stackitem *titem, *tstack;
538      int depth;
539    
540      switch(val->type) {
541      case empty:
542        if(fprintf(stream, "[]") < 0){
543          perror("print_val");
544          env->err= 5;
545          return;
546        }
547        break;
548    case integer:    case integer:
549      printf("%d", CAR(stack_head)->content.i);      if(fprintf(stream, "%d", val->content.i) < 0){
550          perror("print_val");
551          env->err= 5;
552          return;
553        }
554      break;      break;
555    case tfloat:    case tfloat:
556      printf("%f", CAR(stack_head)->content.f);      if(fprintf(stream, "%f", val->content.f) < 0){
557          perror("print_val");
558          env->err= 5;
559          return;
560        }
561      break;      break;
562    case string:    case string:
563      if(noquote)      if(noquote){
564        printf("%s", (char*)CAR(stack_head)->content.ptr);        if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){
565      else          perror("print_val");
566        printf("\"%s\"", (char*)CAR(stack_head)->content.ptr);          env->err= 5;
567            return;
568          }
569        } else {                    /* quote */
570          if(fprintf(stream, "\"%s\"", (char*)(val->content.ptr)) < 0){
571            perror("print_val");
572            env->err= 5;
573            return;
574          }
575        }
576      break;      break;
577    case symb:    case symb:
578      printf("%s", CAR(stack_head)->content.sym->id);      if(fprintf(stream, "%s", val->content.sym->id) < 0){
579          perror("print_val");
580          env->err= 5;
581          return;
582        }
583      break;      break;
584    case func:    case func:
585      printf("#<function %p>", (funcp)(CAR(stack_head)->content.ptr));      if(fprintf(stream, "#<function %p>", (funcp)(val->content.ptr)) < 0){
586          perror("print_val");
587          env->err= 5;
588          return;
589        }
590        break;
591      case port:
592        if(fprintf(stream, "#<port %p>", (funcp)(val->content.p)) < 0){
593          perror("print_val");
594          env->err= 5;
595          return;
596        }
597      break;      break;
598    case tcons:    case tcons:
599      /* A list is just a stack, so make stack_head point to it */      if(fprintf(stream, "[ ") < 0){
600      stack_head= CAR(stack_head);        perror("print_val");
601      printf("[ ");        env->err= 5;
602      while(stack_head != NULL) {        return;
603        print_h(stack_head, noquote);      }
604        printf(" ");      tstack= stack;
605        stack_head= CDR(stack_head);      do {
606          titem=malloc(sizeof(stackitem));
607          assert(titem != NULL);
608          titem->item=val;
609          titem->next=tstack;
610          tstack=titem;             /* Put it on the stack */
611          /* Search a stack of values being printed to see if we are already
612             printing this value */
613          titem=tstack;
614          depth=0;
615          while(titem != NULL && titem->item != CAR(val)){
616            titem=titem->next;
617            depth++;
618          }
619          if(titem != NULL){        /* If we found it on the stack, */
620            if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
621              perror("print_val");
622              env->err= 5;
623              free(titem);
624              return;
625            }
626          } else {
627            print_val(env, CAR(val), noquote, tstack, stream);
628          }
629          val= CDR(val);
630          switch(val->type){
631          case empty:
632            break;
633          case tcons:
634            /* Search a stack of values being printed to see if we are already
635               printing this value */
636            titem=tstack;
637            depth=0;
638            while(titem != NULL && titem->item != val){
639              titem=titem->next;
640              depth++;
641            }
642            if(titem != NULL){      /* If we found it on the stack, */
643              if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
644                perror("print_val");
645                env->err= 5;
646                goto printval_end;
647              }
648            } else {
649              if(fprintf(stream, " ") < 0){
650                perror("print_val");
651                env->err= 5;
652                goto printval_end;
653              }
654            }
655            break;
656          default:
657            if(fprintf(stream, " . ") < 0){ /* Improper list */
658              perror("print_val");
659              env->err= 5;
660              goto printval_end;
661            }
662            print_val(env, val, noquote, tstack, stream);
663          }
664        } while(val->type == tcons && titem == NULL);
665    
666      printval_end:
667    
668        titem=tstack;
669        while(titem != stack){
670          tstack=titem->next;
671          free(titem);
672          titem=tstack;
673        }
674    
675        if(! (env->err)){
676          if(fprintf(stream, " ]") < 0){
677            perror("print_val");
678            env->err= 5;
679          }
680      }      }
     printf("]");  
681      break;      break;
682    }    }
683  }  }
684    
685    /* Print the top element of the stack but don't discard it */
686  extern void print_(environment *env)  extern void print_(environment *env)
687  {  {
688    if(env->head==NULL) {    if(env->head->type==empty) {
689      printerr("Too Few Arguments");      printerr("Too Few Arguments");
690      env->err= 1;      env->err= 1;
691      return;      return;
692    }    }
693    print_h(env->head, 0);    print_val(env, CAR(env->head), 0, NULL, stdout);
694    nl();    if(env->err) return;
695      nl(env);
696  }  }
697    
698  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack */
699  extern void print(environment *env)  extern void print(environment *env)
700  {  {
701    print_(env);    print_(env);
# Line 505  extern void print(environment *env) Line 703  extern void print(environment *env)
703    toss(env);    toss(env);
704  }  }
705    
706    /* Print the top element of the stack without quotes, but don't
707       discard it. */
708  extern void princ_(environment *env)  extern void princ_(environment *env)
709  {  {
710    if(env->head==NULL) {    if(env->head->type==empty) {
711      printerr("Too Few Arguments");      printerr("Too Few Arguments");
712      env->err= 1;      env->err= 1;
713      return;      return;
714    }    }
715    print_h(env->head, 1);    print_val(env, CAR(env->head), 1, NULL, stdout);
716  }  }
717    
718  /* Prints the top element of the stack and then discards it. */  /* Prints the top element of the stack without quotes. */
719  extern void princ(environment *env)  extern void princ(environment *env)
720  {  {
721    princ_(env);    princ_(env);
# Line 523  extern void princ(environment *env) Line 723  extern void princ(environment *env)
723    toss(env);    toss(env);
724  }  }
725    
726  /* Only to be called by function printstack. */  /* Print a value to a port, but don't discard it */
727  void print_st(value *stack_head, long counter)  extern void printport_(environment *env)
728    {
729      if(env->head->type==empty ||  CDR(env->head)->type == empty) {
730        printerr("Too Few Arguments");
731        env->err= 1;
732        return;
733      }
734    
735      if(CAR(env->head)->type!=port) {
736        printerr("Bad Argument Type");
737        env->err= 2;
738        return;
739      }
740    
741      print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);
742      if(env->err) return;
743      nlport(env);
744    }
745    
746    /* Print a value to a port */
747    extern void printport(environment *env)
748    {
749      printport_(env);
750      if(env->err) return;
751      toss(env);
752    }
753    
754    /* Print, without quotes, to a port, a value, but don't discard it. */
755    extern void princport_(environment *env)
756    {
757      if(env->head->type==empty ||  CDR(env->head)->type == empty) {
758        printerr("Too Few Arguments");
759        env->err= 1;
760        return;
761      }
762    
763      if(CAR(env->head)->type!=port) {
764        printerr("Bad Argument Type");
765        env->err= 2;
766        return;
767      }
768    
769      print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);
770      toss(env); if(env->err) return;
771    }
772    
773    /* Print, without quotes, to a port, the top element. */
774    extern void princport(environment *env)
775    {
776      princport_(env);
777      if(env->err) return;
778      toss(env);
779    }
780    
781    /* Only to be called by itself function printstack. */
782    void print_st(environment *env, value *stack_head, long counter)
783  {  {
784    if(CDR(stack_head) != NULL)    if(CDR(stack_head)->type != empty)
785      print_st(CDR(stack_head), counter+1);      print_st(env, CDR(stack_head), counter+1);
786    printf("%ld: ", counter);    printf("%ld: ", counter);
787    print_h(stack_head, 0);    print_val(env, CAR(stack_head), 0, NULL, stdout);
788    nl();    nl(env);
789  }  }
790    
791  /* Prints the stack. */  /* Prints the stack. */
792  extern void printstack(environment *env)  extern void printstack(environment *env)
793  {  {
794    if(env->head == NULL) {    if(env->head->type == empty) {
795      printf("Stack Empty\n");      printf("Stack Empty\n");
796      return;      return;
797    }    }
798    
799    print_st(env->head, 1);    print_st(env, env->head, 1);
800  }  }
801    
802  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
# Line 549  extern void swap(environment *env) Line 804  extern void swap(environment *env)
804  {  {
805    value *temp= env->head;    value *temp= env->head;
806        
807    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
808      printerr("Too Few Arguments");      printerr("Too Few Arguments");
809      env->err=1;      env->err=1;
810      return;      return;
# Line 565  extern void rot(environment *env) Line 820  extern void rot(environment *env)
820  {  {
821    value *temp= env->head;    value *temp= env->head;
822        
823    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type == empty || CDR(env->head)->type == empty
824       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type == empty) {
825      printerr("Too Few Arguments");      printerr("Too Few Arguments");
826      env->err= 1;      env->err= 1;
827      return;      return;
# Line 582  extern void rcl(environment *env) Line 837  extern void rcl(environment *env)
837  {  {
838    value *val;    value *val;
839    
840    if(env->head==NULL) {    if(env->head->type==empty) {
841      printerr("Too Few Arguments");      printerr("Too Few Arguments");
842      env->err= 1;      env->err= 1;
843      return;      return;
# Line 600  extern void rcl(environment *env) Line 855  extern void rcl(environment *env)
855      env->err= 3;      env->err= 3;
856      return;      return;
857    }    }
858    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
859    toss(env);            /* toss the symbol */    swap(env);
860      if(env->err) return;
861      toss(env);                    /* toss the symbol */
862    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
863  }  }
864    
865  /* 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 620  extern void eval(environment *env) Line 875  extern void eval(environment *env)
875    
876    gc_maybe(env);    gc_maybe(env);
877    
878    if(env->head==NULL) {    if(env->head->type==empty) {
879      printerr("Too Few Arguments");      printerr("Too Few Arguments");
880      env->err= 1;      env->err= 1;
881      return;      return;
# Line 651  extern void eval(environment *env) Line 906  extern void eval(environment *env)
906      toss(env); if(env->err) return;      toss(env); if(env->err) return;
907      iterator= temp_val;      iterator= temp_val;
908            
909      while(iterator!=NULL) {      while(iterator->type != empty) {
910        push_val(env, CAR(iterator));        push_val(env, CAR(iterator));
911                
912        if(CAR(env->head)->type==symb        if(CAR(env->head)->type==symb
# Line 659  extern void eval(environment *env) Line 914  extern void eval(environment *env)
914          toss(env);          toss(env);
915          if(env->err) return;          if(env->err) return;
916                    
917          if(CDR(iterator)==NULL){          if(CDR(iterator)->type == empty){
918            goto eval_start;            goto eval_start;
919          }          }
920          eval(env);          eval(env);
921          if(env->err) return;          if(env->err) return;
922        }        }
923        if (CDR(iterator)->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
924          iterator= CDR(iterator);          iterator= CDR(iterator);
925        else {        else {
926          printerr("Bad Argument Type"); /* Improper list */          printerr("Bad Argument Type"); /* Improper list */
# Line 676  extern void eval(environment *env) Line 931  extern void eval(environment *env)
931      unprotect(temp_val);      unprotect(temp_val);
932      return;      return;
933    
934    default:    case empty:
935        toss(env);
936      case integer:
937      case tfloat:
938      case string:
939      case port:
940      return;      return;
941    }    }
942  }  }
# Line 686  extern void rev(environment *env) Line 946  extern void rev(environment *env)
946  {  {
947    value *old_head, *new_head, *item;    value *old_head, *new_head, *item;
948    
949    if(env->head==NULL) {    if(env->head->type==empty) {
950      printerr("Too Few Arguments");      printerr("Too Few Arguments");
951      env->err= 1;      env->err= 1;
952      return;      return;
953    }    }
954    
955      if(CAR(env->head)->type==empty)
956        return;                     /* Don't reverse an empty list */
957    
958    if(CAR(env->head)->type!=tcons) {    if(CAR(env->head)->type!=tcons) {
959      printerr("Bad Argument Type");      printerr("Bad Argument Type");
960      env->err= 2;      env->err= 2;
# Line 699  extern void rev(environment *env) Line 962  extern void rev(environment *env)
962    }    }
963    
964    old_head= CAR(env->head);    old_head= CAR(env->head);
965    new_head= NULL;    new_head= new_val(env);
966    while(old_head!=NULL) {    while(old_head->type != empty) {
967      item= old_head;      item= old_head;
968      old_head= CDR(old_head);      old_head= CDR(old_head);
969      CDR(item)= new_head;      CDR(item)= new_head;
# Line 712  extern void rev(environment *env) Line 975  extern void rev(environment *env)
975  /* Make a list. */  /* Make a list. */
976  extern void pack(environment *env)  extern void pack(environment *env)
977  {  {
978    value *iterator, *temp;    value *iterator, *temp, *ending;
979    
980      ending=new_val(env);
981    
982    iterator= env->head;    iterator= env->head;
983    if(iterator==NULL    if(iterator->type == empty
984       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
985       && CAR(iterator)->content.sym->id[0]=='[')) {       && CAR(iterator)->content.sym->id[0]=='[')) {
986      temp= NULL;      temp= ending;
987      toss(env);      toss(env);
988    } else {    } else {
989      /* Search for first delimiter */      /* Search for first delimiter */
990      while(CDR(iterator)!=NULL      while(CDR(iterator)->type != empty
991            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
992             || CAR(CDR(iterator))->content.sym->id[0]!='['))             || CAR(CDR(iterator))->content.sym->id[0]!='['))
993        iterator= CDR(iterator);        iterator= CDR(iterator);
# Line 730  extern void pack(environment *env) Line 995  extern void pack(environment *env)
995      /* Extract list */      /* Extract list */
996      temp= env->head;      temp= env->head;
997      env->head= CDR(iterator);      env->head= CDR(iterator);
998      CDR(iterator)= NULL;      CDR(iterator)= ending;
999    
1000      if(env->head!=NULL)      if(env->head->type != empty)
1001        toss(env);        toss(env);
1002    }    }
1003    
# Line 748  extern void expand(environment *env) Line 1013  extern void expand(environment *env)
1013    value *temp, *new_head;    value *temp, *new_head;
1014    
1015    /* Is top element a list? */    /* Is top element a list? */
1016    if(env->head==NULL) {    if(env->head->type==empty) {
1017      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1018      env->err= 1;      env->err= 1;
1019      return;      return;
# Line 771  extern void expand(environment *env) Line 1036  extern void expand(environment *env)
1036    toss(env);    toss(env);
1037    
1038    /* Find the end of the list */    /* Find the end of the list */
1039    while(CDR(temp)->content.ptr != NULL) {    while(CDR(temp)->type != empty) {
1040      if (CDR(temp)->type == tcons)      if (CDR(temp)->type == tcons)
1041        temp= CDR(temp);        temp= CDR(temp);
1042      else {      else {
# Line 792  extern void eq(environment *env) Line 1057  extern void eq(environment *env)
1057  {  {
1058    void *left, *right;    void *left, *right;
1059    
1060    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1061      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1062      env->err= 1;      env->err= 1;
1063      return;      return;
# Line 810  extern void not(environment *env) Line 1075  extern void not(environment *env)
1075  {  {
1076    int val;    int val;
1077    
1078    if(env->head==NULL) {    if(env->head->type==empty) {
1079      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1080      env->err= 1;      env->err= 1;
1081      return;      return;
# Line 841  extern void def(environment *env) Line 1106  extern void def(environment *env)
1106    symbol *sym;    symbol *sym;
1107    
1108    /* 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 */
1109    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1110      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1111      env->err= 1;      env->err= 1;
1112      return;      return;
# Line 880  extern void quit(environment *env) Line 1145  extern void quit(environment *env)
1145    env->gc_limit= 0;    env->gc_limit= 0;
1146    gc_maybe(env);    gc_maybe(env);
1147    
1148      words(env);
1149    
1150    if(env->free_string!=NULL)    if(env->free_string!=NULL)
1151      free(env->free_string);      free(env->free_string);
1152        
1153    #ifdef __linux__
1154    muntrace();    muntrace();
1155    #endif
1156    
1157    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
1158  }  }
# Line 891  extern void quit(environment *env) Line 1160  extern void quit(environment *env)
1160  /* Clear stack */  /* Clear stack */
1161  extern void clear(environment *env)  extern void clear(environment *env)
1162  {  {
1163    while(env->head!=NULL)    while(env->head->type != empty)
1164      toss(env);      toss(env);
1165  }  }
1166    
# Line 904  extern void words(environment *env) Line 1173  extern void words(environment *env)
1173    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
1174      temp= env->symbols[i];      temp= env->symbols[i];
1175      while(temp!=NULL) {      while(temp!=NULL) {
1176    #ifdef DEBUG
1177          if (temp->val != NULL && temp->val->gc.flag.protect)
1178            printf("(protected) ");
1179    #endif /* DEBUG */
1180        printf("%s\n", temp->id);        printf("%s\n", temp->id);
1181        temp= temp->next;        temp= temp->next;
1182      }      }
# Line 926  void forget_sym(symbol **hash_entry) Line 1199  void forget_sym(symbol **hash_entry)
1199  extern void forget(environment *env)  extern void forget(environment *env)
1200  {  {
1201    char* sym_id;    char* sym_id;
   value *stack_head= env->head;  
1202    
1203    if(stack_head==NULL) {    if(env->head->type==empty) {
1204      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1205      env->err= 1;      env->err= 1;
1206      return;      return;
1207    }    }
1208        
1209    if(CAR(stack_head)->type!=symb) {    if(CAR(env->head)->type!=symb) {
1210      printerr("Bad Argument Type");      printerr("Bad Argument Type");
1211      env->err= 2;      env->err= 2;
1212      return;      return;
1213    }    }
1214    
1215    sym_id= CAR(stack_head)->content.sym->id;    sym_id= CAR(env->head)->content.sym->id;
1216    toss(env);    toss(env);
1217    
1218    return forget_sym(hash(env->symbols, sym_id));    return forget_sym(hash(env->symbols, sym_id));
# Line 958  int main(int argc, char **argv) Line 1230  int main(int argc, char **argv)
1230    
1231    int c;                        /* getopt option character */    int c;                        /* getopt option character */
1232    
1233    #ifdef __linux__
1234    mtrace();    mtrace();
1235    #endif
1236    
1237    init_env(&myenv);    init_env(&myenv);
1238    
# Line 972  int main(int argc, char **argv) Line 1246  int main(int argc, char **argv)
1246          break;          break;
1247        case '?':        case '?':
1248          fprintf (stderr,          fprintf (stderr,
1249                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
1250                   optopt);                   optopt);
1251          return EX_USAGE;          return EX_USAGE;
1252        default:        default:
# Line 991  int main(int argc, char **argv) Line 1265  int main(int argc, char **argv)
1265    if(myenv.interactive) {    if(myenv.interactive) {
1266      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
1267  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
1268  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
1269  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
1270  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
1271    }    }
1272    
1273    while(1) {    while(1) {
# Line 1001  under certain conditions; type `copying; Line 1275  under certain conditions; type `copying;
1275        if (myenv.interactive) {        if (myenv.interactive) {
1276          if(myenv.err) {          if(myenv.err) {
1277            printf("(error %d)\n", myenv.err);            printf("(error %d)\n", myenv.err);
1278              myenv.err= 0;
1279          }          }
1280          nl();          nl(&myenv);
1281          printstack(&myenv);          printstack(&myenv);
1282          printf("> ");          printf("> ");
1283        }        }
1284        myenv.err=0;        myenv.err=0;
1285      }      }
1286      sx_72656164(&myenv);      sx_72656164(&myenv);        /* "read" */
1287      if (myenv.err==4) {      if (myenv.err==4) {         /* EOF */
1288        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
1289      } else if(myenv.head!=NULL        quit(&myenv);
1290        } else if(myenv.head->type!=empty
1291                && CAR(myenv.head)->type==symb                && CAR(myenv.head)->type==symb
1292                && CAR(myenv.head)->content.sym->id[0]                && CAR(myenv.head)->content.sym->id[0] == ';') {
               ==';') {  
1293        toss(&myenv);             /* No error check in main */        toss(&myenv);             /* No error check in main */
1294        eval(&myenv);        eval(&myenv);
1295      }      }
# Line 1033  extern void sx_2b(environment *env) Line 1308  extern void sx_2b(environment *env)
1308    char* new_string;    char* new_string;
1309    value *a_val, *b_val;    value *a_val, *b_val;
1310    
1311    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1312      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1313      env->err= 1;      env->err= 1;
1314      return;      return;
# Line 1048  extern void sx_2b(environment *env) Line 1323  extern void sx_2b(environment *env)
1323      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1324      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
1325      new_string= malloc(len);      new_string= malloc(len);
1326        assert(new_string != NULL);
1327      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1328      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1329      push_cstring(env, new_string);      push_cstring(env, new_string);
# Line 1111  extern void sx_2d(environment *env) Line 1387  extern void sx_2d(environment *env)
1387    int a, b;    int a, b;
1388    float fa, fb;    float fa, fb;
1389    
1390    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1391      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1392      env->err=1;      env->err=1;
1393      return;      return;
# Line 1171  extern void sx_3e(environment *env) Line 1447  extern void sx_3e(environment *env)
1447    int a, b;    int a, b;
1448    float fa, fb;    float fa, fb;
1449    
1450    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1451      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1452      env->err= 1;      env->err= 1;
1453      return;      return;
# Line 1254  value *copy_val(environment *env, value Line 1530  value *copy_val(environment *env, value
1530    if(old_value==NULL)    if(old_value==NULL)
1531      return NULL;      return NULL;
1532    
   protect(old_value);  
1533    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
1534    new_value->type= old_value->type;    new_value->type= old_value->type;
1535    
1536    switch(old_value->type){    switch(old_value->type){
# Line 1264  value *copy_val(environment *env, value Line 1538  value *copy_val(environment *env, value
1538    case integer:    case integer:
1539    case func:    case func:
1540    case symb:    case symb:
1541      case empty:
1542      case port:
1543      new_value->content= old_value->content;      new_value->content= old_value->content;
1544      break;      break;
1545    case string:    case string:
# Line 1271  value *copy_val(environment *env, value Line 1547  value *copy_val(environment *env, value
1547        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
1548      break;      break;
1549    case tcons:    case tcons:
     new_value= NULL;  
1550    
1551      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
1552        assert(new_value->content.c!=NULL);
1553        env->gc_count += sizeof(pair);
1554    
1555      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1556      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
1557      break;      break;
1558    }    }
1559    
   unprotect(old_value); unprotect(new_value);  
   
1560    return new_value;    return new_value;
1561  }  }
1562    
1563  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
1564  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
1565  {  {
1566    if(env->head==NULL) {    if(env->head->type==empty) {
1567      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1568      env->err= 1;      env->err= 1;
1569      return;      return;
# Line 1300  extern void sx_6966(environment *env) Line 1576  extern void sx_6966(environment *env)
1576  {  {
1577    int truth;    int truth;
1578    
1579    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1580      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1581      env->err= 1;      env->err= 1;
1582      return;      return;
# Line 1331  extern void ifelse(environment *env) Line 1607  extern void ifelse(environment *env)
1607  {  {
1608    int truth;    int truth;
1609    
1610    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1611       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1612      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1613      env->err= 1;      env->err= 1;
1614      return;      return;
# Line 1362  extern void ifelse(environment *env) Line 1638  extern void ifelse(environment *env)
1638    eval(env);    eval(env);
1639  }  }
1640    
1641    /* "else" */
1642    extern void sx_656c7365(environment *env)
1643    {
1644      if(env->head->type==empty || CDR(env->head)->type==empty
1645         || CDR(CDR(env->head))->type==empty || CDR(CDR(CDR(env->head)))->type==empty
1646         || CDR(CDR(CDR(CDR(env->head))))->type==empty) {
1647        printerr("Too Few Arguments");
1648        env->err= 1;
1649        return;
1650      }
1651    
1652      if(CAR(CDR(env->head))->type!=symb
1653         || strcmp(CAR(CDR(env->head))->content.sym->id, "then")!=0
1654         || CAR(CDR(CDR(CDR(env->head))))->type!=symb
1655         || strcmp(CAR(CDR(CDR(CDR(env->head))))->content.sym->id, "if")!=0) {
1656        printerr("Bad Argument Type");
1657        env->err= 2;
1658        return;
1659      }
1660    
1661      swap(env); toss(env); rot(env); toss(env);
1662      ifelse(env);
1663    }
1664    
1665    extern void then(environment *env)
1666    {
1667      if(env->head->type==empty || CDR(env->head)->type==empty
1668         || CDR(CDR(env->head))->type==empty) {
1669        printerr("Too Few Arguments");
1670        env->err= 1;
1671        return;
1672      }
1673    
1674      if(CAR(CDR(env->head))->type!=symb
1675         || strcmp(CAR(CDR(env->head))->content.sym->id, "if")!=0) {
1676        printerr("Bad Argument Type");
1677        env->err= 2;
1678        return;
1679      }
1680    
1681      swap(env); toss(env);
1682      sx_6966(env);
1683    }
1684    
1685  /* "while" */  /* "while" */
1686  extern void sx_7768696c65(environment *env)  extern void sx_7768696c65(environment *env)
1687  {  {
1688    int truth;    int truth;
1689    value *loop, *test;    value *loop, *test;
1690    
1691    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1692      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1693      env->err= 1;      env->err= 1;
1694      return;      return;
# Line 1414  extern void sx_666f72(environment *env) Line 1734  extern void sx_666f72(environment *env)
1734    value *loop;    value *loop;
1735    int foo1, foo2;    int foo1, foo2;
1736    
1737    if(env->head==NULL || CDR(env->head)==NULL    if(env->head->type==empty || CDR(env->head)->type==empty
1738       || CDR(CDR(env->head))==NULL) {       || CDR(CDR(env->head))->type==empty) {
1739      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1740      env->err= 1;      env->err= 1;
1741      return;      return;
# Line 1462  extern void foreach(environment *env) Line 1782  extern void foreach(environment *env)
1782    value *loop, *foo;    value *loop, *foo;
1783    value *iterator;    value *iterator;
1784        
1785    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1786      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1787      env->err= 1;      env->err= 1;
1788      return;      return;
# Line 1484  extern void foreach(environment *env) Line 1804  extern void foreach(environment *env)
1804    
1805    iterator= foo;    iterator= foo;
1806    
1807    while(iterator!=NULL) {    while(iterator->type!=empty) {
1808      push_val(env, CAR(iterator));      push_val(env, CAR(iterator));
1809      push_val(env, loop);      push_val(env, loop);
1810      eval(env); if(env->err) return;      eval(env); if(env->err) return;
# Line 1503  extern void foreach(environment *env) Line 1823  extern void foreach(environment *env)
1823  extern void to(environment *env)  extern void to(environment *env)
1824  {  {
1825    int ending, start, i;    int ending, start, i;
1826    value *iterator, *temp;    value *iterator, *temp, *end;
1827    
1828    if(env->head==NULL || CDR(env->head)==NULL) {    end= new_val(env);
1829    
1830      if(env->head->type==empty || CDR(env->head)->type==empty) {
1831      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1832      env->err= 1;      env->err= 1;
1833      return;      return;
# Line 1535  extern void to(environment *env) Line 1857  extern void to(environment *env)
1857    
1858    iterator= env->head;    iterator= env->head;
1859    
1860    if(iterator==NULL    if(iterator->type==empty
1861       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
1862           && CAR(iterator)->content.sym->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1863      temp= NULL;      temp= end;
1864      toss(env);      toss(env);
1865    } else {    } else {
1866      /* Search for first delimiter */      /* Search for first delimiter */
1867      while(CDR(iterator)!=NULL      while(CDR(iterator)->type!=empty
1868            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
1869                || CAR(CDR(iterator))->content.sym->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1870        iterator= CDR(iterator);        iterator= CDR(iterator);
# Line 1550  extern void to(environment *env) Line 1872  extern void to(environment *env)
1872      /* Extract list */      /* Extract list */
1873      temp= env->head;      temp= env->head;
1874      env->head= CDR(iterator);      env->head= CDR(iterator);
1875      CDR(iterator)= NULL;      CDR(iterator)= end;
1876    
1877      if(env->head!=NULL)      if(env->head->type!=empty)
1878        toss(env);        toss(env);
1879    }    }
1880    
# Line 1563  extern void to(environment *env) Line 1885  extern void to(environment *env)
1885  /* Read a string */  /* Read a string */
1886  extern void readline(environment *env)  extern void readline(environment *env)
1887  {  {
1888      readlinestream(env, env->inputstream);
1889    }
1890    
1891    /* Read a string from a port */
1892    extern void readlineport(environment *env)
1893    {
1894      FILE *stream;
1895    
1896      if(env->head->type==empty) {
1897        printerr("Too Few Arguments");
1898        env->err= 1;
1899        return;
1900      }
1901    
1902      if(CAR(env->head)->type!=port) {
1903        printerr("Bad Argument Type");
1904        env->err= 2;
1905        return;
1906      }
1907    
1908      stream=CAR(env->head)->content.p;
1909      readlinestream(env, stream); if(env->err) return;
1910    
1911      swap(env); if(env->err) return;
1912      toss(env);
1913    }
1914    
1915    /* read a line from a stream; used by readline */
1916    void readlinestream(environment *env, FILE *stream)
1917    {
1918    char in_string[101];    char in_string[101];
1919    
1920    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, stream)==NULL) {
1921      push_cstring(env, "");      push_cstring(env, "");
1922    else      if (! feof(stream)){
1923          perror("readline");
1924          env->err= 5;
1925        }
1926      } else {
1927      push_cstring(env, in_string);      push_cstring(env, in_string);
1928      }
1929  }  }
1930    
1931  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1932  extern void sx_72656164(environment *env)  extern void sx_72656164(environment *env)
1933  {  {
1934      readstream(env, env->inputstream);
1935    }
1936    
1937    /* "readport"; Read a value from a port and place on stack */
1938    extern void readport(environment *env)
1939    {
1940      FILE *stream;
1941    
1942      if(env->head->type==empty) {
1943        printerr("Too Few Arguments");
1944        env->err= 1;
1945        return;
1946      }
1947    
1948      if(CAR(env->head)->type!=port) {
1949        printerr("Bad Argument Type");
1950        env->err= 2;
1951        return;
1952      }
1953    
1954      stream=CAR(env->head)->content.p;
1955      readstream(env, stream); if(env->err) return;
1956    
1957      swap(env); if(env->err) return;
1958      toss(env);
1959    }
1960    
1961    /* read from a stream; used by "read" and "readport" */
1962    void readstream(environment *env, FILE *stream)
1963    {
1964    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1965    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1966    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1587  extern void sx_72656164(environment *env Line 1974  extern void sx_72656164(environment *env
1974    int count= -1;    int count= -1;
1975    float ftemp;    float ftemp;
1976    static int depth= 0;    static int depth= 0;
1977    char *match, *ctemp;    char *match;
1978    size_t inlength;    size_t inlength;
1979    
1980    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1602  extern void sx_72656164(environment *env Line 1989  extern void sx_72656164(environment *env
1989      }      }
1990            
1991      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1992        assert(env->in_string != NULL);
1993      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1994      strcpy(env->in_string, CAR(env->head)->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1995      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1609  extern void sx_72656164(environment *env Line 1997  extern void sx_72656164(environment *env
1997        
1998    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1999    match= malloc(inlength);    match= malloc(inlength);
2000      assert(match != NULL);
2001    
2002    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
2003       && readlength != -1) {       && readlength != -1) {
# Line 1621  extern void sx_72656164(environment *env Line 2010  extern void sx_72656164(environment *env
2010      } else {      } else {
2011        push_float(env, ftemp);        push_float(env, ftemp);
2012      }      }
2013      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
2014                && readlength != -1) {
2015        push_cstring(env, "");
2016    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
2017              && readlength != -1) {              && readlength != -1) {
2018      push_cstring(env, match);      push_cstring(env, match);
# Line 1652  extern void sx_72656164(environment *env Line 2044  extern void sx_72656164(environment *env
2044      return sx_72656164(env);      return sx_72656164(env);
2045  }  }
2046    
2047    #ifdef __linux__
2048  extern void beep(environment *env)  extern void beep(environment *env)
2049  {  {
2050    int freq, dur, period, ticks;    int freq, dur, period, ticks;
2051    
2052    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2053      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2054      env->err= 1;      env->err= 1;
2055      return;      return;
# Line 1694  extern void beep(environment *env) Line 2087  extern void beep(environment *env)
2087      abort();      abort();
2088    }    }
2089  }  }
2090    #endif /* __linux__ */
2091    
2092  /* "wait" */  /* "wait" */
2093  extern void sx_77616974(environment *env)  extern void sx_77616974(environment *env)
2094  {  {
2095    int dur;    int dur;
2096    
2097    if(env->head==NULL) {    if(env->head->type==empty) {
2098      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2099      env->err= 1;      env->err= 1;
2100      return;      return;
# Line 1720  extern void sx_77616974(environment *env Line 2114  extern void sx_77616974(environment *env
2114    
2115  extern void copying(environment *env)  extern void copying(environment *env)
2116  {  {
2117    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
2118                         Version 2, June 1991\n\                         Version 2, June 1991\n\
2119  \n\  \n\
2120   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2009  extern void sx_2a(environment *env) Line 2403  extern void sx_2a(environment *env)
2403    int a, b;    int a, b;
2404    float fa, fb;    float fa, fb;
2405    
2406    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2407      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2408      env->err= 1;      env->err= 1;
2409      return;      return;
# Line 2069  extern void sx_2f(environment *env) Line 2463  extern void sx_2f(environment *env)
2463    int a, b;    int a, b;
2464    float fa, fb;    float fa, fb;
2465    
2466    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2467      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2468      env->err= 1;      env->err= 1;
2469      return;      return;
# Line 2128  extern void mod(environment *env) Line 2522  extern void mod(environment *env)
2522  {  {
2523    int a, b;    int a, b;
2524    
2525    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2526      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2527      env->err= 1;      env->err= 1;
2528      return;      return;
# Line 2154  extern void sx_646976(environment *env) Line 2548  extern void sx_646976(environment *env)
2548  {  {
2549    int a, b;    int a, b;
2550        
2551    if(env->head==NULL || CDR(env->head)==NULL) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
2552      printerr("Too Few Arguments");      printerr("Too Few Arguments");
2553      env->err= 1;      env->err= 1;
2554      return;      return;
# Line 2174  extern void sx_646976(environment *env) Line 2568  extern void sx_646976(environment *env)
2568    printerr("Bad Argument Type");    printerr("Bad Argument Type");
2569    env->err= 2;    env->err= 2;
2570  }  }
2571    
2572    extern void setcar(environment *env)
2573    {
2574      if(env->head->type==empty || CDR(env->head)->type==empty) {
2575        printerr("Too Few Arguments");
2576        env->err= 1;
2577        return;
2578      }
2579    
2580      if(CDR(env->head)->type!=tcons) {
2581        printerr("Bad Argument Type");
2582        env->err= 2;
2583        return;
2584      }
2585    
2586      CAR(CAR(CDR(env->head)))=CAR(env->head);
2587      toss(env);
2588    }
2589    
2590    extern void setcdr(environment *env)
2591    {
2592      if(env->head->type==empty || CDR(env->head)->type==empty) {
2593        printerr("Too Few Arguments");
2594        env->err= 1;
2595        return;
2596      }
2597    
2598      if(CDR(env->head)->type!=tcons) {
2599        printerr("Bad Argument Type");
2600        env->err= 2;
2601        return;
2602      }
2603    
2604      CDR(CAR(CDR(env->head)))=CAR(env->head);
2605      toss(env);
2606    }
2607    
2608    extern void car(environment *env)
2609    {
2610      if(env->head->type==empty) {
2611        printerr("Too Few Arguments");
2612        env->err= 1;
2613        return;
2614      }
2615    
2616      if(CAR(env->head)->type!=tcons) {
2617        printerr("Bad Argument Type");
2618        env->err= 2;
2619        return;
2620      }
2621    
2622      CAR(env->head)=CAR(CAR(env->head));
2623    }
2624    
2625    extern void cdr(environment *env)
2626    {
2627      if(env->head->type==empty) {
2628        printerr("Too Few Arguments");
2629        env->err= 1;
2630        return;
2631      }
2632    
2633      if(CAR(env->head)->type!=tcons) {
2634        printerr("Bad Argument Type");
2635        env->err= 2;
2636        return;
2637      }
2638    
2639      CAR(env->head)=CDR(CAR(env->head));
2640    }
2641    
2642    extern void cons(environment *env)
2643    {
2644      value *val;
2645    
2646      if(env->head->type==empty || CDR(env->head)->type==empty) {
2647        printerr("Too Few Arguments");
2648        env->err= 1;
2649        return;
2650      }
2651    
2652      val=new_val(env);
2653      val->content.c= malloc(sizeof(pair));
2654      assert(val->content.c!=NULL);
2655    
2656      env->gc_count += sizeof(pair);
2657      val->type=tcons;
2658    
2659      CAR(val)= CAR(CDR(env->head));
2660      CDR(val)= CAR(env->head);
2661    
2662      push_val(env, val);
2663    
2664      swap(env); if(env->err) return;
2665      toss(env); if(env->err) return;
2666      swap(env); if(env->err) return;
2667      toss(env); if(env->err) return;
2668    }
2669    
2670    /*  2: 3                        =>                */
2671    /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
2672    extern void assq(environment *env)
2673    {
2674      assocgen(env, eq);
2675    }
2676    
2677    
2678    /* General assoc function */
2679    void assocgen(environment *env, funcp eqfunc)
2680    {
2681      value *key, *item;
2682    
2683      /* Needs two values on the stack, the top one must be an association
2684         list */
2685      if(env->head->type==empty || CDR(env->head)->type==empty) {
2686        printerr("Too Few Arguments");
2687        env->err= 1;
2688        return;
2689      }
2690    
2691      if(CAR(env->head)->type!=tcons) {
2692        printerr("Bad Argument Type");
2693        env->err= 2;
2694        return;
2695      }
2696    
2697      key=CAR(CDR(env->head));
2698      item=CAR(env->head);
2699    
2700      while(item->type == tcons){
2701        if(CAR(item)->type != tcons){
2702          printerr("Bad Argument Type");
2703          env->err= 2;
2704          return;
2705        }
2706        push_val(env, key);
2707        push_val(env, CAR(CAR(item)));
2708        eqfunc(env); if(env->err) return;
2709    
2710        /* Check the result of 'eqfunc' */
2711        if(env->head->type==empty) {
2712          printerr("Too Few Arguments");
2713          env->err= 1;
2714        return;
2715        }
2716        if(CAR(env->head)->type!=integer) {
2717          printerr("Bad Argument Type");
2718          env->err= 2;
2719          return;
2720        }
2721    
2722        if(CAR(env->head)->content.i){
2723          toss(env); if(env->err) return;
2724          break;
2725        }
2726        toss(env); if(env->err) return;
2727    
2728        if(item->type!=tcons) {
2729          printerr("Bad Argument Type");
2730          env->err= 2;
2731          return;
2732        }
2733    
2734        item=CDR(item);
2735      }
2736    
2737      if(item->type == tcons){      /* A match was found */
2738        push_val(env, CAR(item));
2739      } else {
2740        push_int(env, 0);
2741      }
2742      swap(env); if(env->err) return;
2743      toss(env); if(env->err) return;
2744      swap(env); if(env->err) return;
2745      toss(env);
2746    }
2747    
2748    /* "do" */
2749    extern void sx_646f(environment *env)
2750    {
2751      swap(env); if(env->err) return;
2752      eval(env);
2753    }
2754    
2755    /* "open" */
2756    /* 2: "file"                                    */
2757    /* 1: "r"       =>      1: #<port 0x47114711>   */
2758    extern void sx_6f70656e(environment *env)
2759    {
2760      value *new_port;
2761      FILE *stream;
2762    
2763      if(env->head->type == empty || CDR(env->head)->type == empty) {
2764        printerr("Too Few Arguments");
2765        env->err=1;
2766        return;
2767      }
2768    
2769      if(CAR(env->head)->type != string
2770         || CAR(CDR(env->head))->type != string) {
2771        printerr("Bad Argument Type");
2772        env->err= 2;
2773        return;
2774      }
2775    
2776      stream=fopen(CAR(CDR(env->head))->content.ptr,
2777                   CAR(env->head)->content.ptr);
2778    
2779      if(stream == NULL) {
2780        perror("open");
2781        env->err= 5;
2782        return;
2783      }
2784    
2785      new_port=new_val(env);
2786      new_port->type=port;
2787      new_port->content.p=stream;
2788    
2789      push_val(env, new_port);
2790    
2791      swap(env); if(env->err) return;
2792      toss(env); if(env->err) return;
2793      swap(env); if(env->err) return;
2794      toss(env);
2795    }
2796    
2797    
2798    /* "close" */
2799    extern void sx_636c6f7365(environment *env)
2800    {
2801      int ret;
2802    
2803      if(env->head->type == empty) {
2804        printerr("Too Few Arguments");
2805        env->err=1;
2806        return;
2807      }
2808    
2809      if(CAR(env->head)->type != port) {
2810        printerr("Bad Argument Type");
2811        env->err= 2;
2812        return;
2813      }
2814    
2815      ret= fclose(CAR(env->head)->content.p);
2816    
2817      if(ret != 0){
2818        perror("close");
2819        env->err= 5;
2820        return;
2821      }
2822    
2823      toss(env);
2824    }
Legend:
Removed from v.1.105  
changed lines
  Added in v.1.124
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26