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

Diff of /stack/stack.c

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

revision 1.103 by teddy, Mon Mar 11 08:52:59 2002 UTC revision 1.127 by masse, Mon Aug 4 11:57:33 2003 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    
 /* printf, sscanf, fgets, fprintf, fopen, perror */  
 #include <stdio.h>  
 /* exit, EXIT_SUCCESS, malloc, free */  
 #include <stdlib.h>  
 /* NULL */  
 #include <stddef.h>  
 /* dlopen, dlsym, dlerror */  
 #include <dlfcn.h>  
 /* strcmp, strcpy, strlen, strcat, strdup */  
 #include <string.h>  
 /* getopt, STDIN_FILENO, STDOUT_FILENO, usleep */  
 #include <unistd.h>  
 /* EX_NOINPUT, EX_USAGE */  
 #include <sysexits.h>  
 /* mtrace, muntrace */  
 #include <mcheck.h>  
 /* ioctl */  
 #include <sys/ioctl.h>  
 /* KDMKTONE */  
 #include <linux/kd.h>  
   
24  #include "stack.h"  #include "stack.h"
25    
26  /* Initialize a newly created environment */  /* Initialize a newly created environment */
# Line 52  void init_env(environment *env) Line 32  void init_env(environment *env)
32    env->gc_count= 0;    env->gc_count= 0;
33    env->gc_ref= NULL;    env->gc_ref= NULL;
34    
35    env->head= NULL;    env->head= new_val(env);
36    for(i= 0; i<HASHTBLSIZE; i++)    for(i= 0; i<HASHTBLSIZE; i++)
37      env->symbols[i]= NULL;      env->symbols[i]= NULL;
38    env->err= 0;    env->err= 0;
# Line 67  void printerr(const char* in_string) Line 47  void printerr(const char* in_string)
47    fprintf(stderr, "Err: %s\n", in_string);    fprintf(stderr, "Err: %s\n", in_string);
48  }  }
49    
 /* Discard the top element of the stack. */  
 extern void toss(environment *env)  
 {  
   cons *temp= env->head;  
   
   if(env->head==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   env->head= env->head->cdr->content.c; /* Remove the top stack item */  
   free(temp);                   /* Free the old top stack item */  
 }  
   
50  /* Returns a pointer to a pointer to an element in the hash table. */  /* Returns a pointer to a pointer to an element in the hash table. */
51  symbol **hash(hashtbl in_hashtbl, const char *in_string)  symbol **hash(hashtbl in_hashtbl, const char *in_string)
52  {  {
# Line 117  value* new_val(environment *env) Line 82  value* new_val(environment *env)
82    value *nval= malloc(sizeof(value));    value *nval= malloc(sizeof(value));
83    stackitem *nitem= malloc(sizeof(stackitem));    stackitem *nitem= malloc(sizeof(stackitem));
84    
85      assert(nval != NULL);
86      assert(nitem != NULL);
87    
88    nval->content.ptr= NULL;    nval->content.ptr= NULL;
89      nval->type= empty;
90    
91    nitem->item= nval;    nitem->item= nval;
92    nitem->next= env->gc_ref;    nitem->next= env->gc_ref;
# Line 131  value* new_val(environment *env) Line 100  value* new_val(environment *env)
100    return nval;    return nval;
101  }  }
102    
103    
104  /* Mark values recursively.  /* Mark values recursively.
105     Marked values are not collected by the GC. */     Marked values are not collected by the GC. */
106  inline void gc_mark(value *val)  inline void gc_mark(value *val)
# Line 140  inline void gc_mark(value *val) Line 110  inline void gc_mark(value *val)
110    
111    val->gc.flag.mark= 1;    val->gc.flag.mark= 1;
112    
113    if(val->type==tcons && val->content.c!=NULL) {    if(val->type==tcons) {
114      gc_mark(val->content.c->car);      gc_mark(CAR(val));
115      gc_mark(val->content.c->cdr);      gc_mark(CDR(val));
116    }    }
117  }  }
118    
 inline void gc_maybe(environment *env)  
 {  
   if(env->gc_count < env->gc_limit)  
     return;  
   else  
     return gc_init(env);  
 }  
119    
120  /* Start GC */  /* Start GC */
121  extern void gc_init(environment *env)  extern void gc_init(environment *env)
122  {  {
123    stackitem *new_head= NULL, *titem;    stackitem *new_head= NULL, *titem;
   cons *iterator;  
124    symbol *tsymb;    symbol *tsymb;
125    int i;    int i;
126    
# Line 166  extern void gc_init(environment *env) Line 128  extern void gc_init(environment *env)
128      printf("Garbage collecting.");      printf("Garbage collecting.");
129    
130    /* Mark values on stack */    /* Mark values on stack */
131    if(env->head!=NULL) {    gc_mark(env->head);
     gc_mark(env->head->car);  
     gc_mark(env->head->cdr);  
   }  
132    
133    if(env->interactive)    if(env->interactive)
134      printf(".");      printf(".");
# Line 185  extern void gc_init(environment *env) Line 144  extern void gc_init(environment *env)
144    if(env->interactive)    if(env->interactive)
145      printf(".");      printf(".");
146    
   
147    env->gc_count= 0;    env->gc_count= 0;
148    
149    while(env->gc_ref!=NULL) {    /* Sweep unused values */    while(env->gc_ref!=NULL) {    /* Sweep unused values */
150    
151      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */      if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
152    
153        if(env->gc_ref->item->type==string) /* Remove content */        /* Remove content */
154          switch(env->gc_ref->item->type){
155          case string:
156          free(env->gc_ref->item->content.ptr);          free(env->gc_ref->item->content.ptr);
157            break;
158          case tcons:
159            free(env->gc_ref->item->content.c);
160            break;
161          case port:
162          case empty:
163          case integer:
164          case tfloat:
165          case func:
166          case symb:
167            /* Symbol strings are freed when walking the hash table */
168            break;
169          }
170    
171        free(env->gc_ref->item);  /* Remove from gc_ref */        free(env->gc_ref->item);  /* Remove from gc_ref */
172        titem= env->gc_ref->next;        titem= env->gc_ref->next;
173        free(env->gc_ref);        /* Remove value */        free(env->gc_ref);        /* Remove value */
174        env->gc_ref= titem;        env->gc_ref= titem;
175        continue;        continue;
176      }      }
177    #ifdef DEBUG
178        printf("Kept value (%p)", env->gc_ref->item);
179        if(env->gc_ref->item->gc.flag.mark)
180          printf(" (marked)");
181        if(env->gc_ref->item->gc.flag.protect)
182          printf(" (protected)");
183        switch(env->gc_ref->item->type){
184        case integer:
185          printf(" integer: %d", env->gc_ref->item->content.i);
186          break;
187        case func:
188          printf(" func: %p", env->gc_ref->item->content.ptr);
189          break;
190        case symb:
191          printf(" symb: %s", env->gc_ref->item->content.sym->id);
192          break;
193        case tcons:
194          printf(" tcons: %p\t%p", CAR(env->gc_ref->item),
195                 CDR(env->gc_ref->item));
196          break;
197        default:
198          printf(" <unknown %d>", (env->gc_ref->item->type));
199        }
200        printf("\n");
201    #endif /* DEBUG */
202    
203      /* Keep values */          /* Keep values */    
204      env->gc_count += sizeof(value);      env->gc_count += sizeof(value);
205      if(env->gc_ref->item->type==string)      if(env->gc_ref->item->type==string)
206        env->gc_count += strlen(env->gc_ref->item->content.ptr);        env->gc_count += strlen(env->gc_ref->item->content.ptr)+1;
207            
208      titem= env->gc_ref->next;      titem= env->gc_ref->next;
209      env->gc_ref->next= new_head;      env->gc_ref->next= new_head;
# Line 220  extern void gc_init(environment *env) Line 218  extern void gc_init(environment *env)
218    env->gc_ref= new_head;    env->gc_ref= new_head;
219    
220    if(env->interactive)    if(env->interactive)
221      printf("done\n");      printf("done (%d bytes still allocated)\n", env->gc_count);
222    
223    }
224    
225    inline void gc_maybe(environment *env)
226    {
227      if(env->gc_count < env->gc_limit)
228        return;
229      else
230        return gc_init(env);
231  }  }
232    
233  /* Protect values from GC */  /* Protect values from GC */
# Line 232  void protect(value *val) Line 238  void protect(value *val)
238    
239    val->gc.flag.protect= 1;    val->gc.flag.protect= 1;
240    
241    if(val->type==tcons && val->content.c!=NULL) {    if(val->type==tcons) {
242      protect(val->content.c->car);      protect(CAR(val));
243      protect(val->content.c->cdr);      protect(CDR(val));
244    }    }
245  }  }
246    
# Line 246  void unprotect(value *val) Line 252  void unprotect(value *val)
252    
253    val->gc.flag.protect= 0;    val->gc.flag.protect= 0;
254    
255    if(val->type==tcons && val->content.c!=NULL) {    if(val->type==tcons) {
256      unprotect(val->content.c->car);      unprotect(CAR(val));
257      unprotect(val->content.c->cdr);      unprotect(CDR(val));
258    }    }
259  }  }
260    
261  /* Push a value onto the stack */  /* Push a value onto the stack */
262  void push_val(environment *env, value *val)  void push_val(environment *env, value *val)
263  {  {
264    cons *new_item= malloc(sizeof(cons));    value *new_value= new_val(env);
   new_item->car= val;  
265    
266    new_item->cdr= new_val(env);    new_value->content.c= malloc(sizeof(pair));
267    new_item->cdr->type= tcons;    assert(new_value->content.c!=NULL);
268    new_item->cdr->content.c= env->head;    env->gc_count += sizeof(pair);
269    env->head= new_item;    new_value->type= tcons;
270      CAR(new_value)= val;
271      CDR(new_value)= env->head;
272      env->head= new_value;
273  }  }
274    
275  /* Push an integer onto the stack */  /* Push an integer onto the stack */
# Line 293  void push_cstring(environment *env, cons Line 301  void push_cstring(environment *env, cons
301    int length= strlen(in_string)+1;    int length= strlen(in_string)+1;
302    
303    new_value->content.ptr= malloc(length);    new_value->content.ptr= malloc(length);
304      assert(new_value != NULL);
305    env->gc_count += length;    env->gc_count += length;
306    strcpy(new_value->content.ptr, in_string);    strcpy(new_value->content.ptr, in_string);
307    new_value->type= string;    new_value->type= string;
# Line 307  char *mangle_str(const char *old_string) Line 316  char *mangle_str(const char *old_string)
316    char *new_string, *current;    char *new_string, *current;
317    
318    new_string= malloc((strlen(old_string)*2)+4);    new_string= malloc((strlen(old_string)*2)+4);
319      assert(new_string != NULL);
320    strcpy(new_string, "sx_");    /* Stack eXternal */    strcpy(new_string, "sx_");    /* Stack eXternal */
321    current= new_string+3;    current= new_string+3;
322    while(old_string[0] != '\0'){    while(old_string[0] != '\0'){
# Line 324  extern void mangle(environment *env) Line 334  extern void mangle(environment *env)
334  {  {
335    char *new_string;    char *new_string;
336    
337    if((env->head)==NULL) {    if(env->head->type==empty) {
338      printerr("Too Few Arguments");      printerr("Too Few Arguments");
339      env->err= 1;      env->err= 1;
340      return;      return;
341    }    }
342    
343    if(env->head->car->type!=string) {    if(CAR(env->head)->type!=string) {
344      printerr("Bad Argument Type");      printerr("Bad Argument Type");
345      env->err= 2;      env->err= 2;
346      return;      return;
347    }    }
348    
349    new_string= mangle_str((const char *)(env->head->car->content.ptr));    new_string=
350        mangle_str((const char *)(CAR(env->head)->content.ptr));
351    
352    toss(env);    toss(env);
353    if(env->err) return;    if(env->err) return;
# Line 375  void push_sym(environment *env, const ch Line 386  void push_sym(environment *env, const ch
386    
387      /* Create a new symbol */      /* Create a new symbol */
388      (*new_symbol)= malloc(sizeof(symbol));      (*new_symbol)= malloc(sizeof(symbol));
389        assert((*new_symbol) != NULL);
390      (*new_symbol)->val= NULL;   /* undefined value */      (*new_symbol)->val= NULL;   /* undefined value */
391      (*new_symbol)->next= NULL;      (*new_symbol)->next= NULL;
392      (*new_symbol)->id= malloc(strlen(in_string)+1);      (*new_symbol)->id= malloc(strlen(in_string)+1);
393        assert((*new_symbol)->id != NULL);
394      strcpy((*new_symbol)->id, in_string);      strcpy((*new_symbol)->id, in_string);
395    
396      /* Intern the new symbol in the hash table */      /* Intern the new symbol in the hash table */
# Line 411  void push_sym(environment *env, const ch Line 424  void push_sym(environment *env, const ch
424    unprotect(new_value); unprotect(new_fvalue);    unprotect(new_value); unprotect(new_fvalue);
425  }  }
426    
427  /* Print newline. */  /* Print a value */
428  extern void nl()  void print_val(environment *env, value *val, int noquote, stackitem *stack, FILE *stream)
429  {  {
430    printf("\n");    stackitem *titem, *tstack;
431  }    int depth;
432    
433  /* Gets the type of a value */    switch(val->type) {
434  extern void type(environment *env)    case empty:
435  {      if(fprintf(stream, "[]") < 0){
436    int typenum;        perror("print_val");
437          env->err= 5;
438    if((env->head)==NULL) {        return;
439      printerr("Too Few Arguments");      }
     env->err=1;  
     return;  
   }  
   typenum=env->head->car->type;  
   toss(env);  
   switch(typenum){  
   case integer:  
     push_sym(env, "integer");  
     break;  
   case tfloat:  
     push_sym(env, "float");  
     break;  
   case string:  
     push_sym(env, "string");  
     break;  
   case symb:  
     push_sym(env, "symbol");  
     break;  
   case func:  
     push_sym(env, "function");  
     break;  
   case tcons:  
     push_sym(env, "list");  
440      break;      break;
   }  
 }      
   
 /* Prints the top element of the stack. */  
 void print_h(cons *stack_head, int noquote)  
 {  
   switch(stack_head->car->type) {  
441    case integer:    case integer:
442      printf("%d", stack_head->car->content.i);      if(fprintf(stream, "%d", val->content.i) < 0){
443          perror("print_val");
444          env->err= 5;
445          return;
446        }
447      break;      break;
448    case tfloat:    case tfloat:
449      printf("%f", stack_head->car->content.f);      if(fprintf(stream, "%f", val->content.f) < 0){
450          perror("print_val");
451          env->err= 5;
452          return;
453        }
454      break;      break;
455    case string:    case string:
456      if(noquote)      if(noquote){
457        printf("%s", (char*)stack_head->car->content.ptr);        if(fprintf(stream, "%s", (char*)(val->content.ptr)) < 0){
458      else          perror("print_val");
459        printf("\"%s\"", (char*)stack_head->car->content.ptr);          env->err= 5;
460            return;
461          }
462        } else {                    /* quote */
463          if(fprintf(stream, "\"%s\"", (char*)(val->content.ptr)) < 0){
464            perror("print_val");
465            env->err= 5;
466            return;
467          }
468        }
469      break;      break;
470    case symb:    case symb:
471      printf("%s", ((symbol *)(stack_head->car->content.ptr))->id);      if(fprintf(stream, "%s", val->content.sym->id) < 0){
472          perror("print_val");
473          env->err= 5;
474          return;
475        }
476      break;      break;
477    case func:    case func:
478      printf("#<function %p>", (funcp)(stack_head->car->content.ptr));      if(fprintf(stream, "#<function %p>", (funcp)(val->content.ptr)) < 0){
479          perror("print_val");
480          env->err= 5;
481          return;
482        }
483      break;      break;
484    case tcons:    case port:
485      /* A list is just a stack, so make stack_head point to it */      if(fprintf(stream, "#<port %p>", (funcp)(val->content.p)) < 0){
486      stack_head=stack_head->car->content.c;        perror("print_val");
487      printf("[ ");        env->err= 5;
488      while(stack_head != NULL) {        return;
       print_h(stack_head, noquote);  
       printf(" ");  
       stack_head= stack_head->cdr->content.c;  
489      }      }
     printf("]");  
490      break;      break;
491    }    case tcons:
492  }      if(fprintf(stream, "[ ") < 0){
493          perror("print_val");
494  extern void print_(environment *env)        env->err= 5;
495  {        return;
496    if(env->head==NULL) {      }
497      printerr("Too Few Arguments");      tstack= stack;
498      env->err=1;      do {
499      return;        titem=malloc(sizeof(stackitem));
500    }        assert(titem != NULL);
501    print_h(env->head, 0);        titem->item=val;
502    nl();        titem->next=tstack;
503  }        tstack=titem;             /* Put it on the stack */
504          /* Search a stack of values being printed to see if we are already
505  /* Prints the top element of the stack and then discards it. */           printing this value */
506  extern void print(environment *env)        titem=tstack;
507  {        depth=0;
508    print_(env);        while(titem != NULL && titem->item != CAR(val)){
509    if(env->err) return;          titem=titem->next;
510    toss(env);          depth++;
511  }        }
512          if(titem != NULL){        /* If we found it on the stack, */
513  extern void princ_(environment *env)          if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
514  {            perror("print_val");
515    if(env->head==NULL) {            env->err= 5;
516      printerr("Too Few Arguments");            free(titem);
517      env->err=1;            return;
518      return;          }
519    }        } else {
520    print_h(env->head, 1);          print_val(env, CAR(val), noquote, tstack, stream);
521  }        }
522          val= CDR(val);
523          switch(val->type){
524          case empty:
525            break;
526          case tcons:
527            /* Search a stack of values being printed to see if we are already
528               printing this value */
529            titem=tstack;
530            depth=0;
531            while(titem != NULL && titem->item != val){
532              titem=titem->next;
533              depth++;
534            }
535            if(titem != NULL){      /* If we found it on the stack, */
536              if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
537                perror("print_val");
538                env->err= 5;
539                goto printval_end;
540              }
541            } else {
542              if(fprintf(stream, " ") < 0){
543                perror("print_val");
544                env->err= 5;
545                goto printval_end;
546              }
547            }
548            break;
549          default:
550            if(fprintf(stream, " . ") < 0){ /* Improper list */
551              perror("print_val");
552              env->err= 5;
553              goto printval_end;
554            }
555            print_val(env, val, noquote, tstack, stream);
556          }
557        } while(val->type == tcons && titem == NULL);
558    
559  /* Prints the top element of the stack and then discards it. */    printval_end:
 extern void princ(environment *env)  
 {  
   princ_(env);  
   if(env->err) return;  
   toss(env);  
 }  
560    
561  /* Only to be called by function printstack. */      titem=tstack;
562  void print_st(cons *stack_head, long counter)      while(titem != stack){
563  {        tstack=titem->next;
564    if(stack_head->cdr->content.c != NULL)        free(titem);
565      print_st(stack_head->cdr->content.c, counter+1);        titem=tstack;
566    printf("%ld: ", counter);      }
   print_h(stack_head, 0);  
   nl();  
 }  
567    
568  /* Prints the stack. */      if(! (env->err)){
569  extern void printstack(environment *env)        if(fprintf(stream, " ]") < 0){
570  {          perror("print_val");
571    if(env->head == NULL) {          env->err= 5;
572      printf("Stack Empty\n");        }
573      return;      }
574        break;
575    }    }
   
   print_st(env->head, 1);  
576  }  }
577    
578  /* Swap the two top elements on the stack. */  /* Swap the two top elements on the stack. */
579  extern void swap(environment *env)  extern void swap(environment *env)
580  {  {
581    cons *temp= env->head;    value *temp= env->head;
582        
583    if(env->head==NULL || env->head->cdr->content.c==NULL) {    if(env->head->type == empty || CDR(env->head)->type == empty) {
584      printerr("Too Few Arguments");      printerr("Too Few Arguments");
585      env->err=1;      env->err=1;
586      return;      return;
587    }    }
588    
589    env->head= env->head->cdr->content.c;    env->head= CDR(env->head);
590    temp->cdr->content.c= env->head->cdr->content.c;    CDR(temp)= CDR(env->head);
591    env->head->cdr->content.c= temp;    CDR(env->head)= temp;
592  }  }
593    
 /* Rotate the first three elements on the stack. */  
 extern void rot(environment *env)  
 {  
   cons *temp= env->head;  
     
   if(env->head==NULL || env->head->cdr->content.c==NULL  
      || env->head->cdr->content.c->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
   
   env->head= env->head->cdr->content.c->cdr->content.c;  
   temp->cdr->content.c->cdr->content.c= env->head->cdr->content.c;  
   env->head->cdr->content.c= temp;  
 }  
   
594  /* Recall a value from a symbol, if bound */  /* Recall a value from a symbol, if bound */
595  extern void rcl(environment *env)  extern void rcl(environment *env)
596  {  {
597    value *val;    value *val;
598    
599    if(env->head==NULL) {    if(env->head->type==empty) {
600      printerr("Too Few Arguments");      printerr("Too Few Arguments");
601      env->err= 1;      env->err= 1;
602      return;      return;
603    }    }
604    
605    if(env->head->car->type!=symb) {    if(CAR(env->head)->type!=symb) {
606      printerr("Bad Argument Type");      printerr("Bad Argument Type");
607      env->err= 2;      env->err= 2;
608      return;      return;
609    }    }
610    
611    val= ((symbol *)(env->head->car->content.ptr))->val;    val= CAR(env->head)->content.sym->val;
612    if(val == NULL){    if(val == NULL){
613      printerr("Unbound Variable");      printerr("Unbound Variable");
614      env->err= 3;      env->err= 3;
615      return;      return;
616    }    }
617    protect(val);    push_val(env, val);           /* Return the symbol's bound value */
618    toss(env);            /* toss the symbol */    swap(env);
619      if(env->err) return;
620      toss(env);                    /* toss the symbol */
621    if(env->err) return;    if(env->err) return;
   push_val(env, val); /* Return its bound value */  
   unprotect(val);  
622  }  }
623    
624    
625  /* 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
626     function value, and if it is, toss the symbol and execute the     function value, and if it is, toss the symbol and execute the
627     function. */     function. */
# Line 615  extern void eval(environment *env) Line 629  extern void eval(environment *env)
629  {  {
630    funcp in_func;    funcp in_func;
631    value* temp_val;    value* temp_val;
632    cons* iterator;    value* iterator;
633    
634   eval_start:   eval_start:
635    
636    gc_maybe(env);    gc_maybe(env);
637    
638    if(env->head==NULL) {    if(env->head->type==empty) {
639      printerr("Too Few Arguments");      printerr("Too Few Arguments");
640      env->err= 1;      env->err= 1;
641      return;      return;
642    }    }
643    
644    switch(env->head->car->type) {    switch(CAR(env->head)->type) {
645      /* if it's a symbol */      /* if it's a symbol */
646    case symb:    case symb:
647      rcl(env);                   /* get its contents */      rcl(env);                   /* get its contents */
648      if(env->err) return;      if(env->err) return;
649      if(env->head->car->type!=symb){ /* don't recurse symbols */      if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
650        goto eval_start;        goto eval_start;
651      }      }
652      return;      return;
653    
654      /* If it's a lone function value, run it */      /* If it's a lone function value, run it */
655    case func:    case func:
656      in_func= (funcp)(env->head->car->content.ptr);      in_func= (funcp)(CAR(env->head)->content.ptr);
657      toss(env);      toss(env);
658      if(env->err) return;      if(env->err) return;
659      return in_func(env);      return in_func(env);
660    
661      /* If it's a list */      /* If it's a list */
662    case tcons:    case tcons:
663      temp_val= env->head->car;      temp_val= CAR(env->head);
664      protect(temp_val);      protect(temp_val);
665    
666      toss(env); if(env->err) return;      toss(env); if(env->err) return;
667      iterator= (cons*)temp_val->content.ptr;      iterator= temp_val;
668            
669      while(iterator!=NULL) {      while(iterator->type != empty) {
670        push_val(env, iterator->car);        push_val(env, CAR(iterator));
671                
672        if(env->head->car->type==symb        if(CAR(env->head)->type==symb
673           && (((symbol*)(env->head->car->content.ptr))->id[0] == ';')) {           && CAR(env->head)->content.sym->id[0]==';') {
674          toss(env);          toss(env);
675          if(env->err) return;          if(env->err) return;
676                    
677          if(iterator->cdr->content.ptr==NULL){          if(CDR(iterator)->type == empty){
678            goto eval_start;            goto eval_start;
679          }          }
680          eval(env);          eval(env);
681          if(env->err) return;          if(env->err) return;
682        }        }
683        if (iterator->cdr->type == tcons)        if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
684          iterator= iterator->cdr->content.c;          iterator= CDR(iterator);
685        else {        else {
686          printerr("Bad Argument Type"); /* Improper list */          printerr("Bad Argument Type"); /* Improper list */
687          env->err= 2;          env->err= 2;
# Line 677  extern void eval(environment *env) Line 691  extern void eval(environment *env)
691      unprotect(temp_val);      unprotect(temp_val);
692      return;      return;
693    
694    default:    case empty:
695      return;      toss(env);
696    }    case integer:
697  }    case tfloat:
698      case string:
699  /* Reverse (flip) a list */    case port:
 extern void rev(environment *env)  
 {  
   cons *old_head, *new_head, *item;  
   
   if((env->head)==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->car->type!=tcons) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
700      return;      return;
701    }    }
   
   old_head= env->head->car->content.c;  
   new_head= NULL;  
   while(old_head!=NULL) {  
     item= old_head;  
     old_head= old_head->cdr->content.c;  
     item->cdr->content.c= new_head;  
     new_head= item;  
   }  
   env->head->car->content.ptr= new_head;  
702  }  }
703    
704  /* Make a list. */  /* List all defined words */
705  extern void pack(environment *env)  extern void words(environment *env)
 {  
   cons *iterator, *temp;  
   value *pack;  
   
   iterator= env->head;  
   pack= new_val(env);  
   protect(pack);  
   
   if(iterator==NULL  
      || (iterator->car->type==symb  
      && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {  
     temp= NULL;  
     toss(env);  
   } else {  
     /* Search for first delimiter */  
     while(iterator->cdr->content.c!=NULL  
           && (iterator->cdr->content.c->car->type!=symb  
               || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]  
               !='['))  
       iterator= iterator->cdr->content.c;  
       
     /* Extract list */  
     temp= env->head;  
     env->head= iterator->cdr->content.c;  
     iterator->cdr->content.c= NULL;  
   
     pack->type= tcons;  
     pack->content.ptr= temp;  
       
     if(env->head!=NULL)  
       toss(env);  
   }  
   
   /* Push list */  
   
   push_val(env, pack);  
   rev(env);  
   
   unprotect(pack);  
 }  
   
 /* Relocate elements of the list on the stack. */  
 extern void expand(environment *env)  
706  {  {
707    cons *temp, *new_head;    symbol *temp;
708      int i;
709    /* Is top element a list? */    
710    if(env->head==NULL) {    for(i= 0; i<HASHTBLSIZE; i++) {
711      printerr("Too Few Arguments");      temp= env->symbols[i];
712      env->err= 1;      while(temp!=NULL) {
713      return;  #ifdef DEBUG
714    }        if (temp->val != NULL && temp->val->gc.flag.protect)
715    if(env->head->car->type!=tcons) {          printf("(protected) ");
716      printerr("Bad Argument Type");  #endif /* DEBUG */
717      env->err= 2;        printf("%s ", temp->id);
718      return;        temp= temp->next;
   }  
   
   rev(env);  
   
   if(env->err)  
     return;  
   
   /* The first list element is the new stack head */  
   new_head= temp= env->head->car->content.c;  
   
   toss(env);  
   
   /* Find the end of the list */  
   while(temp->cdr->content.ptr != NULL) {  
     if (temp->cdr->type == tcons)  
       temp= temp->cdr->content.c;  
     else {  
       printerr("Bad Argument Type"); /* Improper list */  
       env->err= 2;  
       return;  
719      }      }
720    }    }
   
   /* Connect the tail of the list with the old stack head */  
   temp->cdr->content.c= env->head;  
   env->head= new_head;          /* ...and voila! */  
   
 }  
   
 /* Compares two elements by reference. */  
 extern void eq(environment *env)  
 {  
   void *left, *right;  
   
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   left= env->head->car->content.ptr;  
   swap(env);  
   right= env->head->car->content.ptr;  
   toss(env); toss(env);  
   
   push_int(env, left==right);  
 }  
   
 /* Negates the top element on the stack. */  
 extern void not(environment *env)  
 {  
   int val;  
   
   if(env->head==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->car->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   val= env->head->car->content.i;  
   toss(env);  
   push_int(env, !val);  
 }  
   
 /* Compares the two top elements on the stack and return 0 if they're the  
    same. */  
 extern void neq(environment *env)  
 {  
   eq(env);  
   not(env);  
721  }  }
722    
 /* Give a symbol some content. */  
 extern void def(environment *env)  
 {  
   symbol *sym;  
   
   /* Needs two values on the stack, the top one must be a symbol */  
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->car->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   /* long names are a pain */  
   sym= env->head->car->content.ptr;  
   
   /* Bind the symbol to the value */  
   sym->val= env->head->cdr->content.c->car;  
   
   toss(env); toss(env);  
 }  
   
723  /* Quit stack. */  /* Quit stack. */
724  extern void quit(environment *env)  extern void quit(environment *env)
725  {  {
726    int i;    int i;
727    
728    clear(env);    while(env->head->type != empty)
729        toss(env);
730    
731    if (env->err) return;    if (env->err) return;
732    for(i= 0; i<HASHTBLSIZE; i++) {    for(i= 0; i<HASHTBLSIZE; i++) {
# Line 891  extern void quit(environment *env) Line 739  extern void quit(environment *env)
739    env->gc_limit= 0;    env->gc_limit= 0;
740    gc_maybe(env);    gc_maybe(env);
741    
742      words(env);
743    
744    if(env->free_string!=NULL)    if(env->free_string!=NULL)
745      free(env->free_string);      free(env->free_string);
746        
747    #ifdef __linux__
748    muntrace();    muntrace();
749    #endif
750    
751    exit(EXIT_SUCCESS);    exit(EXIT_SUCCESS);
752  }  }
753    
 /* Clear stack */  
 extern void clear(environment *env)  
 {  
   while(env->head!=NULL)  
     toss(env);  
 }  
   
 /* List all defined words */  
 extern void words(environment *env)  
 {  
   symbol *temp;  
   int i;  
     
   for(i= 0; i<HASHTBLSIZE; i++) {  
     temp= env->symbols[i];  
     while(temp!=NULL) {  
       printf("%s\n", temp->id);  
       temp= temp->next;  
     }  
   }  
 }  
   
754  /* Internal forget function */  /* Internal forget function */
755  void forget_sym(symbol **hash_entry)  void forget_sym(symbol **hash_entry)
756  {  {
# Line 933  void forget_sym(symbol **hash_entry) Line 763  void forget_sym(symbol **hash_entry)
763    free(temp);    free(temp);
764  }  }
765    
766  /* Forgets a symbol (remove it from the hash table) */  /* Only to be called by itself function printstack. */
767  extern void forget(environment *env)  void print_st(environment *env, value *stack_head, long counter)
768  {  {
769    char* sym_id;    if(CDR(stack_head)->type != empty)
770    cons *stack_head= env->head;      print_st(env, CDR(stack_head), counter+1);
771      printf("%ld: ", counter);
772      print_val(env, CAR(stack_head), 0, NULL, stdout);
773      printf("\n");
774    }
775    
776    if(stack_head==NULL) {  /* Prints the stack. */
777      printerr("Too Few Arguments");  extern void printstack(environment *env)
778      env->err= 1;  {
779      return;    if(env->head->type == empty) {
780    }      printf("Stack Empty\n");
     
   if(stack_head->car->type!=symb) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
781      return;      return;
782    }    }
783    
784    sym_id= ((symbol*)(stack_head->car->content.ptr))->id;    print_st(env, env->head, 1);
   toss(env);  
   
   return forget_sym(hash(env->symbols, sym_id));  
 }  
   
 /* Returns the current error number to the stack */  
 extern void errn(environment *env)  
 {  
   push_int(env, env->err);  
785  }  }
786    
787  int main(int argc, char **argv)  int main(int argc, char **argv)
# Line 969  int main(int argc, char **argv) Line 790  int main(int argc, char **argv)
790    
791    int c;                        /* getopt option character */    int c;                        /* getopt option character */
792    
793    #ifdef __linux__
794    mtrace();    mtrace();
795    #endif
796    
797    init_env(&myenv);    init_env(&myenv);
798    
# Line 983  int main(int argc, char **argv) Line 806  int main(int argc, char **argv)
806          break;          break;
807        case '?':        case '?':
808          fprintf (stderr,          fprintf (stderr,
809                   "Unknown option character `\\x%x'.\n",                   "Unknown option character '\\x%x'.\n",
810                   optopt);                   optopt);
811          return EX_USAGE;          return EX_USAGE;
812        default:        default:
# Line 1002  int main(int argc, char **argv) Line 825  int main(int argc, char **argv)
825    if(myenv.interactive) {    if(myenv.interactive) {
826      printf("Stack version $Revision$\n\      printf("Stack version $Revision$\n\
827  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\  Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn\n\
828  Stack comes with ABSOLUTELY NO WARRANTY; for details type `warranty;'.\n\  Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
829  This is free software, and you are welcome to redistribute it\n\  This is free software, and you are welcome to redistribute it\n\
830  under certain conditions; type `copying;' for details.\n");  under certain conditions; type 'copying;' for details.\n");
831    }    }
832    
833    while(1) {    while(1) {
# Line 1012  under certain conditions; type `copying; Line 835  under certain conditions; type `copying;
835        if (myenv.interactive) {        if (myenv.interactive) {
836          if(myenv.err) {          if(myenv.err) {
837            printf("(error %d)\n", myenv.err);            printf("(error %d)\n", myenv.err);
838              myenv.err= 0;
839          }          }
840          nl();          printf("\n");
841          printstack(&myenv);          printstack(&myenv);
842          printf("> ");          printf("> ");
843        }        }
844        myenv.err=0;        myenv.err=0;
845      }      }
846      sx_72656164(&myenv);      readstream(&myenv, myenv.inputstream);
847      if (myenv.err==4) {      if (myenv.err) {            /* EOF or other error */
848        return EXIT_SUCCESS;      /* EOF */        myenv.err=0;
849      } else if(myenv.head!=NULL        quit(&myenv);
850                && myenv.head->car->type==symb      } else if(myenv.head->type!=empty
851                && ((symbol*)(myenv.head->car->content.ptr))->id[0]==';') {                && CAR(myenv.head)->type==symb
852        toss(&myenv);             /* No error check in main */                && CAR(myenv.head)->content.sym->id[0] == ';') {
853          toss(&myenv); if(myenv.err) continue;
854        eval(&myenv);        eval(&myenv);
855        } else {
856          gc_maybe(&myenv);
857      }      }
     gc_maybe(&myenv);  
858    }    }
859    quit(&myenv);    quit(&myenv);
860    return EXIT_FAILURE;    return EXIT_FAILURE;
861  }  }
862    
 /* "+" */  
 extern void sx_2b(environment *env)  
 {  
   int a, b;  
   float fa, fb;  
   size_t len;  
   char* new_string;  
   value *a_val, *b_val;  
   
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->car->type==string  
      && env->head->cdr->content.c->car->type==string) {  
     a_val= env->head->car;  
     b_val= env->head->cdr->content.c->car;  
     protect(a_val); protect(b_val);  
     toss(env); if(env->err) return;  
     toss(env); if(env->err) return;  
     len= strlen(a_val->content.ptr)+strlen(b_val->content.ptr)+1;  
     new_string= malloc(len);  
     strcpy(new_string, b_val->content.ptr);  
     strcat(new_string, a_val->content.ptr);  
     push_cstring(env, new_string);  
     unprotect(a_val); unprotect(b_val);  
     free(new_string);  
       
     return;  
   }  
     
   if(env->head->car->type==integer  
      && env->head->cdr->content.c->car->type==integer) {  
     a= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     b= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b+a);  
   
     return;  
   }  
   
   if(env->head->car->type==tfloat  
      && env->head->cdr->content.c->car->type==tfloat) {  
     fa= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     fb= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb+fa);  
       
     return;  
   }  
   
   if(env->head->car->type==tfloat  
      && env->head->cdr->content.c->car->type==integer) {  
     fa= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     b= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b+fa);  
       
     return;  
   }  
   
   if(env->head->car->type==integer  
      && env->head->cdr->content.c->car->type==tfloat) {  
     a= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     fb= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb+a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err=2;  
 }  
   
 /* "-" */  
 extern void sx_2d(environment *env)  
 {  
   int a, b;  
   float fa, fb;  
   
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err=1;  
     return;  
   }  
     
   if(env->head->car->type==integer  
      && env->head->cdr->content.c->car->type==integer) {  
     a= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     b= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b-a);  
   
     return;  
   }  
   
   if(env->head->car->type==tfloat  
      && env->head->cdr->content.c->car->type==tfloat) {  
     fa= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     fb= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb-fa);  
       
     return;  
   }  
   
   if(env->head->car->type==tfloat  
      && env->head->cdr->content.c->car->type==integer) {  
     fa= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     b= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b-fa);  
       
     return;  
   }  
   
   if(env->head->car->type==integer  
      && env->head->cdr->content.c->car->type==tfloat) {  
     a= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     fb= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb-a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err=2;  
 }  
   
 /* ">" */  
 extern void sx_3e(environment *env)  
 {  
   int a, b;  
   float fa, fb;  
   
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
     
   if(env->head->car->type==integer  
      && env->head->cdr->content.c->car->type==integer) {  
     a=env->head->car->content.i;  
     toss(env); if(env->err) return;  
     b=env->head->car->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b>a);  
   
     return;  
   }  
   
   if(env->head->car->type==tfloat  
      && env->head->cdr->content.c->car->type==tfloat) {  
     fa= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     fb= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     push_int(env, fb>fa);  
       
     return;  
   }  
   
   if(env->head->car->type==tfloat  
      && env->head->cdr->content.c->car->type==integer) {  
     fa= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     b= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b>fa);  
       
     return;  
   }  
   
   if(env->head->car->type==integer  
      && env->head->cdr->content.c->car->type==tfloat) {  
     a= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     fb= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     push_int(env, fb>a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err=2;  
 }  
   
 /* "<" */  
 extern void sx_3c(environment *env)  
 {  
   swap(env); if(env->err) return;  
   sx_3e(env);  
 }  
   
 /* "<=" */  
 extern void sx_3c3d(environment *env)  
 {  
   sx_3e(env); if(env->err) return;  
   not(env);  
 }  
   
 /* ">=" */  
 extern void sx_3e3d(environment *env)  
 {  
   sx_3c(env); if(env->err) return;  
   not(env);  
 }  
   
863  /* Return copy of a value */  /* Return copy of a value */
864  value *copy_val(environment *env, value *old_value)  value *copy_val(environment *env, value *old_value)
865  {  {
   cons *old_item, *new_item, *prev_item;  
866    value *new_value;    value *new_value;
867    
868    protect(old_value);    if(old_value==NULL)
869        return NULL;
870    
871    new_value= new_val(env);    new_value= new_val(env);
   protect(new_value);  
872    new_value->type= old_value->type;    new_value->type= old_value->type;
873    
874    switch(old_value->type){    switch(old_value->type){
# Line 1272  value *copy_val(environment *env, value Line 876  value *copy_val(environment *env, value
876    case integer:    case integer:
877    case func:    case func:
878    case symb:    case symb:
879      case empty:
880      case port:
881      new_value->content= old_value->content;      new_value->content= old_value->content;
882      break;      break;
883    case string:    case string:
# Line 1279  value *copy_val(environment *env, value Line 885  value *copy_val(environment *env, value
885        strdup((char *)(old_value->content.ptr));        strdup((char *)(old_value->content.ptr));
886      break;      break;
887    case tcons:    case tcons:
     new_value->content.ptr= NULL;  
888    
889      prev_item= NULL;      new_value->content.c= malloc(sizeof(pair));
890      old_item= old_value->content.c;      assert(new_value->content.c!=NULL);
891        env->gc_count += sizeof(pair);
892    
893      if(old_value->content.ptr != NULL) { /* if list is not empty */      CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
894        new_item= malloc(sizeof(cons));      CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
       new_item->car= copy_val(env, old_item->car); /* recurse */  
       new_item->cdr= copy_val(env, old_item->cdr); /* recurse */  
     }  
895      break;      break;
896    }    }
897    
   unprotect(old_value); unprotect(new_value);  
   
898    return new_value;    return new_value;
899  }  }
900    
901  /* "dup"; duplicates an item on the stack */  /* read a line from a stream; used by readline */
902  extern void sx_647570(environment *env)  void readlinestream(environment *env, FILE *stream)
 {  
   if(env->head==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   push_val(env, copy_val(env, env->head->car));  
 }  
   
 /* "if", If-Then */  
 extern void sx_6966(environment *env)  
 {  
   int truth;  
   
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->cdr->content.c->car->type != integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
     
   swap(env);  
   if(env->err) return;  
     
   truth=env->head->car->content.i;  
   
   toss(env);  
   if(env->err) return;  
   
   if(truth)  
     eval(env);  
   else  
     toss(env);  
 }  
   
 /* If-Then-Else */  
 extern void ifelse(environment *env)  
 {  
   int truth;  
   
   if(env->head==NULL || env->head->cdr->content.c==NULL  
      || env->head->cdr->content.c->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->cdr->content.c->cdr->content.c->car->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
     
   rot(env);  
   if(env->err) return;  
     
   truth= env->head->car->content.i;  
   
   toss(env);  
   if(env->err) return;  
   
   if(!truth)  
     swap(env);  
   if(env->err) return;  
   
   toss(env);  
   if(env->err) return;  
   
   eval(env);  
 }  
   
 /* "while" */  
 extern void sx_7768696c65(environment *env)  
903  {  {
904    int truth;    char in_string[101];
   value *loop, *test;  
   
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   loop= env->head->car;  
   protect(loop);  
   toss(env); if(env->err) return;  
   
   test= env->head->car;  
   protect(test);  
   toss(env); if(env->err) return;  
905    
906    do {    if(fgets(in_string, 100, stream)==NULL) {
907      push_val(env, test);      push_cstring(env, "");
908      eval(env);      if (! feof(stream)){
909              perror("readline");
910      if(env->head->car->type != integer) {        env->err= 5;
       printerr("Bad Argument Type");  
       env->err= 2;  
       return;  
     }  
       
     truth= env->head->car->content.i;  
     toss(env); if(env->err) return;  
       
     if(truth) {  
       push_val(env, loop);  
       eval(env);  
     } else {  
       toss(env);  
911      }      }
912        } else {
913    } while(truth);      push_cstring(env, in_string);
914      }
   unprotect(loop); unprotect(test);  
915  }  }
916    
917    /* Reverse (flip) a list */
918  /* "for"; for-loop */  extern void rev(environment *env)
 extern void sx_666f72(environment *env)  
919  {  {
920    value *loop;    value *old_head, *new_head, *item;
   int foo1, foo2;  
921    
922    if(env->head==NULL || env->head->cdr->content.c==NULL    if(env->head->type==empty) {
      || env->head->cdr->content.c->cdr->content.c==NULL) {  
923      printerr("Too Few Arguments");      printerr("Too Few Arguments");
924      env->err= 1;      env->err= 1;
925      return;      return;
926    }    }
927    
928    if(env->head->cdr->content.c->car->type!=integer    if(CAR(env->head)->type==empty)
929       || env->head->cdr->content.c->cdr->content.c->car->type!=integer) {      return;                     /* Don't reverse an empty list */
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   loop= env->head->car;  
   protect(loop);  
   toss(env); if(env->err) return;  
   
   foo2= env->head->car->content.i;  
   toss(env); if(env->err) return;  
   
   foo1= env->head->car->content.i;  
   toss(env); if(env->err) return;  
   
   if(foo1<=foo2) {  
     while(foo1<=foo2) {  
       push_int(env, foo1);  
       push_val(env, loop);  
       eval(env); if(env->err) return;  
       foo1++;  
     }  
   } else {  
     while(foo1>=foo2) {  
       push_int(env, foo1);  
       push_val(env, loop);  
       eval(env); if(env->err) return;  
       foo1--;  
     }  
   }  
   unprotect(loop);  
 }  
   
 /* Variant of for-loop */  
 extern void foreach(environment *env)  
 {    
   value *loop, *foo;  
   cons *iterator;  
     
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
930    
931    if(env->head->cdr->content.c->car->type!=tcons) {    if(CAR(env->head)->type!=tcons) {
932      printerr("Bad Argument Type");      printerr("Bad Argument Type");
933      env->err= 2;      env->err= 2;
934      return;      return;
935    }    }
936    
937    loop= env->head->car;    old_head= CAR(env->head);
938    protect(loop);    new_head= new_val(env);
939    toss(env); if(env->err) return;    while(old_head->type != empty) {
940        item= old_head;
941    foo= env->head->car;      old_head= CDR(old_head);
942    protect(foo);      CDR(item)= new_head;
943    toss(env); if(env->err) return;      new_head= item;
   
   iterator= foo->content.c;  
   
   while(iterator!=NULL) {  
     push_val(env, iterator->car);  
     push_val(env, loop);  
     eval(env); if(env->err) return;  
     if (iterator->cdr->type == tcons){  
       iterator= iterator->cdr->content.c;  
     } else {  
       printerr("Bad Argument Type"); /* Improper list */  
       env->err= 2;  
       break;  
     }  
944    }    }
945    unprotect(loop); unprotect(foo);    CAR(env->head)= new_head;
946  }  }
947    
948  /* "to" */  /* Make a list. */
949  extern void to(environment *env)  extern void pack(environment *env)
950  {  {
951    int ending, start, i;    value *iterator, *temp, *ending;
   cons *iterator, *temp;  
   value *pack;  
   
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
952    
953    if(env->head->car->type!=integer    ending=new_val(env);
      || env->head->cdr->content.c->car->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   ending= env->head->car->content.i;  
   toss(env); if(env->err) return;  
   start= env->head->car->content.i;  
   toss(env); if(env->err) return;  
   
   push_sym(env, "[");  
   
   if(ending>=start) {  
     for(i= ending; i>=start; i--)  
       push_int(env, i);  
   } else {  
     for(i= ending; i<=start; i++)  
       push_int(env, i);  
   }  
954    
955    iterator= env->head;    iterator= env->head;
956    pack= new_val(env);    if(iterator->type == empty
957    protect(pack);       || (CAR(iterator)->type==symb
958         && CAR(iterator)->content.sym->id[0]=='[')) {
959    if(iterator==NULL      temp= ending;
      || (iterator->car->type==symb  
          && ((symbol*)(iterator->car->content.ptr))->id[0]=='[')) {  
     temp= NULL;  
960      toss(env);      toss(env);
961    } else {    } else {
962      /* Search for first delimiter */      /* Search for first delimiter */
963      while(iterator->cdr->content.c!=NULL      while(CDR(iterator)->type != empty
964            && (iterator->cdr->content.c->car->type!=symb            && (CAR(CDR(iterator))->type!=symb
965                || ((symbol*)(iterator->cdr->content.c->car->content.ptr))->id[0]             || CAR(CDR(iterator))->content.sym->id[0]!='['))
966                !='['))        iterator= CDR(iterator);
       iterator= iterator->cdr->content.ptr;  
967            
968      /* Extract list */      /* Extract list */
969      temp= env->head;      temp= env->head;
970      env->head= iterator->cdr->content.c;      env->head= CDR(iterator);
971      iterator->cdr->content.c= NULL;      CDR(iterator)= ending;
972    
973      pack->type= tcons;      if(env->head->type != empty)
     pack->content.ptr= temp;  
       
     if(env->head!=NULL)  
974        toss(env);        toss(env);
975    }    }
976    
977    /* Push list */    /* Push list */
978    
979    push_val(env, pack);    push_val(env, temp);
980      rev(env);
   unprotect(pack);  
 }  
   
 /* Read a string */  
 extern void readline(environment *env)  
 {  
   char in_string[101];  
   
   if(fgets(in_string, 100, env->inputstream)==NULL)  
     push_cstring(env, "");  
   else  
     push_cstring(env, in_string);  
981  }  }
982    
983  /* "read"; Read a value and place on stack */  /* read from a stream; used by "read" and "readport" */
984  extern void sx_72656164(environment *env)  void readstream(environment *env, FILE *stream)
985  {  {
986    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";    const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
987    const char strform[]= "\"%[^\"]\"%n";    const char strform[]= "\"%[^\"]\"%n";
# Line 1610  extern void sx_72656164(environment *env Line 996  extern void sx_72656164(environment *env
996    int count= -1;    int count= -1;
997    float ftemp;    float ftemp;
998    static int depth= 0;    static int depth= 0;
999    char *match, *ctemp;    char *match;
1000    size_t inlength;    size_t inlength;
1001    
1002    if(env->in_string==NULL) {    if(env->in_string==NULL) {
1003      if(depth > 0 && env->interactive) {      if(depth > 0 && env->interactive) {
1004        printf("]> ");        printf("]> ");
1005      }      }
1006      readline(env); if(env->err) return;      readlinestream(env, env->inputstream);
1007        if(env->err) return;
1008    
1009      if(((char *)(env->head->car->content.ptr))[0]=='\0'){      if(((char *)(CAR(env->head)->content.ptr))[0]=='\0'){
1010        env->err= 4;              /* "" means EOF */        env->err= 4;              /* "" means EOF */
1011        return;        return;
1012      }      }
1013            
1014      env->in_string= malloc(strlen(env->head->car->content.ptr)+1);      env->in_string= malloc(strlen(CAR(env->head)->content.ptr)+1);
1015        assert(env->in_string != NULL);
1016      env->free_string= env->in_string; /* Save the original pointer */      env->free_string= env->in_string; /* Save the original pointer */
1017      strcpy(env->in_string, env->head->car->content.ptr);      strcpy(env->in_string, CAR(env->head)->content.ptr);
1018      toss(env); if(env->err) return;      toss(env); if(env->err) return;
1019    }    }
1020        
1021    inlength= strlen(env->in_string)+1;    inlength= strlen(env->in_string)+1;
1022    match= malloc(inlength);    match= malloc(inlength);
1023      assert(match != NULL);
1024    
1025    if(sscanf(env->in_string, blankform, &readlength) != EOF    if(sscanf(env->in_string, blankform, &readlength) != EOF
1026       && readlength != -1) {       && readlength != -1) {
# Line 1644  extern void sx_72656164(environment *env Line 1033  extern void sx_72656164(environment *env
1033      } else {      } else {
1034        push_float(env, ftemp);        push_float(env, ftemp);
1035      }      }
1036      } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
1037                && readlength != -1) {
1038        push_cstring(env, "");
1039    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF    } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
1040              && readlength != -1) {              && readlength != -1) {
1041      push_cstring(env, match);      push_cstring(env, match);
# Line 1672  extern void sx_72656164(environment *env Line 1064  extern void sx_72656164(environment *env
1064    free(match);    free(match);
1065    
1066    if(depth)    if(depth)
1067      return sx_72656164(env);      return readstream(env, env->inputstream);
 }  
   
 extern void beep(environment *env)  
 {  
   int freq, dur, period, ticks;  
   
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->car->type!=integer  
      || env->head->cdr->content.c->car->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   dur= env->head->car->content.i;  
   toss(env);  
   freq= env->head->car->content.i;  
   toss(env);  
   
   period= 1193180/freq;         /* convert freq from Hz to period  
                                    length */  
   ticks= dur*.001193180;        /* convert duration from µseconds to  
                                    timer ticks */  
   
 /*    ticks=dur/1000; */  
   
       /*  if (ioctl(STDOUT_FILENO, KDMKTONE, (125<<16) + 0x637)==0) */  
   switch (ioctl(STDOUT_FILENO, KDMKTONE, (ticks<<16) | period)){  
   case 0:  
     usleep(dur);  
     return;  
   case -1:  
     perror("beep");  
     env->err= 5;  
     return;  
   default:  
     abort();  
   }  
 }  
   
 /* "wait" */  
 extern void sx_77616974(environment *env)  
 {  
   int dur;  
   
   if(env->head==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->car->type!=integer) {  
     printerr("Bad Argument Type");  
     env->err= 2;  
     return;  
   }  
   
   dur=env->head->car->content.i;  
   toss(env);  
   
   usleep(dur);  
1068  }  }
1069    
1070  extern void copying(environment *env)  extern void copying(environment *env)
1071  {  {
1072    printf("GNU GENERAL PUBLIC LICENSE\n\    printf("                  GNU GENERAL PUBLIC LICENSE\n\
1073                         Version 2, June 1991\n\                         Version 2, June 1991\n\
1074  \n\  \n\
1075   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\   Copyright (C) 1989, 1991 Free Software Foundation, Inc.\n\
# Line 2026  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER Line 1352  PROGRAMS), EVEN IF SUCH HOLDER OR OTHER
1352  POSSIBILITY OF SUCH DAMAGES.\n");  POSSIBILITY OF SUCH DAMAGES.\n");
1353  }  }
1354    
1355  /* "*" */  /* General assoc function */
1356  extern void sx_2a(environment *env)  void assocgen(environment *env, funcp eqfunc)
1357  {  {
1358    int a, b;    value *key, *item;
   float fa, fb;  
1359    
1360    if(env->head==NULL || env->head->cdr->content.c==NULL) {    /* Needs two values on the stack, the top one must be an association
1361         list */
1362      if(env->head->type==empty || CDR(env->head)->type==empty) {
1363      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1364      env->err= 1;      env->err= 1;
1365      return;      return;
1366    }    }
     
   if(env->head->car->type==integer  
      && env->head->cdr->content.c->car->type==integer) {  
     a= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     b= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b*a);  
   
     return;  
   }  
1367    
1368    if(env->head->car->type==tfloat    if(CAR(env->head)->type!=tcons) {
1369       && env->head->cdr->content.c->car->type==tfloat) {      printerr("Bad Argument Type");
1370      fa= env->head->car->content.f;      env->err= 2;
     toss(env); if(env->err) return;  
     fb= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb*fa);  
       
     return;  
   }  
   
   if(env->head->car->type==tfloat  
      && env->head->cdr->content.c->car->type==integer) {  
     fa= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     b= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b*fa);  
       
1371      return;      return;
1372    }    }
1373    
1374    if(env->head->car->type==integer    key=CAR(CDR(env->head));
1375       && env->head->cdr->content.c->car->type==tfloat) {    item=CAR(env->head);
     a= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     fb= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb*a);  
1376    
1377      while(item->type == tcons){
1378        if(CAR(item)->type != tcons){
1379          printerr("Bad Argument Type");
1380          env->err= 2;
1381          return;
1382        }
1383        push_val(env, key);
1384        push_val(env, CAR(CAR(item)));
1385        eqfunc(env); if(env->err) return;
1386    
1387        /* Check the result of 'eqfunc' */
1388        if(env->head->type==empty) {
1389          printerr("Too Few Arguments");
1390          env->err= 1;
1391      return;      return;
1392    }      }
1393        if(CAR(env->head)->type!=integer) {
1394    printerr("Bad Argument Type");        printerr("Bad Argument Type");
1395    env->err= 2;        env->err= 2;
1396  }        return;
1397        }
 /* "/" */  
 extern void sx_2f(environment *env)  
 {  
   int a, b;  
   float fa, fb;  
1398    
1399    if(env->head==NULL || env->head->cdr->content.c==NULL) {      if(CAR(env->head)->content.i){
1400      printerr("Too Few Arguments");        toss(env); if(env->err) return;
1401      env->err= 1;        break;
1402      return;      }
   }  
     
   if(env->head->car->type==integer  
      && env->head->cdr->content.c->car->type==integer) {  
     a= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     b= env->head->car->content.i;  
1403      toss(env); if(env->err) return;      toss(env); if(env->err) return;
     push_float(env, b/a);  
1404    
1405      return;      if(item->type!=tcons) {
1406    }        printerr("Bad Argument Type");
1407          env->err= 2;
1408    if(env->head->car->type==tfloat        return;
1409       && env->head->cdr->content.c->car->type==tfloat) {      }
     fa= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     fb= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb/fa);  
       
     return;  
   }  
1410    
1411    if(env->head->car->type==tfloat      item=CDR(item);
      && env->head->cdr->content.c->car->type==integer) {  
     fa= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     b= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     push_float(env, b/fa);  
       
     return;  
1412    }    }
1413    
1414    if(env->head->car->type==integer    if(item->type == tcons){      /* A match was found */
1415       && env->head->cdr->content.c->car->type==tfloat) {      push_val(env, CAR(item));
1416      a= env->head->car->content.i;    } else {
1417      toss(env); if(env->err) return;      push_int(env, 0);
     fb= env->head->car->content.f;  
     toss(env); if(env->err) return;  
     push_float(env, fb/a);  
   
     return;  
1418    }    }
1419      swap(env); if(env->err) return;
1420    printerr("Bad Argument Type");    toss(env); if(env->err) return;
1421    env->err= 2;    swap(env); if(env->err) return;
1422      toss(env);
1423  }  }
1424    
1425  /* "mod" */  /* Discard the top element of the stack. */
1426  extern void mod(environment *env)  extern void toss(environment *env)
1427  {  {
1428    int a, b;    if(env->head->type==empty) {
   
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
1429      printerr("Too Few Arguments");      printerr("Too Few Arguments");
1430      env->err= 1;      env->err= 1;
1431      return;      return;
1432    }    }
1433        
1434    if(env->head->car->type==integer    env->head= CDR(env->head); /* Remove the top stack item */
      && env->head->cdr->content.c->car->type==integer) {  
     a= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     b= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, b%a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err= 2;  
1435  }  }
1436    
 /* "div" */  
 extern void sx_646976(environment *env)  
 {  
   int a, b;  
     
   if(env->head==NULL || env->head->cdr->content.c==NULL) {  
     printerr("Too Few Arguments");  
     env->err= 1;  
     return;  
   }  
   
   if(env->head->car->type==integer  
      && env->head->cdr->content.c->car->type==integer) {  
     a= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     b= env->head->car->content.i;  
     toss(env); if(env->err) return;  
     push_int(env, (int)b/a);  
   
     return;  
   }  
   
   printerr("Bad Argument Type");  
   env->err= 2;  
 }  
Legend:
Removed from v.1.103  
changed lines
  Added in v.1.127
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26