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

Annotation of /stack/stack.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.136 - (hide 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 teddy 1.116 /* -*- coding: utf-8; -*- */
2 teddy 1.91 /*
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 teddy 1.88 #include "stack.h"
25 masse 1.1
26 masse 1.136 const char* start_message= "Stack version $Revision: 1.135 $\n\
27 masse 1.132 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 masse 1.136 under certain conditions; type 'copying;' for details.";
31 masse 1.132
32    
33 teddy 1.28 /* Initialize a newly created environment */
34     void init_env(environment *env)
35 masse 1.1 {
36 masse 1.46 int i;
37 masse 1.1
38 teddy 1.100 env->gc_limit= 400000;
39 masse 1.87 env->gc_count= 0;
40 masse 1.90 env->gc_ref= NULL;
41 masse 1.87
42 teddy 1.111 env->head= new_val(env);
43 masse 1.1 for(i= 0; i<HASHTBLSIZE; i++)
44 teddy 1.28 env->symbols[i]= NULL;
45 teddy 1.84 env->err= 0;
46     env->in_string= NULL;
47     env->free_string= NULL;
48     env->inputstream= stdin;
49     env->interactive= 1;
50 masse 1.1 }
51    
52 masse 1.132
53 masse 1.135 void printerr(environment *env)
54 masse 1.95 {
55 masse 1.135 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 masse 1.136 case 5:
70     return perror(env->errsymb);
71 masse 1.135 default:
72     in_string= "Unknown error";
73     break;
74     }
75    
76 masse 1.133 fprintf(stderr, "\"%s\":\nErr: %s\n", env->errsymb, in_string);
77 teddy 1.48 }
78    
79 masse 1.132
80 teddy 1.27 /* Returns a pointer to a pointer to an element in the hash table. */
81 teddy 1.28 symbol **hash(hashtbl in_hashtbl, const char *in_string)
82 masse 1.1 {
83 masse 1.46 int i= 0;
84     unsigned int out_hash= 0;
85 teddy 1.18 char key= '\0';
86 teddy 1.28 symbol **position;
87 masse 1.1
88 masse 1.16 while(1){ /* Hash in_string */
89 masse 1.1 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 masse 1.25 while(1){
99 teddy 1.18 if(*position==NULL) /* If empty */
100 masse 1.1 return position;
101    
102 teddy 1.18 if(strcmp(in_string, (*position)->id)==0) /* If match */
103 masse 1.1 return position;
104    
105 masse 1.16 position= &((*position)->next); /* Try next */
106 masse 1.1 }
107     }
108    
109 masse 1.132
110 masse 1.95 /* Create new value */
111     value* new_val(environment *env)
112     {
113 masse 1.87 value *nval= malloc(sizeof(value));
114     stackitem *nitem= malloc(sizeof(stackitem));
115    
116 teddy 1.118 assert(nval != NULL);
117     assert(nitem != NULL);
118    
119 masse 1.87 nval->content.ptr= NULL;
120 teddy 1.117 nval->type= empty;
121 masse 1.87
122     nitem->item= nval;
123     nitem->next= env->gc_ref;
124 masse 1.102
125 masse 1.87 env->gc_ref= nitem;
126    
127 teddy 1.101 env->gc_count += sizeof(value);
128 teddy 1.99 nval->gc.flag.mark= 0;
129     nval->gc.flag.protect= 0;
130 masse 1.93
131 masse 1.87 return nval;
132     }
133    
134 masse 1.126
135 masse 1.95 /* Mark values recursively.
136     Marked values are not collected by the GC. */
137 teddy 1.96 inline void gc_mark(value *val)
138 masse 1.95 {
139 masse 1.102 if(val==NULL || val->gc.flag.mark)
140 masse 1.87 return;
141    
142 teddy 1.99 val->gc.flag.mark= 1;
143 masse 1.87
144 masse 1.104 if(val->type==tcons) {
145     gc_mark(CAR(val));
146     gc_mark(CDR(val));
147 masse 1.87 }
148     }
149    
150 teddy 1.96
151 masse 1.95 /* Start GC */
152     extern void gc_init(environment *env)
153     {
154 masse 1.102 stackitem *new_head= NULL, *titem;
155 masse 1.87 symbol *tsymb;
156     int i;
157    
158 masse 1.102 if(env->interactive)
159 teddy 1.101 printf("Garbage collecting.");
160 teddy 1.100
161 masse 1.95 /* Mark values on stack */
162 masse 1.104 gc_mark(env->head);
163 masse 1.87
164 masse 1.102 if(env->interactive)
165 teddy 1.100 printf(".");
166 masse 1.102
167 masse 1.93 /* Mark values in hashtable */
168 masse 1.102 for(i= 0; i<HASHTBLSIZE; i++)
169     for(tsymb= env->symbols[i]; tsymb!=NULL; tsymb= tsymb->next)
170 masse 1.97 if (tsymb->val != NULL)
171     gc_mark(tsymb->val);
172 masse 1.87
173 masse 1.102 if(env->interactive)
174 teddy 1.100 printf(".");
175 masse 1.102
176 masse 1.87 env->gc_count= 0;
177    
178 masse 1.95 while(env->gc_ref!=NULL) { /* Sweep unused values */
179 teddy 1.99 if(!(env->gc_ref->item->gc.no_gc)){ /* neither mark nor protect */
180 masse 1.93
181 teddy 1.116 /* Remove content */
182     switch(env->gc_ref->item->type){
183     case string:
184 masse 1.130 free(env->gc_ref->item->content.string);
185 teddy 1.116 break;
186     case tcons:
187     free(env->gc_ref->item->content.c);
188     break;
189 teddy 1.124 case port:
190 teddy 1.116 case empty:
191 masse 1.133 case unknown:
192 teddy 1.116 case integer:
193     case tfloat:
194     case func:
195     case symb:
196     /* Symbol strings are freed when walking the hash table */
197 masse 1.126 break;
198 teddy 1.116 }
199 masse 1.102
200 masse 1.93 free(env->gc_ref->item); /* Remove from gc_ref */
201 masse 1.87 titem= env->gc_ref->next;
202 masse 1.93 free(env->gc_ref); /* Remove value */
203 masse 1.87 env->gc_ref= titem;
204 masse 1.97 continue;
205 teddy 1.110 }
206 masse 1.132
207 teddy 1.110 #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 masse 1.128 printf(" func: %p", env->gc_ref->item->content.func);
219 teddy 1.110 break;
220     case symb:
221     printf(" symb: %s", env->gc_ref->item->content.sym->id);
222     break;
223     case tcons:
224 masse 1.127 printf(" tcons: %p\t%p", CAR(env->gc_ref->item),
225     CDR(env->gc_ref->item));
226 teddy 1.110 break;
227     default:
228     printf(" <unknown %d>", (env->gc_ref->item->type));
229     }
230     printf("\n");
231     #endif /* DEBUG */
232 masse 1.102
233     /* Keep values */
234     env->gc_count += sizeof(value);
235     if(env->gc_ref->item->type==string)
236 masse 1.128 env->gc_count += strlen(env->gc_ref->item->content.string)+1;
237 masse 1.97
238     titem= env->gc_ref->next;
239     env->gc_ref->next= new_head;
240     new_head= env->gc_ref;
241 teddy 1.99 new_head->item->gc.flag.mark= 0;
242 masse 1.97 env->gc_ref= titem;
243 masse 1.87 }
244    
245 teddy 1.100 if (env->gc_limit < env->gc_count*2)
246     env->gc_limit= env->gc_count*2;
247 teddy 1.101
248 masse 1.87 env->gc_ref= new_head;
249 teddy 1.100
250 masse 1.102 if(env->interactive)
251 teddy 1.110 printf("done (%d bytes still allocated)\n", env->gc_count);
252 teddy 1.100
253 masse 1.87 }
254    
255 masse 1.132
256 masse 1.126 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 masse 1.132
265 masse 1.95 /* Protect values from GC */
266 masse 1.98 void protect(value *val)
267 masse 1.90 {
268 masse 1.102 if(val==NULL || val->gc.flag.protect)
269 masse 1.98 return;
270    
271 teddy 1.99 val->gc.flag.protect= 1;
272 masse 1.98
273 masse 1.104 if(val->type==tcons) {
274     protect(CAR(val));
275     protect(CDR(val));
276 masse 1.98 }
277 masse 1.90 }
278    
279 masse 1.132
280 masse 1.95 /* Unprotect values from GC */
281 masse 1.98 void unprotect(value *val)
282 masse 1.90 {
283 masse 1.102 if(val==NULL || !(val->gc.flag.protect))
284 masse 1.98 return;
285    
286 teddy 1.99 val->gc.flag.protect= 0;
287 masse 1.98
288 masse 1.104 if(val->type==tcons) {
289     unprotect(CAR(val));
290     unprotect(CDR(val));
291 masse 1.98 }
292 masse 1.90 }
293    
294 masse 1.132
295 teddy 1.29 /* Push a value onto the stack */
296 masse 1.72 void push_val(environment *env, value *val)
297 teddy 1.29 {
298 masse 1.104 value *new_value= new_val(env);
299 masse 1.102
300 teddy 1.115 new_value->content.c= malloc(sizeof(pair));
301 masse 1.108 assert(new_value->content.c!=NULL);
302 teddy 1.116 env->gc_count += sizeof(pair);
303 masse 1.104 new_value->type= tcons;
304     CAR(new_value)= val;
305     CDR(new_value)= env->head;
306     env->head= new_value;
307 teddy 1.29 }
308    
309 masse 1.132
310 masse 1.95 /* Push an integer onto the stack */
311 masse 1.72 void push_int(environment *env, int in_val)
312 masse 1.1 {
313 masse 1.87 value *new_value= new_val(env);
314 teddy 1.28
315 masse 1.93 new_value->content.i= in_val;
316 teddy 1.28 new_value->type= integer;
317 masse 1.1
318 masse 1.75 push_val(env, new_value);
319 masse 1.1 }
320    
321 masse 1.132
322 masse 1.95 /* Push a floating point number onto the stack */
323 masse 1.93 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 masse 1.132
334 masse 1.14 /* Copy a string onto the stack. */
335 masse 1.72 void push_cstring(environment *env, const char *in_string)
336 masse 1.1 {
337 masse 1.87 value *new_value= new_val(env);
338 teddy 1.101 int length= strlen(in_string)+1;
339 teddy 1.28
340 masse 1.128 new_value->content.string= malloc(length);
341 teddy 1.118 assert(new_value != NULL);
342 teddy 1.101 env->gc_count += length;
343 masse 1.128 strcpy(new_value->content.string, in_string);
344 teddy 1.28 new_value->type= string;
345 masse 1.1
346 masse 1.75 push_val(env, new_value);
347 masse 1.1 }
348    
349 masse 1.132
350 teddy 1.48 /* Mangle a symbol name to a valid C identifier name */
351 masse 1.95 char *mangle_str(const char *old_string)
352     {
353 masse 1.90 char validchars[]= "0123456789abcdef";
354 teddy 1.48 char *new_string, *current;
355    
356 masse 1.90 new_string= malloc((strlen(old_string)*2)+4);
357 teddy 1.118 assert(new_string != NULL);
358 teddy 1.48 strcpy(new_string, "sx_"); /* Stack eXternal */
359 masse 1.90 current= new_string+3;
360 masse 1.132
361 teddy 1.48 while(old_string[0] != '\0'){
362 masse 1.90 current[0]= validchars[(unsigned char)(old_string[0])/16];
363     current[1]= validchars[(unsigned char)(old_string[0])%16];
364     current+= 2;
365 teddy 1.48 old_string++;
366     }
367 masse 1.90 current[0]= '\0';
368 teddy 1.48
369     return new_string; /* The caller must free() it */
370     }
371    
372 masse 1.132
373 teddy 1.28 /* Push a symbol onto the stack. */
374 teddy 1.35 void push_sym(environment *env, const char *in_string)
375 masse 1.1 {
376 teddy 1.28 value *new_value; /* A new symbol value */
377     /* ...which might point to... */
378 teddy 1.29 symbol **new_symbol; /* (if needed) A new actual symbol */
379 teddy 1.28 /* ...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 teddy 1.48 const char *dlerr; /* Dynamic linker error */
386     char *mangled; /* Mangled function name */
387 teddy 1.28
388 masse 1.87 new_value= new_val(env);
389 masse 1.93 new_fvalue= new_val(env);
390 teddy 1.28
391     /* The new value is a symbol */
392     new_value->type= symb;
393    
394     /* Look up the symbol name in the hash table */
395 teddy 1.29 new_symbol= hash(env->symbols, in_string);
396 masse 1.130 new_value->content.sym= *new_symbol;
397 teddy 1.28
398 teddy 1.30 if(*new_symbol==NULL) { /* If symbol was undefined */
399 teddy 1.28
400     /* Create a new symbol */
401 teddy 1.30 (*new_symbol)= malloc(sizeof(symbol));
402 teddy 1.118 assert((*new_symbol) != NULL);
403 teddy 1.29 (*new_symbol)->val= NULL; /* undefined value */
404     (*new_symbol)->next= NULL;
405     (*new_symbol)->id= malloc(strlen(in_string)+1);
406 teddy 1.118 assert((*new_symbol)->id != NULL);
407 teddy 1.29 strcpy((*new_symbol)->id, in_string);
408 masse 1.1
409 teddy 1.28 /* Intern the new symbol in the hash table */
410 masse 1.130 new_value->content.sym= *new_symbol;
411 masse 1.1
412 teddy 1.28 /* 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 masse 1.16 if(handle==NULL) /* If no handle */
415 teddy 1.28 handle= dlopen(NULL, RTLD_LAZY);
416 masse 1.6
417 masse 1.90 mangled= mangle_str(in_string); /* mangle the name */
418 teddy 1.86 funcptr= dlsym(handle, mangled); /* and try to find it */
419 masse 1.95
420 masse 1.90 dlerr= dlerror();
421 teddy 1.48 if(dlerr != NULL) { /* If no function was found */
422 teddy 1.86 funcptr= dlsym(handle, in_string); /* Get function pointer */
423 masse 1.90 dlerr= dlerror();
424 teddy 1.48 }
425 masse 1.95
426 teddy 1.48 if(dlerr==NULL) { /* If a function was found */
427 masse 1.90 new_fvalue->type= func; /* The new value is a function pointer */
428 masse 1.128 new_fvalue->content.func= funcptr; /* Store function pointer */
429 teddy 1.29 (*new_symbol)->val= new_fvalue; /* Bind the symbol to the new
430     function value */
431 teddy 1.28 }
432 masse 1.95
433     free(mangled);
434 masse 1.1 }
435 masse 1.95
436 masse 1.75 push_val(env, new_value);
437 masse 1.1 }
438    
439 masse 1.132
440 teddy 1.114 /* Print a value */
441 masse 1.132 void print_val(environment *env, value *val, int noquote, stackitem *stack,
442     FILE *stream)
443 masse 1.8 {
444 teddy 1.117 stackitem *titem, *tstack;
445     int depth;
446    
447 teddy 1.113 switch(val->type) {
448 teddy 1.112 case empty:
449 masse 1.136 if(fprintf(stream, "[]") < 0)
450 teddy 1.124 env->err= 5;
451 teddy 1.112 break;
452 masse 1.133 case unknown:
453 masse 1.136 if(fprintf(stream, "UNKNOWN") < 0)
454 masse 1.133 env->err= 5;
455     break;
456 teddy 1.28 case integer:
457 masse 1.136 if(fprintf(stream, "%d", val->content.i) < 0)
458 teddy 1.124 env->err= 5;
459 masse 1.93 break;
460     case tfloat:
461 masse 1.136 if(fprintf(stream, "%f", val->content.f) < 0)
462 teddy 1.124 env->err= 5;
463 teddy 1.2 break;
464     case string:
465 teddy 1.124 if(noquote){
466 masse 1.136 if(fprintf(stream, "%s", val->content.string) < 0)
467 teddy 1.124 env->err= 5;
468     } else { /* quote */
469 masse 1.136 if(fprintf(stream, "\"%s\"", val->content.string) < 0)
470 teddy 1.124 env->err= 5;
471     }
472 teddy 1.2 break;
473 teddy 1.28 case symb:
474 masse 1.136 if(fprintf(stream, "%s", val->content.sym->id) < 0)
475 teddy 1.124 env->err= 5;
476 masse 1.6 break;
477 teddy 1.35 case func:
478 masse 1.136 if(fprintf(stream, "#<function %p>", val->content.func) < 0)
479 teddy 1.124 env->err= 5;
480     break;
481     case port:
482 masse 1.136 if(fprintf(stream, "#<port %p>", val->content.p) < 0)
483 teddy 1.124 env->err= 5;
484 teddy 1.35 break;
485 masse 1.102 case tcons:
486 masse 1.136 if(fprintf(stream, "[ ") < 0) {
487 teddy 1.124 env->err= 5;
488 masse 1.136 return printerr(env);
489 teddy 1.124 }
490 teddy 1.117 tstack= stack;
491 masse 1.132
492 teddy 1.113 do {
493 teddy 1.117 titem=malloc(sizeof(stackitem));
494 teddy 1.118 assert(titem != NULL);
495 teddy 1.117 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 masse 1.132
503 teddy 1.117 while(titem != NULL && titem->item != CAR(val)){
504     titem=titem->next;
505     depth++;
506     }
507 masse 1.132
508 teddy 1.117 if(titem != NULL){ /* If we found it on the stack, */
509 teddy 1.124 if(fprintf(stream, "#%d#", depth) < 0){ /* print a depth reference */
510     env->err= 5;
511     free(titem);
512 masse 1.136 return printerr(env);
513 teddy 1.124 }
514 teddy 1.117 } else {
515 teddy 1.124 print_val(env, CAR(val), noquote, tstack, stream);
516 teddy 1.117 }
517 masse 1.132
518 teddy 1.114 val= CDR(val);
519     switch(val->type){
520 teddy 1.112 case empty:
521     break;
522     case tcons:
523 teddy 1.117 /* Search a stack of values being printed to see if we are already
524     printing this value */
525     titem=tstack;
526     depth=0;
527 masse 1.132
528 teddy 1.117 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 teddy 1.124 if(fprintf(stream, " . #%d#", depth) < 0){ /* print a depth reference */
534     env->err= 5;
535 masse 1.136 printerr(env);
536 teddy 1.124 goto printval_end;
537     }
538 teddy 1.117 } else {
539 teddy 1.124 if(fprintf(stream, " ") < 0){
540     env->err= 5;
541 masse 1.136 printerr(env);
542 teddy 1.124 goto printval_end;
543     }
544 teddy 1.117 }
545 teddy 1.112 break;
546     default:
547 teddy 1.124 if(fprintf(stream, " . ") < 0){ /* Improper list */
548     env->err= 5;
549 masse 1.136 printerr(env);
550 teddy 1.124 goto printval_end;
551     }
552     print_val(env, val, noquote, tstack, stream);
553 teddy 1.112 }
554 teddy 1.117 } while(val->type == tcons && titem == NULL);
555 teddy 1.124
556     printval_end:
557    
558 teddy 1.117 titem=tstack;
559     while(titem != stack){
560     tstack=titem->next;
561     free(titem);
562     titem=tstack;
563     }
564 teddy 1.124
565     if(! (env->err)){
566     if(fprintf(stream, " ]") < 0){
567     env->err= 5;
568     }
569     }
570 teddy 1.35 break;
571 teddy 1.2 }
572 masse 1.136
573     if(env->err)
574     return printerr(env);
575 masse 1.1 }
576    
577 masse 1.132
578 masse 1.26 /* Swap the two top elements on the stack. */
579 teddy 1.28 extern void swap(environment *env)
580 masse 1.26 {
581 masse 1.104 value *temp= env->head;
582 masse 1.134
583 masse 1.136 if(check_args(env, 2, unknown, unknown))
584 masse 1.135 return printerr(env);
585 masse 1.134
586 masse 1.104 env->head= CDR(env->head);
587     CDR(temp)= CDR(env->head);
588     CDR(env->head)= temp;
589 masse 1.26 }
590    
591 masse 1.132
592 teddy 1.33 /* Recall a value from a symbol, if bound */
593 teddy 1.31 extern void rcl(environment *env)
594     {
595     value *val;
596    
597 masse 1.136 if(check_args(env, 1, symb))
598 masse 1.135 return printerr(env);
599 teddy 1.35
600 masse 1.105 val= CAR(env->head)->content.sym->val;
601 teddy 1.33 if(val == NULL){
602 masse 1.102 env->err= 3;
603 masse 1.135 return printerr(env);
604 teddy 1.33 }
605 masse 1.135
606 teddy 1.110 push_val(env, val); /* Return the symbol's bound value */
607     swap(env);
608     if(env->err) return;
609 masse 1.132 env->head= CDR(env->head);
610 teddy 1.31 }
611 masse 1.26
612 masse 1.126
613 teddy 1.29 /* 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 teddy 1.28 extern void eval(environment *env)
617 masse 1.1 {
618     funcp in_func;
619 masse 1.44 value* temp_val;
620 masse 1.104 value* iterator;
621 masse 1.44
622 teddy 1.80 eval_start:
623    
624 teddy 1.96 gc_maybe(env);
625    
626 masse 1.136 if(check_args(env, 1, unknown))
627 masse 1.135 return printerr(env);
628 masse 1.1
629 masse 1.104 switch(CAR(env->head)->type) {
630 masse 1.46 /* if it's a symbol */
631     case symb:
632 masse 1.133 env->errsymb= CAR(env->head)->content.sym->id;
633 teddy 1.35 rcl(env); /* get its contents */
634     if(env->err) return;
635 masse 1.104 if(CAR(env->head)->type!=symb){ /* don't recurse symbols */
636 teddy 1.64 goto eval_start;
637 teddy 1.29 }
638 teddy 1.59 return;
639 masse 1.22
640 masse 1.46 /* If it's a lone function value, run it */
641     case func:
642 masse 1.128 in_func= CAR(env->head)->content.func;
643 masse 1.132 env->head= CDR(env->head);
644 masse 1.135 return in_func((void*)env);
645 masse 1.44
646 masse 1.46 /* If it's a list */
647 masse 1.102 case tcons:
648 masse 1.104 temp_val= CAR(env->head);
649 masse 1.98 protect(temp_val);
650 masse 1.93
651 masse 1.132 env->head= CDR(env->head);
652 masse 1.104 iterator= temp_val;
653 masse 1.90
654 teddy 1.111 while(iterator->type != empty) {
655 masse 1.104 push_val(env, CAR(iterator));
656 masse 1.90
657 masse 1.132 if(CAR(env->head)->type==symb
658 masse 1.105 && CAR(env->head)->content.sym->id[0]==';') {
659 masse 1.132 env->head= CDR(env->head);
660 masse 1.90
661 teddy 1.111 if(CDR(iterator)->type == empty){
662 teddy 1.64 goto eval_start;
663 teddy 1.59 }
664 masse 1.44 eval(env);
665 masse 1.46 if(env->err) return;
666 masse 1.44 }
667 teddy 1.111 if (CDR(iterator)->type == empty || CDR(iterator)->type == tcons)
668 masse 1.104 iterator= CDR(iterator);
669 teddy 1.103 else {
670 masse 1.135 env->err= 2; /* Improper list */
671     return printerr(env);
672 teddy 1.103 }
673 masse 1.44 }
674 masse 1.98 unprotect(temp_val);
675 teddy 1.59 return;
676 masse 1.46
677 teddy 1.116 case empty:
678 masse 1.132 env->head= CDR(env->head);
679 teddy 1.116 case integer:
680     case tfloat:
681     case string:
682 teddy 1.124 case port:
683 masse 1.133 case unknown:
684 teddy 1.59 return;
685 masse 1.26 }
686 masse 1.1 }
687    
688 teddy 1.40
689 masse 1.126 /* Internal forget function */
690     void forget_sym(symbol **hash_entry)
691 masse 1.19 {
692 masse 1.126 symbol *temp;
693 teddy 1.111
694 masse 1.126 temp= *hash_entry;
695     *hash_entry= (*hash_entry)->next;
696    
697     free(temp->id);
698     free(temp);
699     }
700 masse 1.93
701 masse 1.65
702 masse 1.126 int main(int argc, char **argv)
703 masse 1.95 {
704 masse 1.126 environment myenv;
705     int c; /* getopt option character */
706 masse 1.89
707 masse 1.126 #ifdef __linux__
708     mtrace();
709     #endif
710 masse 1.89
711 masse 1.126 init_env(&myenv);
712 masse 1.89
713 masse 1.126 myenv.interactive = isatty(STDIN_FILENO) && isatty(STDOUT_FILENO);
714 masse 1.89
715 masse 1.126 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 masse 1.89 }
737     }
738    
739 masse 1.132 if(myenv.interactive)
740 masse 1.134 puts(start_message);
741 masse 1.65
742 masse 1.126 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 masse 1.132 if(myenv.head->type != empty)
763     myenv.head= CDR(myenv.head);
764 masse 1.126 eval(&myenv);
765 teddy 1.103 } else {
766 masse 1.126 gc_maybe(&myenv);
767 teddy 1.103 }
768 masse 1.65 }
769 masse 1.126 quit(&myenv);
770     return EXIT_FAILURE;
771 masse 1.65 }
772 masse 1.66
773 masse 1.132
774 masse 1.126 /* Return copy of a value */
775     value *copy_val(environment *env, value *old_value)
776 masse 1.95 {
777 masse 1.126 value *new_value;
778 masse 1.121
779 masse 1.126 if(old_value==NULL)
780     return NULL;
781 masse 1.95
782 masse 1.126 new_value= new_val(env);
783     new_value->type= old_value->type;
784 masse 1.66
785 masse 1.126 switch(old_value->type){
786     case tfloat:
787     case integer:
788     case func:
789     case symb:
790     case empty:
791 masse 1.133 case unknown:
792 masse 1.126 case port:
793     new_value->content= old_value->content;
794     break;
795     case string:
796 masse 1.128 new_value->content.string= strdup(old_value->content.string);
797 masse 1.126 break;
798     case tcons:
799 masse 1.66
800 masse 1.126 new_value->content.c= malloc(sizeof(pair));
801     assert(new_value->content.c!=NULL);
802     env->gc_count += sizeof(pair);
803 masse 1.66
804 masse 1.126 CAR(new_value)= copy_val(env, CAR(old_value)); /* recurse */
805     CDR(new_value)= copy_val(env, CDR(old_value)); /* recurse */
806     break;
807 masse 1.67 }
808 masse 1.66
809 masse 1.126 return new_value;
810 teddy 1.124 }
811    
812 masse 1.132
813 teddy 1.124 /* read a line from a stream; used by readline */
814     void readlinestream(environment *env, FILE *stream)
815     {
816 masse 1.68 char in_string[101];
817    
818 teddy 1.124 if(fgets(in_string, 100, stream)==NULL) {
819 teddy 1.84 push_cstring(env, "");
820 teddy 1.124 if (! feof(stream)){
821     env->err= 5;
822 masse 1.136 return printerr(env);
823 teddy 1.124 }
824     } else {
825 teddy 1.84 push_cstring(env, in_string);
826 teddy 1.124 }
827 masse 1.68 }
828    
829 masse 1.132
830 masse 1.126 /* Reverse (flip) a list */
831     extern void rev(environment *env)
832 masse 1.95 {
833 masse 1.126 value *old_head, *new_head, *item;
834 teddy 1.124
835 masse 1.126 if(CAR(env->head)->type==empty)
836     return; /* Don't reverse an empty list */
837    
838 masse 1.136 if(check_args(env, 1, tcons))
839 masse 1.135 return printerr(env);
840 teddy 1.124
841 masse 1.126 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 masse 1.132
853 masse 1.126 /* 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 masse 1.132 if(env->head->type != empty)
866     env->head= CDR(env->head);
867 masse 1.126 } 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 masse 1.132 env->head= CDR(env->head);
881 masse 1.126 }
882    
883     /* Push list */
884 teddy 1.124
885 masse 1.126 push_val(env, temp);
886     rev(env);
887 teddy 1.124 }
888    
889 masse 1.132
890 teddy 1.124 /* read from a stream; used by "read" and "readport" */
891     void readstream(environment *env, FILE *stream)
892     {
893 teddy 1.78 const char symbform[]= "%[a-zA-Z0-9!$%*+./:<=>?@^_~-]%n";
894     const char strform[]= "\"%[^\"]\"%n";
895     const char intform[]= "%i%n";
896 masse 1.93 const char fltform[]= "%f%n";
897 teddy 1.78 const char blankform[]= "%*[ \t]%n";
898 masse 1.90 const char ebrackform[]= "]%n";
899     const char semicform[]= ";%n";
900     const char bbrackform[]= "[%n";
901 masse 1.68
902 teddy 1.78 int itemp, readlength= -1;
903 masse 1.93 int count= -1;
904     float ftemp;
905 masse 1.68 static int depth= 0;
906 teddy 1.116 char *match;
907 masse 1.68 size_t inlength;
908    
909 masse 1.70 if(env->in_string==NULL) {
910 teddy 1.84 if(depth > 0 && env->interactive) {
911 teddy 1.80 printf("]> ");
912     }
913 masse 1.126 readlinestream(env, env->inputstream);
914     if(env->err) return;
915 teddy 1.84
916 masse 1.128 if((CAR(env->head)->content.string)[0]=='\0'){
917 teddy 1.85 env->err= 4; /* "" means EOF */
918 teddy 1.84 return;
919     }
920 masse 1.68
921 masse 1.128 env->in_string= malloc(strlen(CAR(env->head)->content.string)+1);
922 teddy 1.118 assert(env->in_string != NULL);
923 teddy 1.78 env->free_string= env->in_string; /* Save the original pointer */
924 masse 1.128 strcpy(env->in_string, CAR(env->head)->content.string);
925 masse 1.132 env->head= CDR(env->head);
926 masse 1.68 }
927    
928 masse 1.70 inlength= strlen(env->in_string)+1;
929 masse 1.68 match= malloc(inlength);
930 teddy 1.118 assert(match != NULL);
931 masse 1.68
932 masse 1.93 if(sscanf(env->in_string, blankform, &readlength) != EOF
933 teddy 1.78 && readlength != -1) {
934 masse 1.71 ;
935 masse 1.93 } else if(sscanf(env->in_string, fltform, &ftemp, &readlength) != EOF
936 teddy 1.78 && readlength != -1) {
937 masse 1.93 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 teddy 1.114 } else if(sscanf(env->in_string, "\"\"%n", &readlength) != EOF
944     && readlength != -1) {
945     push_cstring(env, "");
946 teddy 1.78 } else if(sscanf(env->in_string, strform, match, &readlength) != EOF
947     && readlength != -1) {
948 masse 1.72 push_cstring(env, match);
949 teddy 1.78 } else if(sscanf(env->in_string, symbform, match, &readlength) != EOF
950     && readlength != -1) {
951 masse 1.68 push_sym(env, match);
952 teddy 1.78 } else if(sscanf(env->in_string, ebrackform, &readlength) != EOF
953     && readlength != -1) {
954 masse 1.68 pack(env); if(env->err) return;
955 teddy 1.78 if(depth != 0) depth--;
956     } else if(sscanf(env->in_string, semicform, &readlength) != EOF
957     && readlength != -1) {
958 masse 1.68 push_sym(env, ";");
959 teddy 1.78 } else if(sscanf(env->in_string, bbrackform, &readlength) != EOF
960     && readlength != -1) {
961 masse 1.68 push_sym(env, "[");
962     depth++;
963     } else {
964 teddy 1.78 free(env->free_string);
965     env->in_string = env->free_string = NULL;
966     }
967 masse 1.126 if (env->in_string != NULL) {
968     env->in_string += readlength;
969 teddy 1.91 }
970    
971 masse 1.126 free(match);
972 teddy 1.91
973 masse 1.126 if(depth)
974     return readstream(env, env->inputstream);
975 masse 1.133 }
976    
977    
978 masse 1.136 int check_args(environment *env, int num_args, ...)
979 masse 1.133 {
980     va_list ap;
981     enum type_enum mytype;
982 masse 1.136 int i;
983 masse 1.133
984     value *iter= env->head;
985     int errval= 0;
986    
987 masse 1.136 va_start(ap, num_args);
988     for(i=1; i<=num_args; i++) {
989 masse 1.133 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 masse 1.136 if(mytype!=unknown && CAR(iter)->type!=mytype) {
998 masse 1.133 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 masse 1.95 }

root@recompile.se
ViewVC Help
Powered by ViewVC 1.1.26