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

Contents of /stack/stack.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.137 - (show annotations)
Thu Feb 19 15:35:38 2004 UTC (20 years, 8 months ago) by masse
Branch: MAIN
CVS Tags: HEAD
Changes since 1.136: +1 -161 lines
File MIME type: text/plain
Extracted garbage collector to gc.c

1 /* -*- coding: utf-8; -*- */
2 /*
3 stack - an interactive interpreter for a stack-based language
4 Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn
5
6 This program is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2 of the License, or
9 (at your option) any later version.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with this program; if not, write to the Free Software
18 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19
20 Authors: Mats Alritzson <masse@fukt.bth.se>
21 Teddy Hogeborn <teddy@fukt.bth.se>
22 */
23
24 #include "stack.h"
25
26 const char* start_message= "Stack version $Revision: 1.136 $\n\
27 Copyright (C) 2002 Mats Alritzson and Teddy Hogeborn\n\
28 Stack comes with ABSOLUTELY NO WARRANTY; for details type 'warranty;'.\n\
29 This is free software, and you are welcome to redistribute it\n\
30 under certain conditions; type 'copying;' for details.";
31
32
33 /* Initialize a newly created environment */
34 void init_env(environment *env)
35 {
36 int i;
37
38 env->gc_limit= 400000;
39 env->gc_count= 0;
40 env->gc_ref= NULL;
41
42 env->head= new_val(env);
43 for(i= 0; i<HASHTBLSIZE; i++)
44 env->symbols[i]= NULL;
45 env->err= 0;
46 env->in_string= NULL;
47 env->free_string= NULL;
48 env->inputstream= stdin;
49 env->interactive= 1;
50 }
51
52
53 void printerr(environment *env)
54 {
55 char *in_string;
56
57 switch(env->err) {
58 case 0:
59 return;
60 case 1:
61 in_string= "Too Few Arguments";
62 break;
63 case 2:
64 in_string= "Bad Argument Type";
65 break;
66 case 3:
67 in_string= "Unbound Variable";
68 break;
69 case 5:
70 return perror(env->errsymb);
71 default:
72 in_string= "Unknown error";
73 break;
74 }
75
76 fprintf(stderr, "\"%s\":\nErr: %s\n", env->errsymb, in_string);
77 }
78
79
80 /* Returns a pointer to a pointer to an element in the hash table. */
81 symbol **hash(hashtbl in_hashtbl, const char *in_string)
82 {
83 int i= 0;
84 unsigned int out_hash= 0;
85 char key= '\0';
86 symbol **position;
87
88 while(1){ /* Hash in_string */
89 key= in_string[i++];
90 if(key=='\0')
91 break;
92 out_hash= out_hash*32+key;
93 }
94
95 out_hash= out_hash%HASHTBLSIZE;
96 position= &(in_hashtbl[out_hash]);
97
98 while(1){
99 if(*position==NULL) /* If empty */
100 return position;
101
102 if(strcmp(in_string, (*position)->id)==0) /* If match */
103 return position;
104
105 position= &((*position)->next); /* Try next */
106 }
107 }
108
109
110 /* Create new value */
111 value* new_val(environment *env)
112 {
113 value *nval= malloc(sizeof(value));
114 stackitem *nitem= malloc(sizeof(stackitem));
115
116 assert(nval != NULL);
117 assert(nitem != NULL);
118
119 nval->content.ptr= NULL;
120 nval->type= empty;
121
122 nitem->item= nval;
123 nitem->next= env->gc_ref;
124
125 env->gc_ref= nitem;
126
127 env->gc_count += sizeof(value);
128 nval->gc.flag.mark= 0;
129 nval->gc.flag.protect= 0;
130
131 return nval;
132 }
133
134
135 /* Push a value onto the stack */
136 void push_val(environment *env, value *val)
137 {
138 value *new_value= new_val(env);
139
140 new_value->content.c= malloc(sizeof(pair));
141 assert(new_value->content.c!=NULL);
142 env->gc_count += sizeof(pair);
143 new_value->type= tcons;
144 CAR(new_value)= val;
145 CDR(new_value)= env->head;
146 env->head= new_value;
147 }
148
149
150 /* Push an integer onto the stack */
151 void push_int(environment *env, int in_val)
152 {
153 value *new_value= new_val(env);
154
155 new_value->content.i= in_val;
156 new_value->type= integer;
157
158 push_val(env, new_value);
159 }
160
161
162 /* Push a floating point number onto the stack */
163 void push_float(environment *env, float in_val)
164 {
165 value *new_value= new_val(env);
166
167 new_value->content.f= in_val;
168 new_value->type= tfloat;
169
170 push_val(env, new_value);
171 }
172
173
174 /* Copy a string onto the stack. */
175 void push_cstring(environment *env, const char *in_string)
176 {
177 value *new_value= new_val(env);
178 int length= strlen(in_string)+1;
179
180 new_value->content.string= malloc(length);
181 assert(new_value != NULL);
182 env->gc_count += length;
183 strcpy(new_value->content.string, in_string);
184 new_value->type= string;
185
186 push_val(env, new_value);
187 }
188
189
190 /* Mangle a symbol name to a valid C identifier name */
191 char *mangle_str(const char *old_string)
192 {
193 char validchars[]= "0123456789abcdef";
194 char *new_string, *current;
195
196 new_string= malloc((strlen(old_string)*2)+4);
197 assert(new_string != NULL);
198 strcpy(new_string, "sx_"); /* Stack eXternal */
199 current= new_string+3;
200
201 while(old_string[0] != '\0'){
202 current[0]= validchars[(unsigned char)(old_string[0])/16];
203 current[1]= validchars[(unsigned char)(old_string[0])%16];
204 current+= 2;
205 old_string++;
206 }
207 current[0]= '\0';
208
209 return new_string; /* The caller must free() it */
210 }
211
212
213 /* Push a symbol onto the stack. */
214 void push_sym(environment *env, const char *in_string)
215 {
216 value *new_value; /* A new symbol value */
217 /* ...which might point to... */
218 symbol **new_symbol; /* (if needed) A new actual symbol */
219 /* ...which, if possible, will be bound to... */
220 value *new_fvalue; /* (if needed) A new function value */
221 /* ...which will point to... */
222 void *funcptr; /* A function pointer */
223
224 static void *handle= NULL; /* Dynamic linker handle */
225 const char *dlerr; /* Dynamic linker error */
226 char *mangled; /* Mangled function name */
227
228 new_value= new_val(env);
229 new_fvalue= new_val(env);
230
231 /* The new value is a symbol */
232 new_value->type= symb;
233
234 /* Look up the symbol name in the hash table */
235 new_symbol= hash(env->symbols, in_string);
236 new_value->content.sym= *new_symbol;
237
238 if(*new_symbol==NULL) { /* If symbol was undefined */
239
240 /* Create a new symbol */
241 (*new_symbol)= malloc(sizeof(symbol));
242 assert((*new_symbol) != NULL);
243 (*new_symbol)->val= NULL; /* undefined value */
244 (*new_symbol)->next= NULL;
245 (*new_symbol)->id= malloc(strlen(in_string)+1);
246 assert((*new_symbol)->id != NULL);
247 strcpy((*new_symbol)->id, in_string);
248
249 /* Intern the new symbol in the hash table */
250 new_value->content.sym= *new_symbol;
251
252 /* Try to load the symbol name as an external function, to see if
253 we should bind the symbol to a new function pointer value */
254 if(handle==NULL) /* If no handle */
255 handle= dlopen(NULL, RTLD_LAZY);
256
257 mangled= mangle_str(in_string); /* mangle the name */
258 funcptr= dlsym(handle, mangled); /* and try to find it */
259
260 dlerr= dlerror();
261 if(dlerr != NULL) { /* If no function was found */
262 funcptr= dlsym(handle, in_string); /* Get function pointer */
263 dlerr= dlerror();
264 }
265
266 if(dlerr==NULL) { /* If a function was found */
267 new_fvalue->type= func; /* The new value is a function pointer */
268 new_fvalue->content.func= funcptr; /* Store function pointer */
269 (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
270 function value */
271 }
272
273 free(mangled);
274 }
275
276 push_val(env, new_value);
277 }
278
279
280 /* Print a value */
281 void print_val(environment *env, value *val, int noquote, stackitem *stack,
282 FILE *stream)
283 {
284 stackitem *titem, *tstack;
285 int depth;
286
287 switch(val->type) {
288 case empty:
289 if(fprintf(stream, "[]") < 0)
290 env->err= 5;
291 break;
292 case unknown:
293 if(fprintf(stream, "UNKNOWN") < 0)
294 env->err= 5;
295 break;
296 case integer:
297 if(fprintf(stream, "%d", val->content.i) < 0)
298 env->err= 5;
299 break;
300 case tfloat:
301 if(fprintf(stream, "%f", val->content.f) < 0)
302 env->err= 5;
303 break;
304 case string:
305 if(noquote){
306 if(fprintf(stream, "%s", val->content.string) < 0)
307 env->err= 5;
308 } else { /* quote */
309 if(fprintf(stream, "\"%s\"", val->content.string) < 0)
310 env->err= 5;
311 }
312 break;
313 case symb:
314 if(fprintf(stream, "%s", val->content.sym->id) < 0)
315 env->err= 5;
316 break;
317 case func:
318 if(fprintf(stream, "#<function %p>", val->content.func) < 0)
319 env->err= 5;
320 break;
321 case port:
322 if(fprintf(stream, "#<port %p>", val->content.p) < 0)
323 env->err= 5;
324 break;
325 case tcons:
326 if(fprintf(stream, "[ ") < 0) {
327 env->err= 5;
328 return printerr(env);
329 }
330 tstack= stack;
331
332 do {
333 titem=malloc(sizeof(stackitem));
334 assert(titem != NULL);
335 titem->item=val;
336 titem->next=tstack;
337 tstack=titem; /* Put it on the stack */
338 /* Search a stack of values being printed to see if we are already
339 printing this value */
340 titem=tstack;
341 depth=0;
342
343 while(titem != NULL && titem->item != CAR(val)){
344 titem=titem->next;
345 depth++;
346 }
347
348 if(titem != NULL){ /* If we found it on the stack, */
349 if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
350 env->err= 5;
351 free(titem);
352 return printerr(env);
353 }
354 } else {
355 print_val(env, CAR(val), noquote, tstack, stream);
356 }
357
358 val= CDR(val);
359 switch(val->type){
360 case empty:
361 break;
362 case tcons:
363 /* Search a stack of values being printed to see if we are already
364 printing this value */
365 titem=tstack;
366 depth=0;
367
368 while(titem != NULL && titem->item != val){
369 titem=titem->next;
370 depth++;
371 }
372 if(titem != NULL){ /* If we found it on the stack, */
373 if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
374 env->err= 5;
375 printerr(env);
376 goto printval_end;
377 }
378 } else {
379 if(fprintf(stream, " ") < 0){
380 env->err= 5;
381 printerr(env);
382 goto printval_end;
383 }
384 }
385 break;
386 default:
387 if(fprintf(stream, " . ") < 0){ /* Improper list */
388 env->err= 5;
389 printerr(env);
390 goto printval_end;
391 }
392 print_val(env, val, noquote, tstack, stream);
393 }
394 } while(val->type == tcons && titem == NULL);
395
396 printval_end:
397
398 titem=tstack;
399 while(titem != stack){
400 tstack=titem->next;
401 free(titem);
402 titem=tstack;
403 }
404
405 if(! (env->err)){
406 if(fprintf(stream, " ]") < 0){
407 env->err= 5;
408 }
409 }
410 break;
411 }
412
413 if(env->err)
414 return printerr(env);
415 }
416
417
418 /* Swap the two top elements on the stack. */
419 extern void swap(environment *env)
420 {
421 value *temp= env->head;
422
423 if(check_args(env, 2, unknown, unknown))
424 return printerr(env);
425
426 env->head= CDR(env->head);
427 CDR(temp)= CDR(env->head);
428 CDR(env->head)= temp;
429 }
430
431
432 /* Recall a value from a symbol, if bound */
433 extern void rcl(environment *env)
434 {
435 value *val;
436
437 if(check_args(env, 1, symb))
438 return printerr(env);
439
440 val= CAR(env->head)->content.sym->val;
441 if(val == NULL){
442 env->err= 3;
443 return printerr(env);
444 }
445
446 push_val(env, val); /* Return the symbol's bound value */
447 swap(env);
448 if(env->err) return;
449 env->head= CDR(env->head);
450 }
451
452
453 /* If the top element is a symbol, determine if it's bound to a
454 function value, and if it is, toss the symbol and execute the
455 function. */
456 extern void eval(environment *env)
457 {
458 funcp in_func;
459 value* temp_val;
460 value* iterator;
461
462 eval_start:
463
464 gc_maybe(env);
465
466 if(check_args(env, 1, unknown))
467 return printerr(env);
468
469 switch(CAR(env->head)->type) {
470 /* if it's a symbol */
471 case symb:
472 env->errsymb= CAR(env->head)->content.sym->id;
473 rcl(env); /* get its contents */
474 if(env->err) return;
475 if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
476 goto eval_start;
477 }
478 return;
479
480 /* If it's a lone function value, run it */
481 case func:
482 in_func= CAR(env->head)->content.func;
483 env->head= CDR(env->head);
484 return in_func((void*)env);
485
486 /* If it's a list */
487 case tcons:
488 temp_val= CAR(env->head);
489 protect(temp_val);
490
491 env->head= CDR(env->head);
492 iterator= temp_val;
493
494 while(iterator->type != empty) {
495 push_val(env, CAR(iterator));
496
497 if(CAR(env->head)->type==symb
498 && CAR(env->head)->content.sym->id[0]==';') {
499 env->head= CDR(env->head);
500
501 if(CDR(iterator)->type == empty){
502 goto eval_start;
503 }
504 eval(env);
505 if(env->err) return;
506 }
507 if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
508 iterator= CDR(iterator);
509 else {
510 env->err= 2; /* Improper list */
511 return printerr(env);
512 }
513 }
514 unprotect(temp_val);
515 return;
516
517 case empty:
518 env->head= CDR(env->head);
519 case integer:
520 case tfloat:
521 case string:
522 case port:
523 case unknown:
524 return;
525 }
526 }
527
528
529 /* Internal forget function */
530 void forget_sym(symbol **hash_entry)
531 {
532 symbol *temp;
533
534 temp= *hash_entry;
535 *hash_entry= (*hash_entry)->next;
536
537 free(temp->id);
538 free(temp);
539 }
540
541
542 int main(int argc, char **argv)
543 {
544 environment myenv;
545 int c; /* getopt option character */
546
547 #ifdef __linux__
548 mtrace();
549 #endif
550
551 init_env(&myenv);
552
553 myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO);
554
555 while ((c = getopt (argc, argv, "i")) != -1)
556 switch (c)
557 {
558 case 'i':
559 myenv.interactive = 1;
560 break;
561 case '?':
562 fprintf (stderr,
563 "Unknown option character '\\x%x'.\n",
564 optopt);
565 return EX_USAGE;
566 default:
567 abort ();
568 }
569
570 if (optind < argc) {
571 myenv.interactive = 0;
572 myenv.inputstream= fopen(argv[optind], "r");
573 if(myenv.inputstream== NULL) {
574 perror(argv[0]);
575 exit (EX_NOINPUT);
576 }
577 }
578
579 if(myenv.interactive)
580 puts(start_message);
581
582 while(1) {
583 if(myenv.in_string==NULL) {
584 if (myenv.interactive) {
585 if(myenv.err) {
586 printf("(error %d)\n", myenv.err);
587 myenv.err= 0;
588 }
589 printf("\n");
590 printstack(&myenv);
591 printf("> ");
592 }
593 myenv.err=0;
594 }
595 readstream(&myenv, myenv.inputstream);
596 if (myenv.err) { /* EOF or other error */
597 myenv.err=0;
598 quit(&myenv);
599 } else if(myenv.head->type!=empty
600 && CAR(myenv.head)->type==symb
601 && CAR(myenv.head)->content.sym->id[0] == ';') {
602 if(myenv.head->type != empty)
603 myenv.head= CDR(myenv.head);
604 eval(&myenv);
605 } else {
606 gc_maybe(&myenv);
607 }
608 }
609 quit(&myenv);
610 return EXIT_FAILURE;
611 }
612
613
614 /* Return copy of a value */
615 value *copy_val(environment *env, value *old_value)
616 {
617 value *new_value;
618
619 if(old_value==NULL)
620 return NULL;
621
622 new_value= new_val(env);
623 new_value->type= old_value->type;
624
625 switch(old_value->type){
626 case tfloat:
627 case integer:
628 case func:
629 case symb:
630 case empty:
631 case unknown:
632 case port:
633 new_value->content= old_value->content;
634 break;
635 case string:
636 new_value->content.string= strdup(old_value->content.string);
637 break;
638 case tcons:
639
640 new_value->content.c= malloc(sizeof(pair));
641 assert(new_value->content.c!=NULL);
642 env->gc_count += sizeof(pair);
643
644 CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
645 CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
646 break;
647 }
648
649 return new_value;
650 }
651
652
653 /* read a line from a stream; used by readline */
654 void readlinestream(environment *env, FILE *stream)
655 {
656 char in_string[101];
657
658 if(fgets(in_string, 100, stream)==NULL) {
659 push_cstring(env, "");
660 if (! feof(stream)){
661 env->err= 5;
662 return printerr(env);
663 }
664 } else {
665 push_cstring(env, in_string);
666 }
667 }
668
669
670 /* Reverse (flip) a list */
671 extern void rev(environment *env)
672 {
673 value *old_head, *new_head, *item;
674
675 if(CAR(env->head)->type==empty)
676 return; /* Don't reverse an empty list */
677
678 if(check_args(env, 1, tcons))
679 return printerr(env);
680
681 old_head= CAR(env->head);
682 new_head= new_val(env);
683 while(old_head->type != empty) {
684 item= old_head;
685 old_head= CDR(old_head);
686 CDR(item)= new_head;
687 new_head= item;
688 }
689 CAR(env->head)= new_head;
690 }
691
692
693 /* Make a list. */
694 extern void pack(environment *env)
695 {
696 value *iterator, *temp, *ending;
697
698 ending=new_val(env);
699
700 iterator= env->head;
701 if(iterator->type == empty
702 || (CAR(iterator)->type==symb
703 && CAR(iterator)->content.sym->id[0]=='[')) {
704 temp= ending;
705 if(env->head->type != empty)
706 env->head= CDR(env->head);
707 } else {
708 /* Search for first delimiter */
709 while(CDR(iterator)->type != empty
710 && (CAR(CDR(iterator))->type!=symb
711 || CAR(CDR(iterator))->content.sym->id[0]!='['))
712 iterator= CDR(iterator);
713
714 /* Extract list */
715 temp= env->head;
716 env->head= CDR(iterator);
717 CDR(iterator)= ending;
718
719 if(env->head->type != empty)
720 env->head= CDR(env->head);
721 }
722
723 /* Push list */
724
725 push_val(env, temp);
726 rev(env);
727 }
728
729
730 /* read from a stream; used by "read" and "readport" */
731 void readstream(environment *env, FILE *stream)
732 {
733 const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
734 const char strform[]= "\"%[^\"]\"%n";
735 const char intform[]= "%i%n";
736 const char fltform[]= "%f%n";
737 const char blankform[]= "%*[ \t]%n";
738 const char ebrackform[]= "]%n";
739 const char semicform[]= ";%n";
740 const char bbrackform[]= "[%n";
741
742 int itemp, readlength= -1;
743 int count= -1;
744 float ftemp;
745 static int depth= 0;
746 char *match;
747 size_t inlength;
748
749 if(env->in_string==NULL) {
750 if(depth > 0 && env->interactive) {
751 printf("]> ");
752 }
753 readlinestream(env, env->inputstream);
754 if(env->err) return;
755
756 if((CAR(env->head)->content.string)[0]=='\0'){
757 env->err= 4; /* "" means EOF */
758 return;
759 }
760
761 env->in_string= malloc(strlen(CAR(env->head)->content.string)+1);
762 assert(env->in_string != NULL);
763 env->free_string= env->in_string; /* Save the original pointer */
764 strcpy(env->in_string, CAR(env->head)->content.string);
765 env->head= CDR(env->head);
766 }
767
768 inlength= strlen(env->in_string)+1;
769 match= malloc(inlength);
770 assert(match != NULL);
771
772 if(sscanf(env->in_string, blankform, &readlength) != EOF
773 && readlength != -1) {
774 ;
775 } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
776 && readlength != -1) {
777 if(sscanf(env->in_string, intform, &itemp, &count) != EOF
778 && count==readlength) {
779 push_int(env, itemp);
780 } else {
781 push_float(env, ftemp);
782 }
783 } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
784 && readlength != -1) {
785 push_cstring(env, "");
786 } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
787 && readlength != -1) {
788 push_cstring(env, match);
789 } else if(sscanf(env->in_string, symbform, match, &readlength) != EOF
790 && readlength != -1) {
791 push_sym(env, match);
792 } else if(sscanf(env->in_string, ebrackform, &readlength) != EOF
793 && readlength != -1) {
794 pack(env); if(env->err) return;
795 if(depth != 0) depth--;
796 } else if(sscanf(env->in_string, semicform, &readlength) != EOF
797 && readlength != -1) {
798 push_sym(env, ";");
799 } else if(sscanf(env->in_string, bbrackform, &readlength) != EOF
800 && readlength != -1) {
801 push_sym(env, "[");
802 depth++;
803 } else {
804 free(env->free_string);
805 env->in_string = env->free_string = NULL;
806 }
807 if (env->in_string != NULL) {
808 env->in_string += readlength;
809 }
810
811 free(match);
812
813 if(depth)
814 return readstream(env, env->inputstream);
815 }
816
817
818 int check_args(environment *env, int num_args, ...)
819 {
820 va_list ap;
821 enum type_enum mytype;
822 int i;
823
824 value *iter= env->head;
825 int errval= 0;
826
827 va_start(ap, num_args);
828 for(i=1; i<=num_args; i++) {
829 mytype= va_arg(ap, enum type_enum);
830 // fprintf(stderr, "%s\n", env->errsymb);
831
832 if(iter->type==empty || iter==NULL) {
833 errval= 1;
834 break;
835 }
836
837 if(mytype!=unknown && CAR(iter)->type!=mytype) {
838 errval= 2;
839 break;
840 }
841
842 iter= CDR(iter);
843 }
844
845 va_end(ap);
846
847 env->err= errval;
848 return errval;
849 }

root@recompile.se
ViewVC Help
Powered by ViewVC 1.1.26