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

Diff of /stack/symbols.c

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

revision 1.9 by masse, Wed Aug 13 11:58:00 2003 UTC revision 1.11 by masse, Thu Feb 19 15:35:38 2004 UTC
# Line 1  Line 1 
1    /*
2        stack - an interactive interpreter for a stack-based language
3        Copyright (C) 2002  Mats Alritzson and Teddy Hogeborn
4    
5        This program is free software; you can redistribute it and/or modify
6        it under the terms of the GNU General Public License as published by
7        the Free Software Foundation; either version 2 of the License, or
8        (at your option) any later version.
9    
10        This program is distributed in the hope that it will be useful,
11        but WITHOUT ANY WARRANTY; without even the implied warranty of
12        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13        GNU General Public License for more details.
14    
15        You should have received a copy of the GNU General Public License
16        along with this program; if not, write to the Free Software
17        Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
18    
19        Authors: Mats Alritzson <masse@fukt.bth.se>
20                 Teddy Hogeborn <teddy@fukt.bth.se>
21    */
22    
23  #include "stack.h"  #include "stack.h"
24  #include "messages.h"  #include "messages.h"
25    
# Line 10  extern void nl(environment *env) Line 32  extern void nl(environment *env)
32  /* Print a newline to a port */  /* Print a newline to a port */
33  extern void nlport(environment *env)  extern void nlport(environment *env)
34  {  {
35    if(check_args(env, port, empty))    if(check_args(env, 1, port))
36      return printerr(env);      return printerr(env);
37    
38    if(fprintf(CAR(env->head)->content.p, "\n") < 0){    if(fprintf(CAR(env->head)->content.p, "\n") < 0) {
     perror("nl");  
39      env->err= 5;      env->err= 5;
40      return;      return printerr(env);
41    }    }
42    
43    toss(env);    toss(env);
44  }  }
45    
# Line 25  extern void nlport(environment *env) Line 47  extern void nlport(environment *env)
47  extern void type(environment *env)  extern void type(environment *env)
48  {  {
49    
50    if(check_args(env, unknown, empty))    if(check_args(env, 1, unknown))
51      return printerr(env);      return printerr(env);
52    
53    switch(CAR(env->head)->type){    switch(CAR(env->head)->type){
# Line 66  extern void type(environment *env) Line 88  extern void type(environment *env)
88  extern void print_(environment *env)  extern void print_(environment *env)
89  {  {
90    
91    if(check_args(env, unknown, empty))    if(check_args(env, 1, unknown))
92      return printerr(env);      return printerr(env);
93    
94    print_val(env, CAR(env->head), 0, NULL, stdout);    print_val(env, CAR(env->head), 0, NULL, stdout);
# Line 87  extern void print(environment *env) Line 109  extern void print(environment *env)
109  extern void princ_(environment *env)  extern void princ_(environment *env)
110  {  {
111    
112    if(check_args(env, unknown, empty))    if(check_args(env, 1, unknown))
113      return printerr(env);      return printerr(env);
114    
115    print_val(env, CAR(env->head), 1, NULL, stdout);    print_val(env, CAR(env->head), 1, NULL, stdout);
# Line 105  extern void princ(environment *env) Line 127  extern void princ(environment *env)
127  extern void printport_(environment *env)  extern void printport_(environment *env)
128  {  {
129    
130    if(check_args(env, port, unknown, empty))    if(check_args(env, 2, port, unknown))
131      return printerr(env);      return printerr(env);
132    
133    print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);    print_val(env, CAR(CDR(env->head)), 0, NULL, CAR(env->head)->content.p);
# Line 125  extern void printport(environment *env) Line 147  extern void printport(environment *env)
147  extern void princport_(environment *env)  extern void princport_(environment *env)
148  {  {
149    
150    if(check_args(env, port, unknown, empty))    if(check_args(env, 2, port, unknown))
151      return printerr(env);      return printerr(env);
152    
153    print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);    print_val(env, CAR(CDR(env->head)), 1, NULL, CAR(env->head)->content.p);
# Line 145  extern void rot(environment *env) Line 167  extern void rot(environment *env)
167  {  {
168    value *temp= env->head;    value *temp= env->head;
169    
170    if(check_args(env, unknown, unknown, unknown, empty))    if(check_args(env, 3, unknown, unknown, unknown))
171      return printerr(env);      return printerr(env);
172        
173    env->head= CDR(CDR(env->head));    env->head= CDR(CDR(env->head));
# Line 158  extern void expand(environment *env) Line 180  extern void expand(environment *env)
180  {  {
181    value *temp, *new_head;    value *temp, *new_head;
182    
183    if(check_args(env, tcons, empty))    if(check_args(env, 1, tcons))
184      return printerr(env);      return printerr(env);
185    
186    rev(env);    rev(env);
# Line 193  extern void eq(environment *env) Line 215  extern void eq(environment *env)
215  {  {
216    void *left, *right;    void *left, *right;
217    
218    if(check_args(env, unknown, unknown, empty))    if(check_args(env, 2, unknown, unknown))
219      return printerr(env);      return printerr(env);
220    
221    left= CAR(env->head)->content.ptr;    left= CAR(env->head)->content.ptr;
# Line 208  extern void not(environment *env) Line 230  extern void not(environment *env)
230  {  {
231    int val;    int val;
232    
233    if(check_args(env, integer, empty))    if(check_args(env, 1, integer))
234      return printerr(env);      return printerr(env);
235    
236    val= CAR(env->head)->content.i;    val= CAR(env->head)->content.i;
# Line 229  extern void def(environment *env) Line 251  extern void def(environment *env)
251    symbol *sym;    symbol *sym;
252    
253    /* Needs two values on the stack, the top one must be a symbol */    /* Needs two values on the stack, the top one must be a symbol */
254    if(check_args(env, symb, unknown, empty))    if(check_args(env, 2, symb, unknown))
255      return printerr(env);      return printerr(env);
256    
257    /* long names are a pain */    /* long names are a pain */
# Line 252  extern void forget(environment *env) Line 274  extern void forget(environment *env)
274  {  {
275    char* sym_id;    char* sym_id;
276    
277    if(check_args(env, symb, empty))    if(check_args(env, 1, symb))
278      return printerr(env);      return printerr(env);
279    
280    sym_id= CAR(env->head)->content.sym->id;    sym_id= CAR(env->head)->content.sym->id;
# Line 276  extern void sx_2b(environment *env) Line 298  extern void sx_2b(environment *env)
298    char* new_string;    char* new_string;
299    value *a_val, *b_val;    value *a_val, *b_val;
300    
301    if(check_args(env, unknown, unknown, empty))    if(check_args(env, 2, string, string)==0) {
     return printerr(env);  
   
   if(check_args(env, string, string, empty)==0) {  
302      a_val= CAR(env->head);      a_val= CAR(env->head);
303      b_val= CAR(CDR(env->head));      b_val= CAR(CDR(env->head));
304      protect(a_val); protect(b_val);      protect(a_val); protect(b_val);
# Line 297  extern void sx_2b(environment *env) Line 316  extern void sx_2b(environment *env)
316      return;      return;
317    }    }
318        
319    if(check_args(env, integer, integer, empty)==0) {    if(check_args(env, 2, integer, integer)==0) {
320      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
321      toss(env); if(env->err) return;      toss(env); if(env->err) return;
322      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 307  extern void sx_2b(environment *env) Line 326  extern void sx_2b(environment *env)
326      return;      return;
327    }    }
328    
329    if(check_args(env, tfloat, tfloat, empty)==0) {    if(check_args(env, 2, tfloat, tfloat)==0) {
330      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
331      toss(env); if(env->err) return;      toss(env); if(env->err) return;
332      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 317  extern void sx_2b(environment *env) Line 336  extern void sx_2b(environment *env)
336      return;      return;
337    }    }
338    
339    if(check_args(env, tfloat, integer, empty)==0) {    if(check_args(env, 2, tfloat, integer)==0) {
340      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
341      toss(env); if(env->err) return;      toss(env); if(env->err) return;
342      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 327  extern void sx_2b(environment *env) Line 346  extern void sx_2b(environment *env)
346      return;      return;
347    }    }
348    
349    if(check_args(env, integer, tfloat, empty)==0) {    if(check_args(env, 2, integer, tfloat)==0) {
350      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
351      toss(env); if(env->err) return;      toss(env); if(env->err) return;
352      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 346  extern void sx_2d(environment *env) Line 365  extern void sx_2d(environment *env)
365    int a, b;    int a, b;
366    float fa, fb;    float fa, fb;
367    
368    if(check_args(env, unknown, unknown, empty))    if(check_args(env, 2, integer, integer)==0) {
     return printerr(env);  
   
   if(check_args(env, integer, integer, empty)==0) {  
369      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
370      toss(env); if(env->err) return;      toss(env); if(env->err) return;
371      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 359  extern void sx_2d(environment *env) Line 375  extern void sx_2d(environment *env)
375      return;      return;
376    }    }
377    
378    if(check_args(env, tfloat, tfloat, empty)==0) {    if(check_args(env, 2, tfloat, tfloat)==0) {
379      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
380      toss(env); if(env->err) return;      toss(env); if(env->err) return;
381      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 369  extern void sx_2d(environment *env) Line 385  extern void sx_2d(environment *env)
385      return;      return;
386    }    }
387    
388    if(check_args(env, tfloat, integer, empty)==0) {    if(check_args(env, 2, tfloat, integer)==0) {
389      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
390      toss(env); if(env->err) return;      toss(env); if(env->err) return;
391      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 379  extern void sx_2d(environment *env) Line 395  extern void sx_2d(environment *env)
395      return;      return;
396    }    }
397    
398    if(check_args(env, integer, tfloat, empty)==0) {    if(check_args(env, 2, integer, tfloat)==0) {
399      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
400      toss(env); if(env->err) return;      toss(env); if(env->err) return;
401      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 398  extern void sx_3e(environment *env) Line 414  extern void sx_3e(environment *env)
414    int a, b;    int a, b;
415    float fa, fb;    float fa, fb;
416    
417    if(check_args(env, unknown, unknown, empty))    if(check_args(env, 2, integer, integer)==0) {
     return printerr(env);  
   
   if(check_args(env, integer, integer, empty)==0) {  
418      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
419      toss(env); if(env->err) return;      toss(env); if(env->err) return;
420      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 411  extern void sx_3e(environment *env) Line 424  extern void sx_3e(environment *env)
424      return;      return;
425    }    }
426    
427    if(check_args(env, tfloat, tfloat, empty)==0) {    if(check_args(env, 2, tfloat, tfloat)==0) {
428      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
429      toss(env); if(env->err) return;      toss(env); if(env->err) return;
430      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 421  extern void sx_3e(environment *env) Line 434  extern void sx_3e(environment *env)
434      return;      return;
435    }    }
436    
437    if(check_args(env, tfloat, integer, empty)==0) {    if(check_args(env, 2, tfloat, integer)==0) {
438      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
439      toss(env); if(env->err) return;      toss(env); if(env->err) return;
440      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 431  extern void sx_3e(environment *env) Line 444  extern void sx_3e(environment *env)
444      return;      return;
445    }    }
446    
447    if(check_args(env, integer, tfloat, empty)==0) {    if(check_args(env, 2, integer, tfloat)==0) {
448      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
449      toss(env); if(env->err) return;      toss(env); if(env->err) return;
450      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 468  extern void sx_3e3d(environment *env) Line 481  extern void sx_3e3d(environment *env)
481  /* "dup"; duplicates an item on the stack */  /* "dup"; duplicates an item on the stack */
482  extern void sx_647570(environment *env)  extern void sx_647570(environment *env)
483  {  {
484    if(check_args(env, unknown, empty))    if(check_args(env, 1, unknown))
485      return printerr(env);      return printerr(env);
486    
487    push_val(env, copy_val(env, CAR(env->head)));    push_val(env, copy_val(env, CAR(env->head)));
# Line 479  extern void sx_6966(environment *env) Line 492  extern void sx_6966(environment *env)
492  {  {
493    int truth;    int truth;
494    
495    if(check_args(env, unknown, integer, empty))    if(check_args(env, 2, unknown, integer))
496      return printerr(env);      return printerr(env);
497    
498    swap(env);    swap(env);
# Line 501  extern void ifelse(environment *env) Line 514  extern void ifelse(environment *env)
514  {  {
515    int truth;    int truth;
516    
517    if(check_args(env, unknown, unknown, integer, empty))    if(check_args(env, 3, unknown, unknown, integer))
518      return printerr(env);      return printerr(env);
519    
520    rot(env);    rot(env);
# Line 526  extern void ifelse(environment *env) Line 539  extern void ifelse(environment *env)
539  extern void sx_656c7365(environment *env)  extern void sx_656c7365(environment *env)
540  {  {
541    
542    if(check_args(env, unknown, symb, unknown, symb, integer, empty))    if(check_args(env, 5, unknown, symb, unknown, symb, integer))
543      return printerr(env);      return printerr(env);
544    
545    /// XXX    /// XXX
# Line 546  extern void sx_656c7365(environment *env Line 559  extern void sx_656c7365(environment *env
559  extern void then(environment *env)  extern void then(environment *env)
560  {  {
561        
562    if(check_args(env, unknown, symb, integer, empty))    if(check_args(env, 3, unknown, symb, integer))
563      return printerr(env);      return printerr(env);
564    
565    /// XXX    /// XXX
# Line 567  extern void sx_7768696c65(environment *e Line 580  extern void sx_7768696c65(environment *e
580    int truth;    int truth;
581    value *loop, *test;    value *loop, *test;
582    
583    if(check_args(env, unknown, integer, empty))    if(check_args(env, 2, unknown, integer))
584      return printerr(env);      return printerr(env);
585    
586    loop= CAR(env->head);    loop= CAR(env->head);
# Line 611  extern void sx_666f72(environment *env) Line 624  extern void sx_666f72(environment *env)
624    value *loop;    value *loop;
625    int foo1, foo2;    int foo1, foo2;
626    
627    if(check_args(env, unknown, integer, integer, empty))    if(check_args(env, 3, unknown, integer, integer))
628      return printerr(env);      return printerr(env);
629    
630    loop= CAR(env->head);    loop= CAR(env->head);
# Line 649  extern void foreach(environment *env) Line 662  extern void foreach(environment *env)
662    value *loop, *foo;    value *loop, *foo;
663    value *iterator;    value *iterator;
664    
665    if(check_args(env, unknown, tcons, empty))    if(check_args(env, 2, unknown, tcons))
666      return printerr(env);      return printerr(env);
667        
668    loop= CAR(env->head);    loop= CAR(env->head);
# Line 686  extern void to(environment *env) Line 699  extern void to(environment *env)
699    int ending, start, i;    int ending, start, i;
700    value *iterator, *temp, *end;    value *iterator, *temp, *end;
701    
702    if(check_args(env, integer, integer, empty))    if(check_args(env, 2, integer, integer))
703      return printerr(env);      return printerr(env);
704    
705    end= new_val(env);    end= new_val(env);
# Line 744  extern void readlineport(environment *en Line 757  extern void readlineport(environment *en
757  {  {
758    FILE *stream;    FILE *stream;
759    
760    if(check_args(env, port, empty))    if(check_args(env, 1, port))
761      return printerr(env);      return printerr(env);
762    
763    stream=CAR(env->head)->content.p;    stream=CAR(env->head)->content.p;
# Line 765  extern void readport(environment *env) Line 778  extern void readport(environment *env)
778  {  {
779    FILE *stream;    FILE *stream;
780    
781    if(check_args(env, port, empty))    if(check_args(env, 1, port))
782      return printerr(env);      return printerr(env);
783    
784    stream=CAR(env->head)->content.p;    stream=CAR(env->head)->content.p;
# Line 780  extern void beep(environment *env) Line 793  extern void beep(environment *env)
793  {  {
794    int freq, dur, period, ticks;    int freq, dur, period, ticks;
795    
796    if(check_args(env, integer, integer, empty))    if(check_args(env, 2, integer, integer))
797      return printerr(env);      return printerr(env);
798    
799    dur= CAR(env->head)->content.i;    dur= CAR(env->head)->content.i;
# Line 801  extern void beep(environment *env) Line 814  extern void beep(environment *env)
814      usleep(dur);      usleep(dur);
815      return;      return;
816    case -1:    case -1:
     perror("beep");  
817      env->err= 5;      env->err= 5;
818      return;      return printerr(env);
819    default:    default:
820      abort();      abort();
821    }    }
# Line 815  extern void sx_77616974(environment *env Line 827  extern void sx_77616974(environment *env
827  {  {
828    int dur;    int dur;
829    
830    if(check_args(env, integer, empty))    if(check_args(env, 1, integer))
831      return printerr(env);      return printerr(env);
832    
833    dur= CAR(env->head)->content.i;    dur= CAR(env->head)->content.i;
# Line 831  extern void sx_2a(environment *env) Line 843  extern void sx_2a(environment *env)
843    int a, b;    int a, b;
844    float fa, fb;    float fa, fb;
845    
846    if(check_args(env, unknown, unknown, empty))    if(check_args(env, 2, integer, integer)==0) {
     return printerr(env);  
   
   if(check_args(env, integer, integer, empty)==0) {  
847      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
848      toss(env); if(env->err) return;      toss(env); if(env->err) return;
849      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 844  extern void sx_2a(environment *env) Line 853  extern void sx_2a(environment *env)
853      return;      return;
854    }    }
855    
856    if(check_args(env, tfloat, tfloat, empty)==0) {    if(check_args(env, 2, tfloat, tfloat)==0) {
857      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
858      toss(env); if(env->err) return;      toss(env); if(env->err) return;
859      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 854  extern void sx_2a(environment *env) Line 863  extern void sx_2a(environment *env)
863      return;      return;
864    }    }
865    
866    if(check_args(env, tfloat, integer, empty)==0) {    if(check_args(env, 2, tfloat, integer)==0) {
867      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
868      toss(env); if(env->err) return;      toss(env); if(env->err) return;
869      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 864  extern void sx_2a(environment *env) Line 873  extern void sx_2a(environment *env)
873      return;      return;
874    }    }
875    
876    if(check_args(env, integer, tfloat, empty)==0) {    if(check_args(env, 2, integer, tfloat)==0) {
877      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
878      toss(env); if(env->err) return;      toss(env); if(env->err) return;
879      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 883  extern void sx_2f(environment *env) Line 892  extern void sx_2f(environment *env)
892    int a, b;    int a, b;
893    float fa, fb;    float fa, fb;
894    
895    if(check_args(env, unknown, unknown, empty))    if(check_args(env, 2, integer, integer)==0) {
     return printerr(env);  
   
   if(check_args(env, integer, integer, empty)==0) {  
896      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
897      toss(env); if(env->err) return;      toss(env); if(env->err) return;
898      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 896  extern void sx_2f(environment *env) Line 902  extern void sx_2f(environment *env)
902      return;      return;
903    }    }
904    
905    if(check_args(env, tfloat, tfloat, empty)==0) {    if(check_args(env, 2, tfloat, tfloat)==0) {
906      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
907      toss(env); if(env->err) return;      toss(env); if(env->err) return;
908      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 906  extern void sx_2f(environment *env) Line 912  extern void sx_2f(environment *env)
912      return;      return;
913    }    }
914    
915    if(check_args(env, tfloat, integer, empty)==0) {    if(check_args(env, 2, tfloat, integer)==0) {
916      fa= CAR(env->head)->content.f;      fa= CAR(env->head)->content.f;
917      toss(env); if(env->err) return;      toss(env); if(env->err) return;
918      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 916  extern void sx_2f(environment *env) Line 922  extern void sx_2f(environment *env)
922      return;      return;
923    }    }
924    
925    if(check_args(env, integer, tfloat, empty)==0) {    if(check_args(env, 2, integer, tfloat)==0) {
926      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
927      toss(env); if(env->err) return;      toss(env); if(env->err) return;
928      fb= CAR(env->head)->content.f;      fb= CAR(env->head)->content.f;
# Line 934  extern void mod(environment *env) Line 940  extern void mod(environment *env)
940  {  {
941    int a, b;    int a, b;
942    
943    if(check_args(env, unknown, unknown, empty))    if(check_args(env, 2, integer, integer)==0) {
     return printerr(env);  
   
   if(check_args(env, integer, integer, empty)==0) {  
944      a= CAR(env->head)->content.i;      a= CAR(env->head)->content.i;
945      toss(env); if(env->err) return;      toss(env); if(env->err) return;
946      b= CAR(env->head)->content.i;      b= CAR(env->head)->content.i;
# Line 956  extern void sx_646976(environment *env) Line 959  extern void sx_646976(environment *env)
959  {  {
960    int a, b;    int a, b;
961    
962    if(check_args(env, integer, integer, empty))    if(check_args(env, 2, integer, integer))
963      return printerr(env);      return printerr(env);
964        
965    a= CAR(env->head)->content.i;    a= CAR(env->head)->content.i;
# Line 970  extern void sx_646976(environment *env) Line 973  extern void sx_646976(environment *env)
973  extern void setcar(environment *env)  extern void setcar(environment *env)
974  {  {
975    
976    if(check_args(env, tcons, unknown, empty))    if(check_args(env, 2, tcons, unknown))
977      return printerr(env);      return printerr(env);
978    
979    CAR(CAR(CDR(env->head)))=CAR(env->head);    CAR(CAR(CDR(env->head)))=CAR(env->head);
# Line 980  extern void setcar(environment *env) Line 983  extern void setcar(environment *env)
983  extern void setcdr(environment *env)  extern void setcdr(environment *env)
984  {  {
985    
986    if(check_args(env, tcons, unknown, empty))    if(check_args(env, 2, tcons, unknown))
987      return printerr(env);      return printerr(env);
988    
989    CDR(CAR(CDR(env->head)))=CAR(env->head);    CDR(CAR(CDR(env->head)))=CAR(env->head);
# Line 990  extern void setcdr(environment *env) Line 993  extern void setcdr(environment *env)
993  extern void car(environment *env)  extern void car(environment *env)
994  {  {
995    
996    if(check_args(env, tcons, empty))    if(check_args(env, 1, tcons))
997      return printerr(env);      return printerr(env);
998    
999    CAR(env->head)=CAR(CAR(env->head));    CAR(env->head)=CAR(CAR(env->head));
# Line 999  extern void car(environment *env) Line 1002  extern void car(environment *env)
1002  extern void cdr(environment *env)  extern void cdr(environment *env)
1003  {  {
1004    
1005    if(check_args(env, tcons, empty))    if(check_args(env, 1, tcons))
1006      return printerr(env);      return printerr(env);
1007    
1008    CAR(env->head)=CDR(CAR(env->head));    CAR(env->head)=CDR(CAR(env->head));
# Line 1009  extern void cons(environment *env) Line 1012  extern void cons(environment *env)
1012  {  {
1013    value *val;    value *val;
1014    
1015    if(check_args(env, unknown, unknown, empty))    if(check_args(env, 2, unknown, unknown))
1016      return printerr(env);      return printerr(env);
1017    
1018    val=new_val(env);    val=new_val(env);
# Line 1038  void assocgen(environment *env, funcp eq Line 1041  void assocgen(environment *env, funcp eq
1041    
1042    /* Needs two values on the stack, the top one must be an association    /* Needs two values on the stack, the top one must be an association
1043       list */       list */
1044    if(check_args(env, tcons, unknown, empty))    if(check_args(env, 2, tcons, unknown))
1045      return printerr(env);      return printerr(env);
1046    
1047    key=CAR(CDR(env->head));    key=CAR(CDR(env->head));
# Line 1055  void assocgen(environment *env, funcp eq Line 1058  void assocgen(environment *env, funcp eq
1058      eqfunc((void*)env); if(env->err) return;      eqfunc((void*)env); if(env->err) return;
1059    
1060      /* Check the result of 'eqfunc' */      /* Check the result of 'eqfunc' */
1061      if(check_args(env, integer, empty))      if(check_args(env, 1, integer))
1062        return printerr(env);        return printerr(env);
1063    
1064      if(CAR(env->head)->content.i){      if(CAR(env->head)->content.i){
# Line 1107  extern void sx_6f70656e(environment *env Line 1110  extern void sx_6f70656e(environment *env
1110    value *new_port;    value *new_port;
1111    FILE *stream;    FILE *stream;
1112    
1113    if(check_args(env, string, string, empty))    if(check_args(env, 2, string, string))
1114      return printerr(env);      return printerr(env);
1115    
1116    stream=fopen(CAR(CDR(env->head))->content.ptr,    stream=fopen(CAR(CDR(env->head))->content.ptr,
1117                 CAR(env->head)->content.ptr);                 CAR(env->head)->content.ptr);
1118    
1119    if(stream == NULL) {    if(stream == NULL) {
     perror("open");  
1120      env->err= 5;      env->err= 5;
1121      return;      return printerr(env);
1122    }    }
1123    
1124    new_port=new_val(env);    new_port=new_val(env);
# Line 1137  extern void sx_636c6f7365(environment *e Line 1139  extern void sx_636c6f7365(environment *e
1139  {  {
1140    int ret;    int ret;
1141    
1142    if(check_args(env, port, empty))    if(check_args(env, 1, port))
1143      return printerr(env);      return printerr(env);
1144    
1145    ret= fclose(CAR(env->head)->content.p);    ret= fclose(CAR(env->head)->content.p);
1146    
1147    if(ret != 0){    if(ret != 0){
     perror("close");  
1148      env->err= 5;      env->err= 5;
1149      return;      return printerr(env);
1150    }    }
1151    
1152    toss(env);    toss(env);
# Line 1156  extern void mangle(environment *env) Line 1157  extern void mangle(environment *env)
1157  {  {
1158    char *new_string;    char *new_string;
1159    
1160    if(check_args(env, string, empty))    if(check_args(env, 1, string))
1161      return printerr(env);      return printerr(env);
1162    
1163    new_string= mangle_str(CAR(env->head)->content.string);    new_string= mangle_str(CAR(env->head)->content.string);
# Line 1177  extern void sx_666f726b(environment *env Line 1178  extern void sx_666f726b(environment *env
1178  extern void sx_77616974706964(environment *env)  extern void sx_77616974706964(environment *env)
1179  {  {
1180    
1181    if(check_args(env, integer, empty))    if(check_args(env, 1, integer))
1182      return printerr(env);      return printerr(env);
1183    
1184    push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0));    push_int(env, waitpid(CAR(env->head)->content.i, NULL, 0));
# Line 1189  extern void sx_77616974706964(environmen Line 1190  extern void sx_77616974706964(environmen
1190  extern void toss(environment *env)  extern void toss(environment *env)
1191  {  {
1192    
1193    if(check_args(env, unknown, empty))    if(check_args(env, 1, unknown))
1194      return printerr(env);      return printerr(env);
1195    
1196    env->head= CDR(env->head); /* Remove the top stack item */    env->head= CDR(env->head); /* Remove the top stack item */
# Line 1280  extern void warranty(environment *env) Line 1281  extern void warranty(environment *env)
1281  {  {
1282    puts(warranty_message);    puts(warranty_message);
1283  }  }
1284    
1285    
1286    /* random */
1287    extern void sx_72616e646f6d(environment *env)
1288    {
1289      push_int(env, (int)rand());
1290    }
1291    
1292    
1293    extern void seed(environment *env)
1294    {
1295      if(check_args(env, 1, integer))
1296        return printerr(env);
1297    
1298      srand(CAR(env->head)->content.i);
1299      toss(env);
1300    }
1301    
1302    
1303    extern void ticks(environment *env)
1304    {
1305      int val;
1306    
1307      val= (int)time(NULL);
1308      if(val<0) {
1309        env->err= 5;
1310        return printerr(env);
1311      }
1312      
1313      return push_int(env, val);
1314    }
1315    
1316    
1317    extern void push(environment *env)
1318    {
1319      symbol *sym;
1320      value *oldval;
1321      value *newval;
1322    
1323      if(check_args(env, 2, symb, unknown)==0) {
1324        sym= CAR(env->head)->content.sym;
1325        oldval= sym->val;
1326      
1327        if(oldval==NULL)
1328          oldval= new_val(env);
1329    
1330        sym->val= new_val(env);
1331        sym->val->content.c= malloc(sizeof(pair));
1332        assert(sym->val->content.c!=NULL);
1333        env->gc_count += sizeof(pair);
1334        sym->val->type= tcons;
1335        CDR(sym->val)= oldval;
1336        CAR(sym->val)= CAR(CDR(env->head));
1337        env->head= CDR(CDR(env->head));
1338    
1339        return;
1340      }
1341    
1342      if(check_args(env, 2, tcons, unknown)==0
1343         || check_args(env, 2, empty, unknown)==0) {
1344        oldval= CAR(env->head);
1345        env->head= CDR(env->head);
1346        newval= new_val(env);
1347        newval->content.c= malloc(sizeof(pair));
1348        assert(newval->content.c!=NULL);
1349        env->gc_count += sizeof(pair);
1350        newval->type= tcons;
1351        CDR(newval)= oldval;
1352        CAR(newval)= CAR(env->head);
1353        env->head= CDR(env->head);
1354        push_val(env, newval);
1355        
1356        return;
1357      }
1358    
1359      return printerr(env);
1360    }
1361    
1362    
1363    extern void pop(environment *env)
1364    {
1365      symbol *sym;
1366      value *val;
1367    
1368      if(check_args(env, 1, symb)==0) {
1369        sym= CAR(env->head)->content.sym;
1370    
1371        if(sym->val==NULL) {
1372          env->err= 3;
1373          return printerr(env);
1374        }
1375    
1376        env->head= CDR(env->head);
1377        if(sym->val->type==tcons) {
1378          push_val(env, CAR(sym->val));
1379          sym->val= CDR(sym->val);
1380        } else {
1381          env->err= 2;
1382          return printerr(env);
1383        }
1384    
1385        return;
1386      }
1387    
1388      if(check_args(env, 1, tcons)==0) {
1389        val= CAR(env->head);
1390        env->head= CDR(env->head);
1391        push_val(env, CAR(val));
1392        return;
1393      }
1394    
1395      return printerr(env);
1396    }
Legend:
Removed from v.1.9  
changed lines
  Added in v.1.11
root@recompile.se
 ViewVC Help
Powered by ViewVC 1.1.26