home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 5 Edit / 05-Edit.zip / me34src.zip / me3 / mc / mc.c < prev    next >
C/C++ Source or Header  |  1995-01-14  |  17KB  |  548 lines
  1. /*
  2.  * mc.c : the Mutt compiler
  3.  *  Craig Durland 6/87, modified in late '91 for Mutt2
  4.  */
  5.  
  6. /* Copyright 1990, 1991, 1992 Craig Durland
  7.  *   Distributed under the terms of the GNU General Public License.
  8.  *   Distributed "as is", without warranties of any kind, but comments,
  9.  *     suggestions and bug reports are welcome.
  10.  */
  11.  
  12. static char what[] = "@(#)Mutt2 compiler 2/2/92 v2.6 2/13/94";
  13. #define WHAT (&what[4])
  14.  
  15. #include <stdio.h>
  16. #include <os.h>
  17. #include "mc.h"
  18. #include "opcode.h"
  19. #include "mm.h"
  20.  
  21. extern char *strcpy(), *new_ext(), *spoof(), *save_string();
  22. extern int32 atoN();
  23. extern unsigned int codesize();
  24. extern dumpcode();
  25.  
  26. void doc(), pilefile();
  27.  
  28. char ebuf[MAXSTRLEN+5], *muttfile = "", *include_list[10];
  29. FILE *lstfile = NULL, *srcfile;
  30. int errors = 0, warnings = 0, srcline = 0;
  31.  
  32. main(argc,argv) char *argv[];
  33. {
  34.   extern char *optarg, optltr;        /* in argh.c */
  35.   extern int no_warn, no_gripe;        /* in supp.c */
  36.  
  37.   char buf[90], *ptr = NULL, *tfname = NULL;
  38.   int j = 0, list = FALSE, x, stats = FALSE, quiet = FALSE;
  39.  
  40.   while ( (x = argh(argc,argv,"I:lst:vq:")) )
  41.     switch (x)
  42.     {
  43.       case 2: ptr = optarg; break;
  44.       case 1:
  45.     switch (optltr)
  46.     {
  47.       case 'I': include_list[j++] = optarg; break;
  48.       case 'l': list = TRUE;    break;
  49.       case 's': stats = TRUE;    break;
  50.       case 't': tfname = optarg;    break;
  51.       case 'v':
  52.         printf("%s copyright 1987-92 Craig Durland\n",WHAT);
  53.         exit(0);
  54.       case 'q':            /* quiet */
  55.         x = atoi(optarg);
  56.         quiet    = x & 1;
  57.         no_gripe = x & 2;
  58.         no_warn  = x & 4;
  59.         break;
  60.     }
  61.     }
  62.   include_list[j] = NULL;
  63.  
  64.   if (!quiet) printf("%s\n",WHAT);
  65.  
  66.   if (ptr == NULL) { doc(); exit(1); }
  67.  
  68.   if (list)
  69.   {
  70.     new_ext(buf,ptr,".lst");
  71.     if ((lstfile = fopen(buf,"w")) == NULL) bitch("Can't open list file.");
  72.   }
  73.  
  74.   init_code_generater();
  75.   keyword_init();
  76.   var_init();
  77.   pgm_init();
  78.  
  79.   if (tfname) load_ext_token_table(tfname);    /* external token file */
  80.  
  81.   new_ext(buf,ptr,".mut");
  82.   pilefile(buf,FALSE); finishup();
  83.  
  84.   if (errors == 0) dumpcode(ptr);
  85.   spoof(ebuf,"%d Errors.  %d Warnings. %u bytes of code.",
  86.     errors,warnings,codesize());
  87.  
  88.   if (stats) dump_stats(stdout);
  89.   if (!quiet || stats) puts(ebuf);
  90.  
  91.   if (lstfile) { fprintf(lstfile,"\n%s\n",ebuf); fclose(lstfile); }
  92.  
  93. /* hstats(); hdump(); /*  */
  94.   exit(errors != 0);    /* 0 if no errors, 1 if errors */
  95. }
  96.  
  97. void doc()
  98. {
  99.   dump_doc(
  100.   "MC2 [options] sourcefile[.MUT]",
  101.   "options: ",
  102.   " -I dir: An alternate directory for include files.  One dir per -I",
  103.   " -l : Assembler output with source comments.  Put into sourcefile.LST",
  104.   " -q <bits> : quiet some messages",
  105.   "    Bits is a bit-or of:",
  106.   "    1 : Don't print compiler version",
  107.   "    2 : Don't print gripes",
  108.   "    4 : Don't print warnings",
  109.   " -s : Obscure compiler stats",
  110.   " -t tokenfile : tokenfile.TOK contains X-tokens",
  111.   " -v : Display the version of the compiler",
  112.   "Compiled code is put into sourcefile.MCO",
  113.   (char *)NULL);
  114. }
  115.  
  116. extern char *catstrs();
  117.  
  118.     /* open a file, search path_list if necessary */
  119. FILE *flopen(name,path_list,mode) char *name, *path_list[], *mode;
  120. {
  121.   char buf[300];
  122.   FILE *fptr;
  123.   int j;
  124.  
  125.   if ((fptr = fopen(name,mode))) return fptr;
  126.   for (j = 0; path_list[j]; j++)
  127.     if ((fptr = fopen(catstrs(buf,path_list[j],"/",name,(char *)NULL),mode)))
  128.       return fptr;
  129.   return NULL;
  130. }
  131.  
  132. void pilefile(fname,search) char *fname;
  133. {
  134.   char fn[100], *ptr = muttfile;
  135.   FILE *sf = srcfile;
  136.   int sline = srcline;
  137.  
  138.   srcfile = search ? flopen(fname,include_list,"r") : fopen(fname,"r");
  139.   if (srcfile == NULL) bitch(spoof(ebuf,"Can't open %s.",fname));
  140.   muttfile = strcpy(fn,fname); srcline = 0;
  141.   getsrc();    /* prime scan() */
  142.   while (compile()) ;
  143.   muttfile = ptr; srcline = sline;
  144.   fclose(srcfile); srcfile = sf;
  145. }
  146.  
  147. /* ******************************************************************** */
  148. /* *************************** The Compiler *************************** */
  149. /* ******************************************************************** */
  150.  
  151. extern address getaddr(), pcaddr();
  152. extern int ddone_label, btv;
  153. extern KeyWord *global_look_up(), *global_look_for(), *global_check();
  154. extern MMDatum *getconst();
  155.  
  156. char token[257], temp[257];
  157. int breaklabel = -1, contlabel = -1;
  158. unsigned int class = VOID;
  159. MMDatum rv, *vtr;
  160.  
  161. #define NO_ARGS        0
  162. #define MAYBE_ARGS    1    
  163. #define EDONE        2
  164.  
  165. static int clevel = -1, indefun = FALSE;
  166.  
  167. compile()
  168. {
  169.   int s;
  170.   unsigned int lastclass;
  171.  
  172.   clevel++;
  173.   lastclass = class; get_token();
  174.   switch(class)
  175.   {
  176.     case SEOF:    clevel--; return FALSE;    /* hit EOF */
  177.     case STRING:  gostr(RVSTR,token);    break;
  178.     case NUMBER:  gonumx(atoN(token));    break;
  179.     case BOOLEAN: gonum8(RVBOOL,btv);    break;
  180.     case TOKEN:   genvar(token,FALSE);    break;
  181.     case DELIMITER:
  182.       switch (*token)
  183.       {
  184.     case START_PGM:                         /* { ... } */
  185.       while (TRUE)
  186.       {
  187.         lookahead();
  188.         if (class == DELIMITER)
  189.           if (*token == END_PGM) break;
  190.           else if (*token == START_PGM) bitch("Can't nest pgms.");
  191.         class = lastclass; compile(); lastclass = class;
  192.       }
  193.       get_token();        /* suck up } */
  194.       class = lastclass; 
  195.       break;
  196.     case START_IPGM:                       /* {{ ... }} */
  197.       if (!indefun) groan("This anon defun is dead code!");
  198.       anon_defun();
  199.       break;
  200.     case START_EXP:                    /* (keyword [args]) */
  201.         /* compile the keyword */
  202.       s = compile_exp(lastclass);
  203.       if (s == EDONE) goto done;
  204.       if (s == MAYBE_ARGS)        /* compile the args */
  205.       {
  206.         vargs(); genop(DOOP); class = UNKNOWN;
  207.       }
  208.       lastclass = class; get_token();
  209.       if (class != DELIMITER || *token != ')')
  210.         bitch(spoof(ebuf,"Wanted ) got %s.",token));
  211.       class = lastclass;
  212.       break;
  213.     default:
  214.       bitch(spoof(ebuf,"Invalid delimiter: %s  ?not enough args?",token));
  215.       }
  216.       break;
  217.     default: bitch(spoof(ebuf,"I don't reconize %s!",token));
  218.   }
  219. done:
  220.   clevel--;
  221.   return TRUE;
  222. }
  223.  
  224.     /* Compile (keyword [args])
  225.      * Part of it anyway.  Let somebody else compile the args.
  226.      * Returns:
  227.      *   If need to compile args.
  228.      * Munges:
  229.      *   class, token
  230.      */
  231. compile_exp(lastclass) unsigned int lastclass;
  232. {
  233.   KeyWord *kw;
  234.  
  235.   lookahead();
  236.  
  237.   if (class == DELIMITER && *token == END_EXP)    /* () */
  238.     { class = EMPTY; return NO_ARGS; }
  239.  
  240.   get_token();
  241.   switch (class)
  242.   {
  243.     case STRING:  gostr(RVSTR,token);  return NO_ARGS;
  244.     case NUMBER:  gonumx(atoN(token)); return NO_ARGS;
  245.     case BOOLEAN: gonum8(RVBOOL,btv);  return NO_ARGS;
  246.     case TOKEN:      break;
  247.     default:
  248.       bitch(spoof(ebuf,
  249.     "Wanted token, string, number or boolean, got %s.",token));
  250.   }
  251.  
  252.   kw = global_look_up(token);
  253.   if (kw && kw->type == KWMutt)        /* Mutt keyword */
  254.     return compile_Mutt_keyword(kw->token, lastclass);
  255.  
  256.   if (var_compile(-1)) return NO_ARGS;
  257.   if (kw)
  258.   {
  259.     switch (kw->type)
  260.     {
  261.       case KWXToken:
  262.     gonum16(PUSHXT,kw->token);    /* !!!??? pass in name? */
  263.     return MAYBE_ARGS;
  264.       case KWGlobalVar:
  265.     var_compile(kw->token);
  266.     return NO_ARGS;
  267.       case KWConst:
  268.     genvar(token,TRUE);    /* illegal, generate an error message */
  269.     return NO_ARGS;
  270.       case KWProgram:
  271.     goaddr(PUSHADDR,pgmaddr(kw->token),token);
  272.     return MAYBE_ARGS;
  273.       default:        /* Unknown */
  274.     printf("????? shouldn't get here (1)!");
  275.     return NO_ARGS;
  276.     }
  277.   }
  278.     /* Unknown keyword, probably an external fcn call */
  279.   gostr(PUSHNAME,token);
  280.   return MAYBE_ARGS;
  281. }
  282.  
  283. compile_Mutt_keyword(t, lastclass) unsigned int lastclass;
  284. {
  285.   int l1, ldone, z;
  286.  
  287.   class = lastclass;
  288.   switch (t)
  289.   {
  290.     case 64:                          /* (include file) */
  291.       get_token();
  292.       if (class != TOKEN && class != STRING)
  293.     bitch("include requires token or string.");
  294.       clevel--; class = include(token); clevel++;
  295.       return EDONE;    /* end of this line !!! sleaze */
  296.     case 23: class = comp_if(lastclass); break;            /* (if ...) */
  297.     case 5:  class = comp_while();     break;             /* (while ...) */
  298.     case 76: class = comp_for();     break;               /* (for ...) */
  299.     case 1:  class = comp_cond();     break;              /* (cond ...) */
  300.     case 4:  class = comp_switch();     break;            /* (switch ...) */
  301.     case 2:                        /* (defun name pgm) */
  302.       if (clevel != 0) moan("Can't nest defuns.");
  303.       indefun = TRUE;
  304.       defun();
  305.       indefun = FALSE; class = VOID;
  306.       break;
  307.     case 8: case 6:             /* (label label-name) (goto label) */
  308.       get_token();
  309.       if (class != TOKEN && class != STRING)
  310.     bitch("Label must be token or string.");
  311.       if (!indefun)
  312.     moan("Labels and gotos can only be used inside defuns.");
  313.       if ((z = get_named_label(token)) == -1)
  314.           z = gen_named_label(token);
  315.       if (t == 6) { gojmp(JMP,z); class = VOID; }            /* goto */
  316.       else                               /* label */
  317.       {
  318.     stufflabel(z);
  319.     class = UNKNOWN;    /* can get here from anywhere */
  320.       }
  321.       break;
  322.     case 7:                             /* (break) */
  323.       if (breaklabel == -1) moan("break not allowed here.");
  324.       else gojmp(JMP,breaklabel);
  325.       class = VOID; 
  326.       break;
  327.     case 71:                              /* (continue) */
  328.       if (contlabel == -1) moan("continue not allowed here.");
  329.       else gojmp(JMP,contlabel);
  330.       class = VOID;
  331.       break;
  332.     case  9: genop(DONE);   class = VOID;   break;          /* (done) */
  333.     case 16: genop(HALT);   class = VOID;   break;          /* (halt) */
  334.     case 29: genop(RVVOID); class = VOID;   break;           /* (novalue) */
  335.     case 42: genop(NARGS);  class = NUMBER; break;         /* (nargs) */
  336.     case 43:                             /* (arg n) */
  337.       compile(); type_check(NUMBER,0); genop(ARG); class = UNKNOWN;
  338.       break;
  339.     case 15:                           /* (push-args n) */
  340.       compile(); type_check(NUMBER,0); genop(PUSHARGS);
  341.       class = PUSHEDARGS;
  342.       break;
  343.     case 17:                          /* (push-arg exp) */
  344.       /* Need to push if RV is a string in result.
  345.        * If RV is a function pointer, need to shove.
  346.        */
  347.       compile();
  348.       genop(        /* !!! doesn't always work for floc's */
  349.     (class == STRING || class == UNKNOWN) ? PUSHRV : SHOVERV);
  350.       class = PUSHEDARGS;
  351.       break;
  352.     case 0:                            /* (!= val val) */
  353.       compile(); z = class;
  354.       checkit("!=",STRING,BOOLEAN,NUMBER,0);
  355.       pushpush(); compile();
  356.       if (z != UNKNOWN) type_check(z,0);        /* yukk!!! */
  357.       genop(CMP); genop(NOT); class = BOOLEAN;
  358.       break;
  359.     case 12:                           /* (== val val ... ) */
  360.       compile(); z = class;
  361.       checkit("==",STRING,BOOLEAN,NUMBER,0);
  362.       pushpush(); compile();
  363.       if (z != UNKNOWN) type_check(z,0);    /* yukk!!! */
  364.       if (!gaze_ahead(STRING,BOOLEAN,NUMBER,0))            /* (== val val) */
  365.           genop(CMP);
  366.       else                      /* (== val val val [...]) */
  367.       {
  368.     l1 = genlabel();
  369.     do
  370.     {
  371.       genop(DUP); genop(CMP);
  372.       if (!gaze_ahead(STRING,BOOLEAN,NUMBER,0)) break;
  373.       gojmp(JMPFALSE,l1); compile();
  374.       if (z != UNKNOWN) type_check(z,0);    /* yukk!!! */
  375.     } while (TRUE);
  376.     stufflabel(l1); genop(POP);
  377.       }
  378.       class = BOOLEAN;
  379.       break;
  380.     case 21:                    /* (remove-elements object n z) */
  381.       gonum16(PUSHTOKEN,REMOVE_ELS);
  382.       compile(); checkit("remove-elements", LIST,STRING,0); /* !!!ick */
  383.           /* !!!??? can't be a string constant! */
  384.     genop(SHOVERV);
  385.       compile(); type_check(NUMBER,0); genop(SHOVERV);
  386.       compile(); type_check(NUMBER,0); genop(SHOVERV);
  387.       genop(DOOP); class = VOID;
  388.       break;
  389.     case 18:             /* (insert-object object n new-object ...) */
  390.       gonum16(PUSHTOKEN,INSERT_OBJ);
  391.       compile(); checkit("insert-object", LIST,STRING,0); /* !!!ick */
  392.     genop(SHOVERV);
  393.       compile(); type_check(NUMBER,0); genop(SHOVERV);
  394.       while (gaze_ahead(LIST,STRING,NUMBER,0))
  395.           { compile(); if (class != PUSHEDARGS) genop(SHOVERV); }
  396.       genop(DOOP);
  397.       class = UNKNOWN;    /* !!!Not really - its STRING or LIST */
  398.       break;
  399.     case 24:                      /* (extract-element object n) */
  400.       gonum16(PUSHTOKEN,EXTRACT_EL);
  401.       compile();
  402.       checkit("extract-element", LIST,STRING,0); /* !!!ick */
  403.           /* !!!??? can't be a string constant! */
  404.     genop(SHOVERV);
  405.       compile(); type_check(NUMBER,0); genop(SHOVERV);
  406.       genop(DOOP); class = UNKNOWN;
  407.       break;
  408.     case 25:                   /* (extract-elements object n z) */
  409.       gonum16(PUSHTOKEN,EXTRACT_ELS);
  410.       compile();
  411.       checkit("extract-elements", LIST,STRING,0); /* !!!ick */
  412.           /* !!!??? can't be a string constant! */
  413.     genop(SHOVERV);
  414.       compile(); type_check(NUMBER,0); genop(SHOVERV);
  415.       compile(); type_check(NUMBER,0); genop(SHOVERV);
  416.       genop(DOOP);
  417.       class = UNKNOWN;    /* !!!Not really - its STRING or LIST */
  418.       break;
  419.     case 19:                          /* (length-of object) */
  420.       compile();    /* get object - can be anything */
  421.       genop(LEN_OF);
  422.       class = NUMBER;
  423.       break;
  424.     case 20:                    /* (convert-to type object) */
  425.       compile(); type_check(NUMBER,0); genop(SHOVERV);  /* type */
  426.       compile();    /* get object - can be anything */
  427.       genop(CONVERT_TO);
  428.       class = UNKNOWN; /* !!!I can (sometimes) figure out the type */
  429.           /* !!! do some more checking here */
  430.       break;
  431.     case 28:                               /* (not) */
  432.       compile(); type_check(BOOLEAN,0); genop(NOT); class = BOOLEAN;
  433.       break;
  434.     case 3:  opmath(ADD); break;             /* (+ num num ...) */
  435.     case 67: opmath(SUB); break;             /* (- num num ...) */
  436.     case 65: opmath(MUL); break;             /* (* num num ...) */
  437.     case 69: opmath(DIV); break;             /* (/ num num ...) */
  438.     case 63: opeq(ADD);   break;          /* (+= var num [num ...]) */
  439.     case 68: opeq(SUB);   break;          /* (-= var num [num ...]) */
  440.     case 66: opeq(MUL);   break;          /* (*= var num [num ...]) */
  441.     case 70: opeq(DIV);   break;          /* (/= var num [num ...]) */
  442.     case 11: case 14:                   /* (< num num), (>= num num) */
  443.       compile(); z = class;
  444.       checkit("< or >=",NUMBER,0); pushpush();
  445.       compile();
  446.       if (z != UNKNOWN) type_check(z,0);    /* yukk!!! */
  447.       genop(LT);
  448.       if (t == 14) genop(NOT);    /* (x >= y) == !(x < y) */
  449.       class = BOOLEAN;
  450.       break;
  451.     case 10: case 13:                   /* (<= num num), (> num num) */
  452.       compile(); z = class;
  453.       checkit("<= or >",NUMBER,0); pushpush();
  454.       compile();
  455.       if (z != UNKNOWN) type_check(z,0);    /* yukk!!! */
  456.       genop(LTE);
  457.       if (t == 13) genop(NOT);    /* (x > y) == !(x <= y) */
  458.       class = BOOLEAN;
  459.       break;
  460.     case 81:                           /* (or bool ...) */
  461.       z = JMPTRUE;
  462.     andor:
  463.       ldone = genlabel();
  464.       while (TRUE)
  465.       {
  466.     compile(); type_check(BOOLEAN,0);
  467.     lookahead(); if (class == DELIMITER && *token == ')') break;
  468.     gojmp(z,ldone);
  469.       }
  470.       stufflabel(ldone);
  471.       class = BOOLEAN;
  472.       break;
  473.     case 80: z = JMPFALSE; goto andor;             /* (and bool bool ...) */
  474.     case 26: genop(ASKUSER); break;                  /* (ask-user) */
  475.     case 78: floc(); break;                 /* (floc fcn-name) */
  476.     case 79: loc();  break;                  /* (loc var-name) */
  477.     case 72:                           /* (pointer var) */
  478.       isvarok(clevel,class); pointer(indefun); class = lastclass;
  479.       break;
  480.     case 73:                      /* (array type name subs) */
  481.       isvarok(clevel,class);
  482.       array(indefun ? LOCAL : GLOBAL,FALSE); class = lastclass;
  483.       break;
  484.     case 62:                        /* (bool var [var ...]) */
  485.       t = BOOLEAN;
  486.   defvar:
  487.       isvarok(clevel,class); vdeclare(t,indefun); class = lastclass;
  488.       break;
  489.     case 75: t = INT8;  goto defvar;            /* (byte var [var ...]) */
  490.     case 61: t = INT16; goto defvar;           /* (small-int var [var ...]) */
  491.     case 31: t = INT32; goto defvar;             /* (int var [var ...]) */
  492.     case 60:                    /* (string name [name ...]) */
  493.       t = STRING; goto defobject;
  494.     case 27:                      /* (list name [name ...]) */
  495.       t = LIST;
  496.     defobject:
  497.       isvarok(clevel,class); 
  498.       do
  499.       {
  500.     get_token();
  501.     if (class != TOKEN)
  502.           bitch(spoof(ebuf,"%s is not a var name.",token));
  503.     z = create_var(token, t, 0, (indefun ? LOCAL : GLOBAL));
  504.     if (indefun) genobj(CREATE_OBJ, LOCAL, t, voffset(z));
  505.     lookahead();
  506.       } while (class == TOKEN);
  507.  
  508.       class = lastclass;
  509.       break;
  510.     case 77:                   /* (const name val name val ...) */
  511.       do
  512.       {
  513.     get_token();
  514.     if (class != TOKEN)
  515.           bitch(spoof(ebuf,"%s is not a const name.",token));
  516.     strcpy(temp,token);
  517.     get_token(); rv.type = class;
  518.     switch (class)
  519.     {
  520.       case NUMBER:  rv.val.num = atoN(token); break;
  521.       case BOOLEAN: rv.val.num = btv; break;
  522.       case STRING:  rv.val.str = save_string(token); break;
  523.       case TOKEN:
  524.         if (vtr = getconst(token)) { rv = *vtr; break; }
  525.         /* else fall though and error */
  526.       default:
  527.         moan(spoof(ebuf,"Invalid const type: %s",token));
  528.         rv.type = BOOLEAN;
  529.     }
  530.     add_const(temp,&rv);
  531.     lookahead();
  532.       } while (class == TOKEN);
  533.       class = lastclass;
  534.       break;
  535.     case 32:                               /* (ask ...) */
  536.     case 33:                            /* (concat ...) */
  537.     case 34:                               /* (msg ...) */
  538.     {
  539.       extern oMuttCmd *id_to_oMutt();
  540.  
  541.       other_Mutt_cmd(id_to_oMutt(t));
  542.       break;
  543.     }
  544.     default: moan(spoof(ebuf,"Compiler is confused by %s.",token));
  545.   }
  546.   return NO_ARGS;
  547. }
  548.