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

Contents of /stack/stack.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.136 - (show annotations)
Mon Aug 18 14:39:16 2003 UTC (20 years, 8 months ago) by masse
Branch: MAIN
Changes since 1.135: +32 -64 lines
File MIME type: text/plain
stack.c (printerr): Modified to accept error type 5.
(check_args): Modified to accept "empty" as argument.
symbols.c: New symbols (sx_72616e646f6d), (seed), (ticks), (push) and (pop).

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.135 $\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 /* Mark values recursively.
136 Marked values are not collected by the GC. */
137 inline void gc_mark(value *val)
138 {
139 if(val==NULL || val->gc.flag.mark)
140 return;
141
142 val->gc.flag.mark= 1;
143
144 if(val->type==tcons) {
145 gc_mark(CAR(val));
146 gc_mark(CDR(val));
147 }
148 }
149
150
151 /* Start GC */
152 extern void gc_init(environment *env)
153 {
154 stackitem *new_head= NULL, *titem;
155 symbol *tsymb;
156 int i;
157
158 if(env->interactive)
159 printf("Garbage collecting.");
160
161 /* Mark values on stack */
162 gc_mark(env->head);
163
164 if(env->interactive)
165 printf(".");
166
167 /* Mark values in hashtable */
168 for(i= 0; i<HASHTBLSIZE; i++)
169 for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
170 if (tsymb->val != NULL)
171 gc_mark(tsymb->val);
172
173 if(env->interactive)
174 printf(".");
175
176 env->gc_count= 0;
177
178 while(env->gc_ref!=NULL) { /* Sweep unused values */
179 if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
180
181 /* Remove content */
182 switch(env->gc_ref->item->type){
183 case string:
184 free(env->gc_ref->item->content.string);
185 break;
186 case tcons:
187 free(env->gc_ref->item->content.c);
188 break;
189 case port:
190 case empty:
191 case unknown:
192 case integer:
193 case tfloat:
194 case func:
195 case symb:
196 /* Symbol strings are freed when walking the hash table */
197 break;
198 }
199
200 free(env->gc_ref->item); /* Remove from gc_ref */
201 titem= env->gc_ref->next;
202 free(env->gc_ref); /* Remove value */
203 env->gc_ref= titem;
204 continue;
205 }
206
207 #ifdef DEBUG
208 printf("Kept value (%p)", env->gc_ref->item);
209 if(env->gc_ref->item->gc.flag.mark)
210 printf(" (marked)");
211 if(env->gc_ref->item->gc.flag.protect)
212 printf(" (protected)");
213 switch(env->gc_ref->item->type){
214 case integer:
215 printf(" integer: %d", env->gc_ref->item->content.i);
216 break;
217 case func:
218 printf(" func: %p", env->gc_ref->item->content.func);
219 break;
220 case symb:
221 printf(" symb: %s", env->gc_ref->item->content.sym->id);
222 break;
223 case tcons:
224 printf(" tcons: %p\t%p", CAR(env->gc_ref->item),
225 CDR(env->gc_ref->item));
226 break;
227 default:
228 printf(" <unknown %d>", (env->gc_ref->item->type));
229 }
230 printf("\n");
231 #endif /* DEBUG */
232
233 /* Keep values */
234 env->gc_count += sizeof(value);
235 if(env->gc_ref->item->type==string)
236 env->gc_count += strlen(env->gc_ref->item->content.string)+1;
237
238 titem= env->gc_ref->next;
239 env->gc_ref->next= new_head;
240 new_head= env->gc_ref;
241 new_head->item->gc.flag.mark= 0;
242 env->gc_ref= titem;
243 }
244
245 if (env->gc_limit < env->gc_count*2)
246 env->gc_limit= env->gc_count*2;
247
248 env->gc_ref= new_head;
249
250 if(env->interactive)
251 printf("done (%d bytes still allocated)\n", env->gc_count);
252
253 }
254
255
256 inline void gc_maybe(environment *env)
257 {
258 if(env->gc_count < env->gc_limit)
259 return;
260 else
261 return gc_init(env);
262 }
263
264
265 /* Protect values from GC */
266 void protect(value *val)
267 {
268 if(val==NULL || val->gc.flag.protect)
269 return;
270
271 val->gc.flag.protect= 1;
272
273 if(val->type==tcons) {
274 protect(CAR(val));
275 protect(CDR(val));
276 }
277 }
278
279
280 /* Unprotect values from GC */
281 void unprotect(value *val)
282 {
283 if(val==NULL || !(val->gc.flag.protect))
284 return;
285
286 val->gc.flag.protect= 0;
287
288 if(val->type==tcons) {
289 unprotect(CAR(val));
290 unprotect(CDR(val));
291 }
292 }
293
294
295 /* Push a value onto the stack */
296 void push_val(environment *env, value *val)
297 {
298 value *new_value= new_val(env);
299
300 new_value->content.c= malloc(sizeof(pair));
301 assert(new_value->content.c!=NULL);
302 env->gc_count += sizeof(pair);
303 new_value->type= tcons;
304 CAR(new_value)= val;
305 CDR(new_value)= env->head;
306 env->head= new_value;
307 }
308
309
310 /* Push an integer onto the stack */
311 void push_int(environment *env, int in_val)
312 {
313 value *new_value= new_val(env);
314
315 new_value->content.i= in_val;
316 new_value->type= integer;
317
318 push_val(env, new_value);
319 }
320
321
322 /* Push a floating point number onto the stack */
323 void push_float(environment *env, float in_val)
324 {
325 value *new_value= new_val(env);
326
327 new_value->content.f= in_val;
328 new_value->type= tfloat;
329
330 push_val(env, new_value);
331 }
332
333
334 /* Copy a string onto the stack. */
335 void push_cstring(environment *env, const char *in_string)
336 {
337 value *new_value= new_val(env);
338 int length= strlen(in_string)+1;
339
340 new_value->content.string= malloc(length);
341 assert(new_value != NULL);
342 env->gc_count += length;
343 strcpy(new_value->content.string, in_string);
344 new_value->type= string;
345
346 push_val(env, new_value);
347 }
348
349
350 /* Mangle a symbol name to a valid C identifier name */
351 char *mangle_str(const char *old_string)
352 {
353 char validchars[]= "0123456789abcdef";
354 char *new_string, *current;
355
356 new_string= malloc((strlen(old_string)*2)+4);
357 assert(new_string != NULL);
358 strcpy(new_string, "sx_"); /* Stack eXternal */
359 current= new_string+3;
360
361 while(old_string[0] != '\0'){
362 current[0]= validchars[(unsigned char)(old_string[0])/16];
363 current[1]= validchars[(unsigned char)(old_string[0])%16];
364 current+= 2;
365 old_string++;
366 }
367 current[0]= '\0';
368
369 return new_string; /* The caller must free() it */
370 }
371
372
373 /* Push a symbol onto the stack. */
374 void push_sym(environment *env, const char *in_string)
375 {
376 value *new_value; /* A new symbol value */
377 /* ...which might point to... */
378 symbol **new_symbol; /* (if needed) A new actual symbol */
379 /* ...which, if possible, will be bound to... */
380 value *new_fvalue; /* (if needed) A new function value */
381 /* ...which will point to... */
382 void *funcptr; /* A function pointer */
383
384 static void *handle= NULL; /* Dynamic linker handle */
385 const char *dlerr; /* Dynamic linker error */
386 char *mangled; /* Mangled function name */
387
388 new_value= new_val(env);
389 new_fvalue= new_val(env);
390
391 /* The new value is a symbol */
392 new_value->type= symb;
393
394 /* Look up the symbol name in the hash table */
395 new_symbol= hash(env->symbols, in_string);
396 new_value->content.sym= *new_symbol;
397
398 if(*new_symbol==NULL) { /* If symbol was undefined */
399
400 /* Create a new symbol */
401 (*new_symbol)= malloc(sizeof(symbol));
402 assert((*new_symbol) != NULL);
403 (*new_symbol)->val= NULL; /* undefined value */
404 (*new_symbol)->next= NULL;
405 (*new_symbol)->id= malloc(strlen(in_string)+1);
406 assert((*new_symbol)->id != NULL);
407 strcpy((*new_symbol)->id, in_string);
408
409 /* Intern the new symbol in the hash table */
410 new_value->content.sym= *new_symbol;
411
412 /* Try to load the symbol name as an external function, to see if
413 we should bind the symbol to a new function pointer value */
414 if(handle==NULL) /* If no handle */
415 handle= dlopen(NULL, RTLD_LAZY);
416
417 mangled= mangle_str(in_string); /* mangle the name */
418 funcptr= dlsym(handle, mangled); /* and try to find it */
419
420 dlerr= dlerror();
421 if(dlerr != NULL) { /* If no function was found */
422 funcptr= dlsym(handle, in_string); /* Get function pointer */
423 dlerr= dlerror();
424 }
425
426 if(dlerr==NULL) { /* If a function was found */
427 new_fvalue->type= func; /* The new value is a function pointer */
428 new_fvalue->content.func= funcptr; /* Store function pointer */
429 (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
430 function value */
431 }
432
433 free(mangled);
434 }
435
436 push_val(env, new_value);
437 }
438
439
440 /* Print a value */
441 void print_val(environment *env, value *val, int noquote, stackitem *stack,
442 FILE *stream)
443 {
444 stackitem *titem, *tstack;
445 int depth;
446
447 switch(val->type) {
448 case empty:
449 if(fprintf(stream, "[]") < 0)
450 env->err= 5;
451 break;
452 case unknown:
453 if(fprintf(stream, "UNKNOWN") < 0)
454 env->err= 5;
455 break;
456 case integer:
457 if(fprintf(stream, "%d", val->content.i) < 0)
458 env->err= 5;
459 break;
460 case tfloat:
461 if(fprintf(stream, "%f", val->content.f) < 0)
462 env->err= 5;
463 break;
464 case string:
465 if(noquote){
466 if(fprintf(stream, "%s", val->content.string) < 0)
467 env->err= 5;
468 } else { /* quote */
469 if(fprintf(stream, "\"%s\"", val->content.string) < 0)
470 env->err= 5;
471 }
472 break;
473 case symb:
474 if(fprintf(stream, "%s", val->content.sym->id) < 0)
475 env->err= 5;
476 break;
477 case func:
478 if(fprintf(stream, "#<function %p>", val->content.func) < 0)
479 env->err= 5;
480 break;
481 case port:
482 if(fprintf(stream, "#<port %p>", val->content.p) < 0)
483 env->err= 5;
484 break;
485 case tcons:
486 if(fprintf(stream, "[ ") < 0) {
487 env->err= 5;
488 return printerr(env);
489 }
490 tstack= stack;
491
492 do {
493 titem=malloc(sizeof(stackitem));
494 assert(titem != NULL);
495 titem->item=val;
496 titem->next=tstack;
497 tstack=titem; /* Put it on the stack */
498 /* Search a stack of values being printed to see if we are already
499 printing this value */
500 titem=tstack;
501 depth=0;
502
503 while(titem != NULL && titem->item != CAR(val)){
504 titem=titem->next;
505 depth++;
506 }
507
508 if(titem != NULL){ /* If we found it on the stack, */
509 if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
510 env->err= 5;
511 free(titem);
512 return printerr(env);
513 }
514 } else {
515 print_val(env, CAR(val), noquote, tstack, stream);
516 }
517
518 val= CDR(val);
519 switch(val->type){
520 case empty:
521 break;
522 case tcons:
523 /* Search a stack of values being printed to see if we are already
524 printing this value */
525 titem=tstack;
526 depth=0;
527
528 while(titem != NULL && titem->item != val){
529 titem=titem->next;
530 depth++;
531 }
532 if(titem != NULL){ /* If we found it on the stack, */
533 if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
534 env->err= 5;
535 printerr(env);
536 goto printval_end;
537 }
538 } else {
539 if(fprintf(stream, " ") < 0){
540 env->err= 5;
541 printerr(env);
542 goto printval_end;
543 }
544 }
545 break;
546 default:
547 if(fprintf(stream, " . ") < 0){ /* Improper list */
548 env->err= 5;
549 printerr(env);
550 goto printval_end;
551 }
552 print_val(env, val, noquote, tstack, stream);
553 }
554 } while(val->type == tcons && titem == NULL);
555
556 printval_end:
557
558 titem=tstack;
559 while(titem != stack){
560 tstack=titem->next;
561 free(titem);
562 titem=tstack;
563 }
564
565 if(! (env->err)){
566 if(fprintf(stream, " ]") < 0){
567 env->err= 5;
568 }
569 }
570 break;
571 }
572
573 if(env->err)
574 return printerr(env);
575 }
576
577
578 /* Swap the two top elements on the stack. */
579 extern void swap(environment *env)
580 {
581 value *temp= env->head;
582
583 if(check_args(env, 2, unknown, unknown))
584 return printerr(env);
585
586 env->head= CDR(env->head);
587 CDR(temp)= CDR(env->head);
588 CDR(env->head)= temp;
589 }
590
591
592 /* Recall a value from a symbol, if bound */
593 extern void rcl(environment *env)
594 {
595 value *val;
596
597 if(check_args(env, 1, symb))
598 return printerr(env);
599
600 val= CAR(env->head)->content.sym->val;
601 if(val == NULL){
602 env->err= 3;
603 return printerr(env);
604 }
605
606 push_val(env, val); /* Return the symbol's bound value */
607 swap(env);
608 if(env->err) return;
609 env->head= CDR(env->head);
610 }
611
612
613 /* If the top element is a symbol, determine if it's bound to a
614 function value, and if it is, toss the symbol and execute the
615 function. */
616 extern void eval(environment *env)
617 {
618 funcp in_func;
619 value* temp_val;
620 value* iterator;
621
622 eval_start:
623
624 gc_maybe(env);
625
626 if(check_args(env, 1, unknown))
627 return printerr(env);
628
629 switch(CAR(env->head)->type) {
630 /* if it's a symbol */
631 case symb:
632 env->errsymb= CAR(env->head)->content.sym->id;
633 rcl(env); /* get its contents */
634 if(env->err) return;
635 if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
636 goto eval_start;
637 }
638 return;
639
640 /* If it's a lone function value, run it */
641 case func:
642 in_func= CAR(env->head)->content.func;
643 env->head= CDR(env->head);
644 return in_func((void*)env);
645
646 /* If it's a list */
647 case tcons:
648 temp_val= CAR(env->head);
649 protect(temp_val);
650
651 env->head= CDR(env->head);
652 iterator= temp_val;
653
654 while(iterator->type != empty) {
655 push_val(env, CAR(iterator));
656
657 if(CAR(env->head)->type==symb
658 && CAR(env->head)->content.sym->id[0]==';') {
659 env->head= CDR(env->head);
660
661 if(CDR(iterator)->type == empty){
662 goto eval_start;
663 }
664 eval(env);
665 if(env->err) return;
666 }
667 if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
668 iterator= CDR(iterator);
669 else {
670 env->err= 2; /* Improper list */
671 return printerr(env);
672 }
673 }
674 unprotect(temp_val);
675 return;
676
677 case empty:
678 env->head= CDR(env->head);
679 case integer:
680 case tfloat:
681 case string:
682 case port:
683 case unknown:
684 return;
685 }
686 }
687
688
689 /* Internal forget function */
690 void forget_sym(symbol **hash_entry)
691 {
692 symbol *temp;
693
694 temp= *hash_entry;
695 *hash_entry= (*hash_entry)->next;
696
697 free(temp->id);
698 free(temp);
699 }
700
701
702 int main(int argc, char **argv)
703 {
704 environment myenv;
705 int c; /* getopt option character */
706
707 #ifdef __linux__
708 mtrace();
709 #endif
710
711 init_env(&myenv);
712
713 myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO);
714
715 while ((c = getopt (argc, argv, "i")) != -1)
716 switch (c)
717 {
718 case 'i':
719 myenv.interactive = 1;
720 break;
721 case '?':
722 fprintf (stderr,
723 "Unknown option character '\\x%x'.\n",
724 optopt);
725 return EX_USAGE;
726 default:
727 abort ();
728 }
729
730 if (optind < argc) {
731 myenv.interactive = 0;
732 myenv.inputstream= fopen(argv[optind], "r");
733 if(myenv.inputstream== NULL) {
734 perror(argv[0]);
735 exit (EX_NOINPUT);
736 }
737 }
738
739 if(myenv.interactive)
740 puts(start_message);
741
742 while(1) {
743 if(myenv.in_string==NULL) {
744 if (myenv.interactive) {
745 if(myenv.err) {
746 printf("(error %d)\n", myenv.err);
747 myenv.err= 0;
748 }
749 printf("\n");
750 printstack(&myenv);
751 printf("> ");
752 }
753 myenv.err=0;
754 }
755 readstream(&myenv, myenv.inputstream);
756 if (myenv.err) { /* EOF or other error */
757 myenv.err=0;
758 quit(&myenv);
759 } else if(myenv.head->type!=empty
760 && CAR(myenv.head)->type==symb
761 && CAR(myenv.head)->content.sym->id[0] == ';') {
762 if(myenv.head->type != empty)
763 myenv.head= CDR(myenv.head);
764 eval(&myenv);
765 } else {
766 gc_maybe(&myenv);
767 }
768 }
769 quit(&myenv);
770 return EXIT_FAILURE;
771 }
772
773
774 /* Return copy of a value */
775 value *copy_val(environment *env, value *old_value)
776 {
777 value *new_value;
778
779 if(old_value==NULL)
780 return NULL;
781
782 new_value= new_val(env);
783 new_value->type= old_value->type;
784
785 switch(old_value->type){
786 case tfloat:
787 case integer:
788 case func:
789 case symb:
790 case empty:
791 case unknown:
792 case port:
793 new_value->content= old_value->content;
794 break;
795 case string:
796 new_value->content.string= strdup(old_value->content.string);
797 break;
798 case tcons:
799
800 new_value->content.c= malloc(sizeof(pair));
801 assert(new_value->content.c!=NULL);
802 env->gc_count += sizeof(pair);
803
804 CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
805 CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
806 break;
807 }
808
809 return new_value;
810 }
811
812
813 /* read a line from a stream; used by readline */
814 void readlinestream(environment *env, FILE *stream)
815 {
816 char in_string[101];
817
818 if(fgets(in_string, 100, stream)==NULL) {
819 push_cstring(env, "");
820 if (! feof(stream)){
821 env->err= 5;
822 return printerr(env);
823 }
824 } else {
825 push_cstring(env, in_string);
826 }
827 }
828
829
830 /* Reverse (flip) a list */
831 extern void rev(environment *env)
832 {
833 value *old_head, *new_head, *item;
834
835 if(CAR(env->head)->type==empty)
836 return; /* Don't reverse an empty list */
837
838 if(check_args(env, 1, tcons))
839 return printerr(env);
840
841 old_head= CAR(env->head);
842 new_head= new_val(env);
843 while(old_head->type != empty) {
844 item= old_head;
845 old_head= CDR(old_head);
846 CDR(item)= new_head;
847 new_head= item;
848 }
849 CAR(env->head)= new_head;
850 }
851
852
853 /* Make a list. */
854 extern void pack(environment *env)
855 {
856 value *iterator, *temp, *ending;
857
858 ending=new_val(env);
859
860 iterator= env->head;
861 if(iterator->type == empty
862 || (CAR(iterator)->type==symb
863 && CAR(iterator)->content.sym->id[0]=='[')) {
864 temp= ending;
865 if(env->head->type != empty)
866 env->head= CDR(env->head);
867 } else {
868 /* Search for first delimiter */
869 while(CDR(iterator)->type != empty
870 && (CAR(CDR(iterator))->type!=symb
871 || CAR(CDR(iterator))->content.sym->id[0]!='['))
872 iterator= CDR(iterator);
873
874 /* Extract list */
875 temp= env->head;
876 env->head= CDR(iterator);
877 CDR(iterator)= ending;
878
879 if(env->head->type != empty)
880 env->head= CDR(env->head);
881 }
882
883 /* Push list */
884
885 push_val(env, temp);
886 rev(env);
887 }
888
889
890 /* read from a stream; used by "read" and "readport" */
891 void readstream(environment *env, FILE *stream)
892 {
893 const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
894 const char strform[]= "\"%[^\"]\"%n";
895 const char intform[]= "%i%n";
896 const char fltform[]= "%f%n";
897 const char blankform[]= "%*[ \t]%n";
898 const char ebrackform[]= "]%n";
899 const char semicform[]= ";%n";
900 const char bbrackform[]= "[%n";
901
902 int itemp, readlength= -1;
903 int count= -1;
904 float ftemp;
905 static int depth= 0;
906 char *match;
907 size_t inlength;
908
909 if(env->in_string==NULL) {
910 if(depth > 0 && env->interactive) {
911 printf("]> ");
912 }
913 readlinestream(env, env->inputstream);
914 if(env->err) return;
915
916 if((CAR(env->head)->content.string)[0]=='\0'){
917 env->err= 4; /* "" means EOF */
918 return;
919 }
920
921 env->in_string= malloc(strlen(CAR(env->head)->content.string)+1);
922 assert(env->in_string != NULL);
923 env->free_string= env->in_string; /* Save the original pointer */
924 strcpy(env->in_string, CAR(env->head)->content.string);
925 env->head= CDR(env->head);
926 }
927
928 inlength= strlen(env->in_string)+1;
929 match= malloc(inlength);
930 assert(match != NULL);
931
932 if(sscanf(env->in_string, blankform, &readlength) != EOF
933 && readlength != -1) {
934 ;
935 } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
936 && readlength != -1) {
937 if(sscanf(env->in_string, intform, &itemp, &count) != EOF
938 && count==readlength) {
939 push_int(env, itemp);
940 } else {
941 push_float(env, ftemp);
942 }
943 } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
944 && readlength != -1) {
945 push_cstring(env, "");
946 } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
947 && readlength != -1) {
948 push_cstring(env, match);
949 } else if(sscanf(env->in_string, symbform, match, &readlength) != EOF
950 && readlength != -1) {
951 push_sym(env, match);
952 } else if(sscanf(env->in_string, ebrackform, &readlength) != EOF
953 && readlength != -1) {
954 pack(env); if(env->err) return;
955 if(depth != 0) depth--;
956 } else if(sscanf(env->in_string, semicform, &readlength) != EOF
957 && readlength != -1) {
958 push_sym(env, ";");
959 } else if(sscanf(env->in_string, bbrackform, &readlength) != EOF
960 && readlength != -1) {
961 push_sym(env, "[");
962 depth++;
963 } else {
964 free(env->free_string);
965 env->in_string = env->free_string = NULL;
966 }
967 if (env->in_string != NULL) {
968 env->in_string += readlength;
969 }
970
971 free(match);
972
973 if(depth)
974 return readstream(env, env->inputstream);
975 }
976
977
978 int check_args(environment *env, int num_args, ...)
979 {
980 va_list ap;
981 enum type_enum mytype;
982 int i;
983
984 value *iter= env->head;
985 int errval= 0;
986
987 va_start(ap, num_args);
988 for(i=1; i<=num_args; i++) {
989 mytype= va_arg(ap, enum type_enum);
990 // fprintf(stderr, "%s\n", env->errsymb);
991
992 if(iter->type==empty || iter==NULL) {
993 errval= 1;
994 break;
995 }
996
997 if(mytype!=unknown && CAR(iter)->type!=mytype) {
998 errval= 2;
999 break;
1000 }
1001
1002 iter= CDR(iter);
1003 }
1004
1005 va_end(ap);
1006
1007 env->err= errval;
1008 return errval;
1009 }

root@recompile.se
ViewVC Help
Powered by ViewVC 1.1.26