path: root/Ganlib/src/objstk.c

/*****************************************/
/*             CLE-2000 API              */
/*   AUTHOR OF FORTRAN VERSION: R. Roy   */
/*     AUTHOR: A. Hebert ; 12/05/09      */
/*****************************************/

#include <stdlib.h>
#include <string.h>
#include "cle2000.h"
#include "header.h"
#define index_f(A, B) (strstr(A, B) == NULL ? 0 : strstr(A, B) - A + 1)
#define maxdxt 200 /* maximum number of modules */
#define ndclkw 9
#define nmodst 15
#define nmawrd 60

int_32 objstk(kdi_file *iunito, FILE *iwrite, int_32 ldatav)
{
   char *nomsub="objstk";
   static char cerror[] = "* GAN-2000 VERS 2.1 * ERROR FOUND FOR THIS LINE";
   static char cl2000[] = "CLE2000(V3)";
   static char alphab[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz";
   static char digits[] = "0123456789";
   static char *ckeywd[] = {"INTEGER", "REAL", "STRING", "DOUBLE", "LOGICAL", "EVALUATE", "ECHO", "ELSEIF",
                            "IF", "WHILE", "UNTIL", "ENDWHILE", "REPEAT", "ELSE", "ENDIF", "THEN", "DO",
                            "QUIT", "NOT", "ABS", "CHS", "LN", "SIN", "COS", "TAN", "ARCSIN", "ARCCOS",
                            "ARCTAN", "EXP", "SQRT", "R_TO_I", "D_TO_I", "I_TO_R", "D_TO_R", "I_TO_D",
                            "R_TO_D", "I_TO_S", "I_TO_S4", "_MIN_", "_MAX_", "_TRIM_"};
   static char *cdclkw[] = {"PROCEDURE", "MODULE", "LINKED_LIST", "XSM_FILE", "SEQ_BINARY", "SEQ_ASCII",
                            "DIR_ACCESS", "HDF5_FILE", "PARAMETER"};

/*     GAN-2000 SYSTEM: R.ROY (12/1999), VERSION 2.0 */

/*             *OBJSTK* FIRST-PASS COMPILE OF THE D.A. UNIT   *IUNITO* */
/*                                 NOW INCLUDING OBJECTS & MODULES */
/*                      RESULT IS STILL THE OBJECT D.A. UNIT  *IUNITO* */
/*                      COMPILER COMMENTS ARE WRITTEN ON UNIT *IWRITE* */
/*                      STACK IS BUILT AT THE END OF          *IUNITO* */

/*        USE:          MODULE+OBJECT NAMES ARE DEFINED AND ALLOCATED, */
/*                      CONSISTENCE OF OBJECTS IN CALL */
/*                      STATEMENTS ARE ALSO CHECKED. */

/*      INPUT: *IUNITO* IS THE DIRECT ACCESS UNIT FOR OBJECT CODE */
/*             *IWRITE* IS THE OUTPUT UNIT FOR COMPILER COMMENTS */
/*             *LDATAV* =0/1: PROCEDURE SECTION/DATA SECTION */

/*       NOTE: *OBJSTK* = 0 IF NO PROBLEM WAS ENCOUNTERED WHILE COMPILING */

   int_32 ret_val = 0;
   char cmodul[13], cparin[13], cparav[13], myreco[121], cdatin[121];
   int_32 i, iretcd, nrecor, ninput, nstack, idblst, idatin, iofset, iloop1, jloop2, ilines,
          ilevel, indlin, idclin, idefin, iusein;
   float_32 adatin;
   double_64 ddatin;
   int_32 maskck[nmaskc], ipacki[nmaskc];
   int_32 idebwd[nmawrd+1], ifinwd[nmawrd+1], jndlec[nmawrd];
   int_32 ivabeg, ivaend, ilogin, lequal, nobjet, ndatav, imodul, logprv, nembed, nmodul;
   int_32 irecor, krecor=0;

/* READ TOP OF OBJECT FILE */
   iretcd = kdiget_c(iunito, (int_32 *)&header, 0, kdisize(header));
   if (iretcd != 0) goto L9023;
   strcpy(cparin, header.cparin);
   strcpy(myreco, header.cdatin);
   nrecor = header.nrecor;
   ninput = header.ninput;
   nstack = header.nstack;
   idblst = header.idblst;
   if (strcmp(cparin, cl2000) != 0) goto L9025;
   if (idblst > 0) {
      printf("%-120s   LINE\n", cerror);
      printf(" \n");
   }
   ivabeg = ninput + nstack;
   ivaend = ninput + nstack;
   ilogin = 0;
   lequal = 0;
   nobjet = -1;
   ndatav = -1;
   imodul = 0;
   logprv = 1;
   nembed = 0;
   nmodul = 0;

/* ***  MAIN LOOP OVER RECORDS (BEGIN) */
   for (irecor = 2; irecor <= ninput; ++irecor) {
      int_32 iwords = 1;
      int_32 nwords = 1;
      int_32 jbiprv = 0;

/*    READ A NEW RECORD */
      iofset = (irecor - 1) * lrclen;
      iretcd = kdiget_c(iunito, (int_32 *)&record1, iofset, kdisize(record1));
      if (iretcd != 0) goto L9023;
      strcpy(cparin, record1.cparin);
      strcpy(myreco, record1.myreco);
      ilines = record1.ilines;
      ilevel = record1.ilevel;
      for (i = 0; i < nmaskc; i++) maskck[i] = record1.maskck[i];
      for (i = 0; i < nmaskc; i++) ipacki[i] = record1.ipacki[i];

/*    RECORDS  INSIDE CLE-2000, NOTHING TO DO */
      if (ilevel != 0) goto L100;

/*    RECORDS OUTSIDE CLE-2000, SCRUTINIZE... */

/*    BEGIN: MASK RECOVERY */
      for (iloop1 = 1; iloop1 <= 120; ++iloop1) {
         int_32 jbicur;
         jloop2 = (iloop1 + 23) / 24;
         jbicur = maskck[jloop2 - 1] % 2;
         iwords += jbiprv * (1 - jbicur);
         idebwd[nwords - 1] = iloop1;
         ifinwd[iwords - 1] = iloop1;
         nwords += jbicur * (1 - jbiprv);
         jbiprv = jbicur;
         maskck[jloop2 - 1] /= 2;
      }
      --nwords;
/*    END:   MASK RECOVERY */

/*    BEGIN: UNPACK JNDLEC WITH TYPES (ITYP-1) */
      for (iloop1 = 1; iloop1 <= nwords; ++iloop1) {
         jloop2 = ((iloop1 << 1) + 23) / 24;
         jndlec[iloop1 - 1] = ipacki[jloop2 - 1] % 4;
         ipacki[jloop2 - 1] /= 4;
      }
/*    END:   UNPACK JNDLEC WITH TYPES (ITYP-1) */

/*    CHECK ALL DECLARATION STATEMENTS, IF NOT YET FOUND */
      if (logprv) {
         krecor = irecor;
         if (jndlec[0] == 2 && myreco[idebwd[0]-1] != '\'' && ifinwd[0]-idebwd[0] <= 11) {
            strncpy(cparav, &myreco[idebwd[0]-1], ifinwd[0]-idebwd[0]+1);
            cparav[ifinwd[0]-idebwd[0]+1] = '\0';
            for (iloop1 = 1; iloop1 <= ndclkw; ++iloop1) {
               if (strcmp(cparav, cdclkw[iloop1-1]) == 0) ilogin = iloop1;
            }
            if (ilogin != 0) {
               strcpy(cmodul, cdclkw[ilogin-1]);
               imodul = -ilogin;
               ++nmodul;
            }
         }
      }
      logprv = 0;

/*    SCAN OTHER WORDS */
      for (iloop1 = 1; iloop1 <= nwords; ++iloop1) {
         int_32 ileng = ifinwd[iloop1-1] - idebwd[iloop1-1] + 1;

/*       ARE WE IN THE DATA SECTION ? */
         if (ldatav) {
            ++ndatav;
/*          INSIDE  THE DATA SECTION ( ...   :: *HERE* ) */
/*          THEN COUNT EMBEDDED MODULES UNTIL MODULE ENDING */
            if (jndlec[iloop1-1] == 2 && myreco[idebwd[iloop1-1]-1] != '\''
                && ifinwd[iloop1-1]-idebwd[iloop1-1] <= 2) {
               strncpy(cparav, &myreco[idebwd[iloop1-1]-1], ileng);
               cparav[ileng] = '\0';
               if (strcmp(cparav, ":::") == 0) {
                  ++nembed;
               } else if (strcmp(cparav, ";") == 0) {
                  if (iloop1 != nwords) goto L9010;
                  if (nembed == 0) {
/*                          END OF STATEMENT REACHED */
                     logprv = 1;
                  } else {
                     --nembed;
                  }
               } else if (strcmp(cparav, "::") == 0) {
                  goto L5002;
               }
            }
         } else {
            char clisto[17];
/*          OUTSIDE THE DATA SECTION ( *HERE*  ::  ... ) */
/*          NOTE:   EVERY OBJECT/MODULE MUST BE FIRST DECLARED */
            if (jndlec[iloop1-1] != 2 || myreco[idebwd[iloop1-1]-1] == '\''
                || ifinwd[iloop1-1]-idebwd[iloop1 - 1] > 15) goto L5001;
            strncpy(clisto, &myreco[idebwd[iloop1-1]-1], ileng);
            clisto[ileng] = '\0';
            if (ifinwd[iloop1-1]-idebwd[iloop1-1] == 1 && strcmp(clisto, ":=") == 0) {
               lequal = 1;
            } else {
/*             REMAININGS: 1 MODULE & OBJECTS ... */
               if (ifinwd[iloop1-1]-idebwd[iloop1-1] > 11) goto L5001;
               strncpy(cparav, &myreco[idebwd[iloop1-1]-1], ileng);
               cparav[ileng] = '\0';
               if (strcmp(cparav, ";") == 0) {
                  if (iloop1 != nwords) goto L9010;
/*                END OF STATEMENT REACHED " "*/
                  logprv = 1;
               } else if (strcmp(cparav, "::") == 0) {
                  ldatav = 1;
               } else if (strcmp(cparav, ":::") == 0) {
                  goto L5002;
               } else {
/*                USING *CPARAV* VARIABLE, SCAN ALL DECLARED OBJECTS */
                  int_32 ilowrc = ivabeg;
                  int_32 ihigrc = ivaend + 1;
L41:
                  if (ihigrc - ilowrc <= 1) {
                     char cc[2];
/*                   OBJECT/MODULE NOT FOUND */
                     if (ilogin == 0) goto L5004;
                     ++ivaend;

/*                   SHIFT GREATER VALUES */
                     if (ihigrc != ivaend) {
                        for (jloop2 = ivaend - 1; jloop2 >= ihigrc; --jloop2) {
                           iofset = (jloop2 - 1) * lrclen;
                           iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2));
                           if (iretcd != 0) goto L9003;
                           iofset = jloop2 * lrclen;
                           iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2));
                           if (iretcd != 0) goto L9001;
                        }
                     }

/*                   CHECK IF OBJECT/MODULE NAME COMPLIES WITH THE RULES */
                     strncpy(&cc[0], &cparav[0], 1); cc[1] = '\0';
                     if (index_f(alphab, cc) == 0) {
                        printf("%s: CHARACTER *%s* IS NOT ALLOWED\n",nomsub, cc);
                        goto L5001;
                     }
                     for (jloop2 = 2; jloop2 <= strlen(cparav); ++jloop2) {
                        int_32 jin1, jin2, jin3, jin4, jin5;
                        strncpy(&cc[0], &cparav[jloop2-1], 1); cc[1] = '\0';
                        jin1 = index_f(alphab, cc);
                        jin2 = index_f(digits, cc);
                        jin3 = index_f(cc, " ");
                        jin4 = index_f(cc, ".");
                        jin5 = index_f(cc, ":");
                        if (jin1 + jin2 + jin3 + jin4 + jin5 == 0) {
                           printf("%s: CHARACTER *%1s* IN *%s* IS NOT ALLOWED\n",nomsub, cc, cparav);
                           goto L5001;
                        }
                     }

/*                   CHECK IF OBJECT/MODULE NAME IS A KEYWORD */
                     for (jloop2 = 1; jloop2 <= 40; ++jloop2) {
                        if (strcmp(cparav, ckeywd[jloop2-1]) == 0) {
                           printf("%s: OBJECT *%s* IS A CLE-2000 KEYWORD\n", nomsub, cparav);
                           goto L5001;
                        }
                     }

/*                   VALID OBJECT/MODULE NAME, WRITE AT END */
                     for (i = 0; i < 120; i++) cdatin[i] = ' ';
                     cdatin[120] = '\0';
                     indlin = -ilogin;
                     idatin = 0;
                     adatin = 0.f;
                     ddatin = 0.;
                     idclin = ilines;
                     idefin = 0;
                     iusein = 0;
                     for (jloop2 = 0; jloop2 < ndclkw; ++jloop2) {
/*                              TO ACCEPT DECLARATIONS AS DEFINED MODULES */
                        if (strcmp(cparav, cdclkw[jloop2]) == 0) indlin = 2;
                     }

/*                   VALID OBJECT/MODULE NAME, WRITE AT *IHIGRC* */
                     iofset = (ihigrc - 1) * lrclen;
                     strcpy(record2.cparin, cparav);
                     strcpy(record2.cdatin, cdatin);
                     record2.indlin = indlin;
                     record2.idatin = idatin;
                     record2.adatin = adatin;
                     record2.ddatin = ddatin;
                     record2.idclin = idclin;
                     record2.idefin = idefin;
                     record2.iusein = iusein;
                     iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2));
                     if (iretcd != 0) goto L9001;
                     ++nobjet;
                  } else {
                     int_32 imedrc = (ihigrc + ilowrc) / 2;
                     iofset = (imedrc - 1) * lrclen;
                     iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2));
                     if (iretcd != 0) goto L9003;
                     strcpy(cparin, record2.cparin);
                     strcpy(cdatin, record2.cdatin);
                     indlin = record2.indlin;
                     idatin = record2.idatin;
                     adatin = record2.adatin;
                     ddatin = record2.ddatin;
                     idclin = record2.idclin;
                     idefin = record2.idefin;
                     iusein = record2.iusein;
                     if (strcmp(cparin, cparav) == 0) {
/*                      OBJECT/MODULE FOUND */
                        if (ilogin != 0) {
/*                         DECLARATION STATEMENT, VERIFY CONSISTENCY */
/*                         IF IT IS THE DECLARATION MODULE NAME */
                           if (strcmp(cparav, cdclkw[ilogin-1]) == 0) {
                              if (indlin != 2) goto L8000;
                           } else {
                              if (abs(indlin) != ilogin) goto L8000;
                           }
                        } else {
                           if (abs(indlin) == 1 || abs(indlin) == 2) {

/*                            PROC/MODULE NAME IS FOUND */
                              strcpy(cmodul, cparav);
                              imodul = abs(indlin);
                              ++nmodul;
                              lequal = 1;
                           } else {
                              if (lequal && iusein == 0) {
/*                               CHANGE FIRST USED LINE FOR OBJECT */
                                 record2.iusein = ilines;
                                 iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2));
                                 if (iretcd != 0) goto L9001;
                              } else if (!lequal && idefin == 0) {
/*                                          CHANGE FIRST DEFINED LINE FOR OBJECT */
                                 record2.idefin = ilines;
                                 iretcd = kdiput_c(iunito, (int_32 *)&record2, iofset, kdisize(record2));
                                 if (iretcd != 0) goto L9001;
                              }
                           }
                           ++nobjet;
                        }
                     } else if (strcmp(cparin, cparav) < 0) {
                        ilowrc = imedrc;
                        goto L41;
                     } else {
                        ihigrc = imedrc;
                        goto L41;
                     }
                  }
               }
            }
         }
      }
/*    STATEMENT END WAS REACHED, */
/*    WRITE MODULE NAME IN 1ST RECORD OF THIS STATEMENT */
      if (logprv) {
         char ctcall[9], ctciox[19], ctcobj[19], ctotcl[121];
         if (nmodul == 0) {
/*          NO MODULE FOUND, IMPOSE */
/*                 => CMODUL = 'IOX:' (WHEN NO OBJECTS) */
/*                 => CMODUL = 'EQU:' (OTHERWISE) */
            if (nobjet == -1) {
               strcpy(cmodul, "IOX:");
            } else {
               strcpy(cmodul, "EQU:");
            }
            nmodul = 1;
            imodul = 2;
         } else if (nmodul != 1) {
            goto L5008;
         }

         iofset = (krecor - 1) * lrclen;
         iretcd = kdiget_c(iunito, (int_32 *)&record1, iofset, kdisize(record1));
         if (iretcd != 0) goto L9023;
         strcpy(cparin, record1.cparin);
         strcpy(myreco, record1.myreco);
         ilines = record1.ilines;
         ilevel = record1.ilevel;
         for (i = 0; i < nmaskc; i++) maskck[i] = record1.maskck[i];
         for (i = 0; i < nmaskc; i++) ipacki[i] = record1.ipacki[i];

/*       WITH MODULE NAME, ADD THE NUMBER OF DATA ITEMS (EXCEPT *;*) */
         strcpy(record1.cparin, cmodul);
         record1.irecor = ndatav;
         iretcd = kdiput_c(iunito, (int_32 *)&record1, iofset, kdisize(record1));
         if (iretcd != 0) goto L9023;
         if (idblst > 0) {
            if (imodul > 0) {
               strcpy(ctcall, "CALL");
            } else {
               strcpy(ctcall, "DECLARE ");
               strcpy(cmodul, " ");
            }
            if (nobjet == -1) {
               strcpy(ctcobj, " WITHOUT  OBJ    ,");
            } else {
               sprintf(ctcobj, " WITH %d OBJ VAL", (int)nobjet);
            }
            if (ndatav == -1) {
               strcpy(ctciox, " WITHOUT  I/O");
            } else {
               sprintf(ctciox, " WITH %d I/O VAL", (int)nobjet);
            }
            sprintf(ctotcl, "%8s%12s%12s%18s%18s", ctcall,cdclkw[abs(imodul)-1],cmodul,ctcobj,ctciox);
            fprintf(iwrite, "%-120s %7d\n", ctotcl, (int)ilines);
         }

/*       RESET THINGS BEFORE NEXT MODULE... */
         nmodul = 0;
         lequal = 0;
         ldatav = 0;
         nobjet = -1;
         ndatav = -1;
         imodul = 0;
         ilogin = 0;
      }

L100:
      ;
   }
/* ***  MAIN LOOP OVER RECORDS (END) */
/* ALL VARIABLES ARE NOW SORTED AT THE END OF THE OBJECT FILE */
/* REWRITE TOP OF OBJECT FILE TO UPDATE *NSTACK+/+NRECOR* */
   nobjet = ivaend - ivabeg;
   nrecor = ivaend;
   header.nrecor = nrecor;
   header.nobjet = nobjet;
   iretcd = kdiput_c(iunito, (int_32 *)&header, 0, kdisize(header));
   if (iretcd != 0) goto L9001;
   if (idblst > 0) fprintf(iwrite, " \n");

L666:
   return ret_val;

L5000:
   printf("%-120s   LINE\n", cerror);
   printf("%-120s   %04d\n", myreco, (int)ilines);
   goto L666;
L5001:
   printf("! %s: INVALID OBJECT/MODULE NAME IN RECORD\n", nomsub);
   ret_val = 5001;
   goto L5000;
L5002:
   printf("! %s: INVALID EMBEDDED MODULES, REVIEW SYNTAX\n", nomsub);
   ret_val = 5002;
   goto L5000;
L5004:
   printf("! %s: OBJECT/MODULE NOT YET DECLARED *%s*\n", nomsub, cparav);
   ret_val = 5004;
   goto L5000;
L5008:
   printf("! %s: MORE THAN 1 MODULE FOUND\n", nomsub);
   ret_val = 5008;
   goto L5000;
L8000:
   printf("! %s: *%s* NOW WITH TYPE %s\n", nomsub, cparav, cdclkw[ilogin-1]);
   ret_val = 8000;
   goto L5000;
L9001:
   iretcd = -1;
   printf("! %s: WRITING RETURN CODE =%d\n", nomsub, (int)iretcd);
   ret_val = iretcd;
   goto L666;
L9003:
   iretcd = -1;
   printf("! %s: READING RETURN CODE =%d\n", nomsub, (int)iretcd);
   ret_val = iretcd;
   goto L666;
L9010:
   printf("! %s: UNEXPECTED END OF STATEMENT\n", nomsub);
   ret_val = 9010;
   goto L5000;
L9023:
   iretcd = -1;
   printf("! %s: IOSTAT RETURN CODE =%d\n", nomsub, (int)iretcd);
   printf("! %s: IMPOSSIBLE TO USE THIS *OBJECT* FILE\n", nomsub);
   ret_val = -2;
   goto L666;
L9025:
   printf("! %s: IMPOSSIBLE TO USE OLD  *OBJECT* FILE\n", nomsub);
   ret_val = -3;
   goto L666;
} /* objstk */