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

Diff of /stack/stack.c

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

revision 1.114 by teddy, Sun Mar 17 02:15:01 2002 UTC revision 1.125 by teddy, Sun Mar 31 02:19:54 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 61  void init_env(environment *env) Line 62  void init_env(environment *env)
62    env->gc_ref= NULL;    env->gc_ref= NULL;
63    
64    env->head= new_val(env);    env->head= new_val(env);
   env->head->type= empty;  
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 123  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= integer;    nval->type= empty;
131    
132    nitem->item= nval;    nitem->item= nval;
133    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# Line 165  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 195  extern void gc_init(environment *env) Line 197  extern void gc_init(environment *env)
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;
# Line 285  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);    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 322  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 336  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 405  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 442  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  {  {
# Line 478  extern void type(environment *env) Line 522  extern void type(environment *env)
522    case tcons:    case tcons:
523      push_sym(env, "pair");      push_sym(env, "pair");
524      break;      break;
525      case port:
526        push_sym(env, "port");
527        break;
528    }    }
529    swap(env);    swap(env);
530    if (env->err) return;    if (env->err) return;
531    toss(env);    toss(env);
532  }      }
533    
534  /* Print a value */  /* Print a value */
535  void print_val(value *val, int noquote)  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
536  {  {
537      stackitem *titem, *tstack;
538      int depth;
539    
540    switch(val->type) {    switch(val->type) {
541    case empty:    case empty:
542      printf("[]");      if(fprintf(stream, "[]") < 0){
543          perror("print_val");
544          env->err= 5;
545          return;
546        }
547      break;      break;
548    case integer:    case integer:
549      printf("%d", val->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", val->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*)(val->content.ptr));        if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){
565      else          perror("print_val");
566        printf("\"%s\"", (char*)(val->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", val->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)(val->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      printf("[ ");      if(fprintf(stream, "[ ") < 0){
600          perror("print_val");
601          env->err= 5;
602          return;
603        }
604        tstack= stack;
605      do {      do {
606        print_val(CAR(val), noquote);        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);        val= CDR(val);
630        switch(val->type){        switch(val->type){
631        case empty:        case empty:
632          break;          break;
633        case tcons:        case tcons:
634          printf(" ");          /* 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;          break;
656        default:        default:
657          printf(" . ");          /* Improper list */          if(fprintf(stream, " . ") < 0){ /* Improper list */
658          print_val(val, noquote);            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);      } while(val->type == tcons && titem == NULL);
665      printf(" ]");  
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        }
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->type==empty) {    if(env->head->type==empty) {
# Line 537  extern void print_(environment *env) Line 690  extern void print_(environment *env)
690      env->err= 1;      env->err= 1;
691      return;      return;
692    }    }
693    print_val(CAR(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 549  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->type==empty) {    if(env->head->type==empty) {
# Line 556  extern void princ_(environment *env) Line 712  extern void princ_(environment *env)
712      env->err= 1;      env->err= 1;
713      return;      return;
714    }    }
715    print_val(CAR(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 567  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)->type != empty)    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_val(CAR(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. */
# Line 585  extern void printstack(environment *env) Line 796  extern void printstack(environment *env)
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 720  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 747  extern void rev(environment *env) Line 963  extern void rev(environment *env)
963    
964    old_head= CAR(env->head);    old_head= CAR(env->head);
965    new_head= new_val(env);    new_head= new_val(env);
   new_head->type= empty;  
966    while(old_head->type != empty) {    while(old_head->type != empty) {
967      item= old_head;      item= old_head;
968      old_head= CDR(old_head);      old_head= CDR(old_head);
# Line 763  extern void pack(environment *env) Line 978  extern void pack(environment *env)
978    value *iterator, *temp, *ending;    value *iterator, *temp, *ending;
979    
980    ending=new_val(env);    ending=new_val(env);
   ending->type=empty;  
981    
982    iterator= env->head;    iterator= env->head;
983    if(iterator->type == empty    if(iterator->type == empty
# Line 1061  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);        /* "read" */      sx_72656164(&myenv);        /* "read" */
1287      if (myenv.err==4) {         /* EOF */      if (myenv.err) {            /* EOF or other error */
1288        myenv.err=0;        myenv.err=0;
1289        quit(&myenv);        quit(&myenv);
1290      } else if(myenv.head->type!=empty      } 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); if(myenv.err) continue;
       toss(&myenv);             /* No error check in main */  
1294        eval(&myenv);        eval(&myenv);
1295        } else {
1296          gc_maybe(&myenv);
1297      }      }
     gc_maybe(&myenv);  
1298    }    }
1299    quit(&myenv);    quit(&myenv);
1300    return EXIT_FAILURE;    return EXIT_FAILURE;
# Line 1109  extern void sx_2b(environment *env) Line 1324  extern void sx_2b(environment *env)
1324      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1325      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;      len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;
1326      new_string= malloc(len);      new_string= malloc(len);
1327        assert(new_string != NULL);
1328      strcpy(new_string, b_val->content.ptr);      strcpy(new_string, b_val->content.ptr);
1329      strcat(new_string, a_val->content.ptr);      strcat(new_string, a_val->content.ptr);
1330      push_cstring(env, new_string);      push_cstring(env, new_string);
# Line 1315  value *copy_val(environment *env, value Line 1531  value *copy_val(environment *env, value
1531    if(old_value==NULL)    if(old_value==NULL)
1532      return NULL;      return NULL;
1533    
   protect(old_value);  
1534    new_value= new_val(env);    new_value= new_val(env);
1535    new_value->type= old_value->type;    new_value->type= old_value->type;
1536    
# Line 1324  value *copy_val(environment *env, value Line 1539  value *copy_val(environment *env, value
1539    case integer:    case integer:
1540    case func:    case func:
1541    case symb:    case symb:
1542      case empty:
1543      case port:
1544      new_value->content= old_value->content;      new_value->content= old_value->content;
1545      break;      break;
1546    case string:    case string:
# Line 1332  value *copy_val(environment *env, value Line 1549  value *copy_val(environment *env, value
1549      break;      break;
1550    case tcons:    case tcons:
1551    
1552      new_value->content.c= malloc(sizeof(cons));      new_value->content.c= malloc(sizeof(pair));
1553      assert(new_value->content.c!=NULL);      assert(new_value->content.c!=NULL);
1554        env->gc_count += sizeof(pair);
1555    
1556      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
1557      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
1558      break;      break;
1559    }    }
1560    
   unprotect(old_value);  
   
1561    return new_value;    return new_value;
1562  }  }
1563    
# Line 1423  extern void ifelse(environment *env) Line 1639  extern void ifelse(environment *env)
1639    eval(env);    eval(env);
1640  }  }
1641    
1642    /* "else" */
1643  extern void sx_656c7365(environment *env)  extern void sx_656c7365(environment *env)
1644  {  {
1645    if(env->head->type==empty || CDR(env->head)->type==empty    if(env->head->type==empty || CDR(env->head)->type==empty
# Line 1588  extern void foreach(environment *env) Line 1805  extern void foreach(environment *env)
1805    
1806    iterator= foo;    iterator= foo;
1807    
1808    while(iterator!=NULL) {    while(iterator->type!=empty) {
1809      push_val(env, CAR(iterator));      push_val(env, CAR(iterator));
1810      push_val(env, loop);      push_val(env, loop);
1811      eval(env); if(env->err) return;      eval(env); if(env->err) return;
# Line 1607  extern void foreach(environment *env) Line 1824  extern void foreach(environment *env)
1824  extern void to(environment *env)  extern void to(environment *env)
1825  {  {
1826    int ending, start, i;    int ending, start, i;
1827    value *iterator, *temp;    value *iterator, *temp, *end;
1828    
1829      end= new_val(env);
1830    
1831    if(env->head->type==empty || CDR(env->head)->type==empty) {    if(env->head->type==empty || CDR(env->head)->type==empty) {
1832      printerr("Too Few Arguments");      printerr("Too Few Arguments");
# Line 1642  extern void to(environment *env) Line 1861  extern void to(environment *env)
1861    if(iterator->type==empty    if(iterator->type==empty
1862       || (CAR(iterator)->type==symb       || (CAR(iterator)->type==symb
1863           && CAR(iterator)->content.sym->id[0]=='[')) {           && CAR(iterator)->content.sym->id[0]=='[')) {
1864      temp= NULL;      temp= end;
1865      toss(env);      toss(env);
1866    } else {    } else {
1867      /* Search for first delimiter */      /* Search for first delimiter */
1868      while(CDR(iterator)!=NULL      while(CDR(iterator)->type!=empty
1869            && (CAR(CDR(iterator))->type!=symb            && (CAR(CDR(iterator))->type!=symb
1870                || CAR(CDR(iterator))->content.sym->id[0]!='['))                || CAR(CDR(iterator))->content.sym->id[0]!='['))
1871        iterator= CDR(iterator);        iterator= CDR(iterator);
# Line 1654  extern void to(environment *env) Line 1873  extern void to(environment *env)
1873      /* Extract list */      /* Extract list */
1874      temp= env->head;      temp= env->head;
1875      env->head= CDR(iterator);      env->head= CDR(iterator);
1876      CDR(iterator)= NULL;      CDR(iterator)= end;
1877    
1878      if(env->head!=NULL)      if(env->head->type!=empty)
1879        toss(env);        toss(env);
1880    }    }
1881    
# Line 1667  extern void to(environment *env) Line 1886  extern void to(environment *env)
1886  /* Read a string */  /* Read a string */
1887  extern void readline(environment *env)  extern void readline(environment *env)
1888  {  {
1889      readlinestream(env, env->inputstream);
1890    }
1891    
1892    /* Read a string from a port */
1893    extern void readlineport(environment *env)
1894    {
1895      FILE *stream;
1896    
1897      if(env->head->type==empty) {
1898        printerr("Too Few Arguments");
1899        env->err= 1;
1900        return;
1901      }
1902    
1903      if(CAR(env->head)->type!=port) {
1904        printerr("Bad Argument Type");
1905        env->err= 2;
1906        return;
1907      }
1908    
1909      stream=CAR(env->head)->content.p;
1910      readlinestream(env, stream); if(env->err) return;
1911    
1912      swap(env); if(env->err) return;
1913      toss(env);
1914    }
1915    
1916    /* read a line from a stream; used by readline */
1917    void readlinestream(environment *env, FILE *stream)
1918    {
1919    char in_string[101];    char in_string[101];
1920    
1921    if(fgets(in_string, 100, env->inputstream)==NULL)    if(fgets(in_string, 100, stream)==NULL) {
1922      push_cstring(env, "");      push_cstring(env, "");
1923    else      if (! feof(stream)){
1924          perror("readline");
1925          env->err= 5;
1926        }
1927      } else {
1928      push_cstring(env, in_string);      push_cstring(env, in_string);
1929      }
1930  }  }
1931    
1932  /* "read"; Read a value and place on stack */  /* "read"; Read a value and place on stack */
1933  extern void sx_72656164(environment *env)  extern void sx_72656164(environment *env)
1934  {  {
1935      readstream(env, env->inputstream);
1936    }
1937    
1938    /* "readport"; Read a value from a port and place on stack */
1939    extern void readport(environment *env)
1940    {
1941      FILE *stream;
1942    
1943      if(env->head->type==empty) {
1944        printerr("Too Few Arguments");
1945        env->err= 1;
1946        return;
1947      }
1948    
1949      if(CAR(env->head)->type!=port) {
1950        printerr("Bad Argument Type");
1951        env->err= 2;
1952        return;
1953      }
1954    
1955      stream=CAR(env->head)->content.p;
1956      readstream(env, stream); if(env->err) return;
1957    
1958      swap(env); if(env->err) return;
1959      toss(env);
1960    }
1961    
1962    /* read from a stream; used by "read" and "readport" */
1963    void readstream(environment *env, FILE *stream)
1964    {
1965    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
1966    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
1967    const char intform[]= "%i%n";    const char intform[]= "%i%n";
# Line 1691  extern void sx_72656164(environment *env Line 1975  extern void sx_72656164(environment *env
1975    int count= -1;    int count= -1;
1976    float ftemp;    float ftemp;
1977    static int depth= 0;    static int depth= 0;
1978    char *match, *ctemp;    char *match;
1979    size_t inlength;    size_t inlength;
1980    
1981    if(env->in_string==NULL) {    if(env->in_string==NULL) {
# Line 1706  extern void sx_72656164(environment *env Line 1990  extern void sx_72656164(environment *env
1990      }      }
1991            
1992      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1993        assert(env->in_string != NULL);
1994      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1995      strcpy(env->in_string, CAR(env->head)->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1996      toss(env); if(env->err) return;      toss(env); if(env->err) return;
# Line 1713  extern void sx_72656164(environment *env Line 1998  extern void sx_72656164(environment *env
1998        
1999    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
2000    match= malloc(inlength);    match= malloc(inlength);
2001      assert(match != NULL);
2002    
2003    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
2004       && readlength != -1) {       && readlength != -1) {
# Line 2353  extern void cdr(environment *env) Line 2639  extern void cdr(environment *env)
2639    
2640    CAR(env->head)=CDR(CAR(env->head));    CAR(env->head)=CDR(CAR(env->head));
2641  }  }
2642    
2643    extern void cons(environment *env)
2644    {
2645      value *val;
2646    
2647      if(env->head->type==empty || CDR(env->head)->type==empty) {
2648        printerr("Too Few Arguments");
2649        env->err= 1;
2650        return;
2651      }
2652    
2653      val=new_val(env);
2654      val->content.c= malloc(sizeof(pair));
2655      assert(val->content.c!=NULL);
2656    
2657      env->gc_count += sizeof(pair);
2658      val->type=tcons;
2659    
2660      CAR(val)= CAR(CDR(env->head));
2661      CDR(val)= CAR(env->head);
2662    
2663      push_val(env, val);
2664    
2665      swap(env); if(env->err) return;
2666      toss(env); if(env->err) return;
2667      swap(env); if(env->err) return;
2668      toss(env); if(env->err) return;
2669    }
2670    
2671    /*  2: 3                        =>                */
2672    /*  1: [ [ 1 . 2 ] [ 3 . 4 ] ]  =>  1: [ 3 . 4 ]  */
2673    extern void assq(environment *env)
2674    {
2675      assocgen(env, eq);
2676    }
2677    
2678    
2679    /* General assoc function */
2680    void assocgen(environment *env, funcp eqfunc)
2681    {
2682      value *key, *item;
2683    
2684      /* Needs two values on the stack, the top one must be an association
2685         list */
2686      if(env->head->type==empty || CDR(env->head)->type==empty) {
2687        printerr("Too Few Arguments");
2688        env->err= 1;
2689        return;
2690      }
2691    
2692      if(CAR(env->head)->type!=tcons) {
2693        printerr("Bad Argument Type");
2694        env->err= 2;
2695        return;
2696      }
2697    
2698      key=CAR(CDR(env->head));
2699      item=CAR(env->head);
2700    
2701      while(item->type == tcons){
2702        if(CAR(item)->type != tcons){
2703          printerr("Bad Argument Type");
2704          env->err= 2;
2705          return;
2706        }
2707        push_val(env, key);
2708        push_val(env, CAR(CAR(item)));
2709        eqfunc(env); if(env->err) return;
2710    
2711        /* Check the result of 'eqfunc' */
2712        if(env->head->type==empty) {
2713          printerr("Too Few Arguments");
2714          env->err= 1;
2715        return;
2716        }
2717        if(CAR(env->head)->type!=integer) {
2718          printerr("Bad Argument Type");
2719          env->err= 2;
2720          return;
2721        }
2722    
2723        if(CAR(env->head)->content.i){
2724          toss(env); if(env->err) return;
2725          break;
2726        }
2727        toss(env); if(env->err) return;
2728    
2729        if(item->type!=tcons) {
2730          printerr("Bad Argument Type");
2731          env->err= 2;
2732          return;
2733        }
2734    
2735        item=CDR(item);
2736      }
2737    
2738      if(item->type == tcons){      /* A match was found */
2739        push_val(env, CAR(item));
2740      } else {
2741        push_int(env, 0);
2742      }
2743      swap(env); if(env->err) return;
2744      toss(env); if(env->err) return;
2745      swap(env); if(env->err) return;
2746      toss(env);
2747    }
2748    
2749    /* "do" */
2750    extern void sx_646f(environment *env)
2751    {
2752      swap(env); if(env->err) return;
2753      eval(env);
2754    }
2755    
2756    /* "open" */
2757    /* 2: "file"                                    */
2758    /* 1: "r"       =>      1: #<port 0x47114711>   */
2759    extern void sx_6f70656e(environment *env)
2760    {
2761      value *new_port;
2762      FILE *stream;
2763    
2764      if(env->head->type == empty || CDR(env->head)->type == empty) {
2765        printerr("Too Few Arguments");
2766        env->err=1;
2767        return;
2768      }
2769    
2770      if(CAR(env->head)->type != string
2771         || CAR(CDR(env->head))->type != string) {
2772        printerr("Bad Argument Type");
2773        env->err= 2;
2774        return;
2775      }
2776    
2777      stream=fopen(CAR(CDR(env->head))->content.ptr,
2778                   CAR(env->head)->content.ptr);
2779    
2780      if(stream == NULL) {
2781        perror("open");
2782        env->err= 5;
2783        return;
2784      }
2785    
2786      new_port=new_val(env);
2787      new_port->type=port;
2788      new_port->content.p=stream;
2789    
2790      push_val(env, new_port);
2791    
2792      swap(env); if(env->err) return;
2793      toss(env); if(env->err) return;
2794      swap(env); if(env->err) return;
2795      toss(env);
2796    }
2797    
2798    
2799    /* "close" */
2800    extern void sx_636c6f7365(environment *env)
2801    {
2802      int ret;
2803    
2804      if(env->head->type == empty) {
2805        printerr("Too Few Arguments");
2806        env->err=1;
2807        return;
2808      }
2809    
2810      if(CAR(env->head)->type != port) {
2811        printerr("Bad Argument Type");
2812        env->err= 2;
2813        return;
2814      }
2815    
2816      ret= fclose(CAR(env->head)->content.p);
2817    
2818      if(ret != 0){
2819        perror("close");
2820        env->err= 5;
2821        return;
2822      }
2823    
2824      toss(env);
2825    }
Legend:
Removed from v.1.114  
changed lines
  Added in v.1.125
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26