Initial commit from Polytechnique Montreal

1 files changed, 300 insertions, 0 deletions

diff --git a/Ganlib/src/objxrf.c b/Ganlib/src/objxrf.c
new file mode 100644
index 0000000..2052525
--- /dev/null
+++ b/Ganlib/src/objxrf.c
@@ -0,0 +1,300 @@
+
+/*****************************************/
+/*             CLE-2000 API              */
+/*   AUTHOR OF FORTRAN VERSION: R. Roy   */
+/*     AUTHOR: A. Hebert ; 11/05/09      */
+/*****************************************/
+
+#include <stdlib.h>
+#include <string.h>
+#include "cle2000.h"
+#include "header.h"
+#define ndclkw 9
+#define ntotxr 7
+#define nmawrd 60
+
+int_32 objxrf(kdi_file *iunito, FILE *iwrite)
+{
+   char *nomsub = "objxrf";
+   static char cl2000[] = "CLE2000(V3)";
+   static char ctitdb[] = "* GAN-2000 VERS 2.1 * DEBUG (WARNINGS AND ERRORS)";
+   static char ctitxr[] = "* GAN-2000 VERS 2.1 * CROSS REFERENCE LISTING";
+   static char *cdclkw[] = {"PROCEDURE", "MODULE", "LINKED_LIST", "XSM_FILE", "SEQ_BINARY",
+                            "SEQ_ASCII", "DIR_ACCESS", "HDF5_FILE", "PARAMETER"};
+   static char *ctypes[] = {"PR", "MD", "LL", "XF", "SB", "SA", "DA", "H5", "--"};
+
+/*     CLE-2000 SYSTEM: R.ROY (11/1999), VERSION 2.1 */
+
+/*             *OBJXRF* X-REF FOR OBJECTS ON THE D.A. UNIT  *IUNITO* */
+/*                      OUTPUT IS WRITTEN ON UNIT           *IWRITE* */
+
+/*        USE:          DRESS UP A LIST OF OBJECTS AND LINES WHERE USED. */
+/*                      IN DEBUG MODE, ATTEMPT TO LIST POSSIBLE ERRORS. */
+
+/*      INPUT: *IUNITO* IS THE DIRECT ACCESS UNIT FOR OBJECT CODE */
+/*             *IWRITE* IS THE OUTPUT UNIT */
+
+/*       NOTE: *OBJXRF* = 0 IF NO PROBLEM WAS ENCOUNTERED WHILE COMPILING */
+
+   int_32 ret_val = 0;
+   int_32 i, iretcd, ninput, nstack, ixrlst, idblst, nobjet, indlin, idclin, idefin, iusein,
+          iofset, ilines, ilevel;
+   char cparin[13], myreco[121], cdatin[121], cerror[13], cdefst[21], cusest[21], myparm[13];
+   int_32 maskck[nmaskc], ipacki[nmaskc];
+   int_32 idebwd[nmawrd+1], ifinwd[nmawrd+1], jndlec[nmawrd];
+   int_32 lequal=0, istack, linxrf[ntotxr];
+   char my_header[38];
+
+/* 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);
+   ninput = header.ninput;
+   nstack = header.nstack;
+   ixrlst = header.ixrlst;
+   idblst = header.idblst;
+   nobjet = header.nobjet;
+   if (strcmp(cparin, cl2000) != 0) goto L9025;
+
+/* CASES WHERE THERE ARE NO OBJECTS/MODULE */
+   if (nobjet == 0) goto L666;
+
+/* CASE WHERE DEBUG IS ACTIVE */
+   if (idblst > 0) {
+      int_32 lfirst = 1;
+      int_32 irecor;
+      strcpy(cerror, "            ");
+      strcpy(cdefst, "                    ");
+      strcpy(cusest, "                    ");
+      for (irecor = ninput + nstack + 1; irecor <= ninput + nstack + nobjet; ++irecor) {
+         iofset = (irecor - 1) * lrclen;
+         iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2));
+         if (iretcd != 0) goto L9023;
+         strcpy(cparin, record2.cparin);
+         strcpy(cdatin, record2.cdatin);
+         indlin = record2.indlin;
+         idclin = record2.idclin;
+         idefin = record2.idefin;
+         iusein = record2.iusein;
+         if (abs(indlin) == 1 || abs(indlin) == 2 || abs(indlin) == 8) goto L60;
+         if (idefin == 0) {
+            strcpy(cdefst, "NOT DEFINED");
+            if (iusein == 0) {
+               strcpy(cusest, "NOT USED");
+               strcpy(cerror, "WARNING");
+            } else {
+               strcpy(cusest, "BEFORE DEFINED");
+               strcpy(cerror, "EXTERNAL");
+            }
+         } else if (iusein == 0) {
+            strcpy(cusest, "NOT USED");
+            strcpy(cerror, "WARNING");
+         } else {
+            if (idclin > idefin) {
+               strcpy(cdefst, "BEFORE DECLARED");
+               strcpy(cerror, "ERROR");
+               ++ret_val;
+            }
+            if (idefin > iusein) {
+               strcpy(cusest, "BEFORE DEFINED");
+               strcpy(cerror, "ERROR");
+               ++ret_val;
+            }
+         }
+         if (lfirst && strcmp(cerror, "            ") != 0) {
+            fprintf(iwrite, "\n");
+            fprintf(iwrite, "%-72s\n", ctitdb);
+            fprintf(iwrite, " REPORT-----/OBJECT------/DEFINED-STATUS------/USED-STATUS---------\n");
+            lfirst = 0;
+         }
+         if (strcmp(cerror, "            ") != 0) {
+            fprintf(iwrite, "%-12s/%-12s/%-20s/%-20s\n", cerror, cparin, cdefst, cusest);
+         }
+L60:
+         ;
+      }
+      if (!lfirst) {
+         if (ret_val > 0) {
+            fprintf(iwrite, " REPORT-----> NB. OF ERRORS=%7d\n", (int)ret_val);
+            fprintf(iwrite, " REPORT-----> MAY STILL EXECUTE WELL...\n");
+         }
+         fprintf(iwrite, " \n");
+      }
+   }
+
+/* CASE WHERE NO XREF WAS ASKED */
+   if (ixrlst <= 0) goto L666;
+   fprintf(iwrite, "%-72s\n", ctitxr);
+   fprintf(iwrite, " \n");
+   fprintf(iwrite, "     OBJECT      TYPE LIN_DCL    ****   FOUND IN LINES (- MEANS NEW EVALUATION)  ****\n");
+   fprintf(iwrite, " \n");
+
+/* ***  MAIN LOOP OVER VARIABLES (BEGIN) */
+   for (istack = ninput + nstack + 1; istack <= ninput + nstack + nobjet; ++istack) {
+      int_32 ilogin = 0;
+      int_32 jlines = 0;
+      int_32 iuseln = 0;
+      int_32 idefln = 0;
+      int_32 nxreft = 0;
+      int_32 irecor;
+
+      iofset = (istack - 1) * lrclen;
+      iretcd = kdiget_c(iunito, (int_32 *)&record2, iofset, kdisize(record2));
+      if (iretcd != 0) goto L9023;
+      strcpy(myparm, record2.cparin);
+      strcpy(cdatin, record2.cdatin);
+      indlin = record2.indlin;
+      idclin = record2.idclin;
+      idefin = record2.idefin;
+      iusein = record2.iusein;
+
+/*    IF WE DO NOT WANT TO SEE PROCEDURES */
+/*    IF( ABS(INDLIN).EQ.1 ) GO TO 200 */
+/*    IF WE DO NOT WANT TO SEE MODULES */
+      if (abs(indlin) == 2) goto L200;
+
+/*    PREPARE HEADER FOR VARIABLE *MYPARM* */
+      sprintf(my_header, " %-4d %-12s %-2s    %04d_", (int)istack, myparm, ctypes[abs(indlin)-1], (int)idclin);
+
+/*    ***  MAIN LOOP OVER RECORDS   (BEGIN) */
+      for (irecor = 2; irecor <= ninput; ++irecor) {
+         int_32 iloop1, jloop2;
+         char cparav[13];
+
+/*       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 OUTSIDE CLE-2000 */
+         if (ilevel == 0) {
+            int_32 iwords = 1;
+            int_32 nwords = 1;
+            int_32 jbiprv = 0;
+
+/*          SKIP OBJECT/MODULE DECLARATIONS */
+            if (strcmp(cparin, " ") != 0) {
+               ilogin = 0;
+               for (iloop1 = 1; iloop1 <= ndclkw; ++iloop1) {
+                  if (strcmp(cparin, cdclkw[iloop1-1]) == 0) ilogin = iloop1;
+               }
+               lequal = 0;
+            }
+            if (ilogin != 0) goto L100;
+
+/*          HERE, WE HAVE FOUND A SENTENCE INCLUDING A STACK... */
+
+/*          BEGIN: MASK RECOVERY */
+            for (iloop1 = 1; iloop1 <= 72; ++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) */
+
+            for (iloop1 = 1; iloop1 <= nwords; ++iloop1) {
+               if (jndlec[iloop1-1] == 2 && myreco[idebwd[iloop1-1]-1] != '\''
+                   && ifinwd[iloop1-1] - idebwd[iloop1-1] <= 11) {
+                  strncpy(cparav, &myreco[idebwd[iloop1-1]-1], ifinwd[iloop1-1]-idebwd[iloop1-1]+1);
+                  cparav[ifinwd[iloop1-1]-idebwd[iloop1-1]+1] = '\0';
+                  if (strcmp(cparav, ";") == 0 || strcmp(cparav, "::") == 0) {
+                     if (!lequal && idefln != 0) iuseln = idefln;
+
+/*                   RESET *ILOGIN* AND LEFT/RIGHT NUMBERS */
+                     ilogin = -10;
+                     idefln = 0;
+                     goto L55;
+                  } else if (lequal) {
+                     if (strcmp(cparav, myparm) == 0) {
+/*                              USING THIS VARIABLE */
+                        if (iuseln == 0) iuseln = ilines;
+                     }
+                  } else {
+                     if (strcmp(cparav, ":=") == 0) {
+                        lequal = 1;
+/*                      *:=* SIGN IMPLIES REDEFINITION */
+                        if (idefln != 0) iuseln = -idefln;
+                        idefln = 0;
+                     } else {
+/*                      KEEP THE DEFINITION LINE UNTIL *:=* OR END */
+                        if (strcmp(cparav, myparm) == 0) idefln = ilines;
+                     }
+                  }
+               }
+            }
+L55:
+            ;
+         }
+
+/*       HAVE WE FOUND A NEW XREF LINE ? */
+         if (iuseln != 0 && iuseln != jlines) {
+            if (nxreft == ntotxr) {
+               char xline[81];
+               sprintf(&xline[0], "%-24s", my_header);
+               for (i = 0; i < ntotxr; i++) sprintf(&xline[24 + 8*i], "    %04d", (int)linxrf[i]);
+               fprintf(iwrite, "%-80s\n", xline);
+               strcpy(my_header, " ");
+               nxreft = 0;
+            }
+            ++nxreft;
+            linxrf[nxreft-1] = iuseln;
+            jlines = iuseln;
+         }
+         iuseln = 0;
+
+L100:
+         ;
+      }
+/*      ***  MAIN LOOP OVER RECORDS   (END) */
+
+/*    POSSIBLE INCOMPLETE LAST LINE... */
+      if (nxreft != 0) {
+         char xline[81];
+         sprintf(&xline[0], "%-24s", my_header);
+         for (i = 0; i < nxreft; i++) sprintf(&xline[24 + 8*i], "    %04d", (int)linxrf[i]);
+         fprintf(iwrite, "%-80s\n", xline);
+      } else if (strcmp(my_header, " ") != 0) {
+         fprintf(iwrite, "%-24s <= WARNING: NEVER DEFINED, NEVER USED... POSSIBLE ERROR\n", my_header);
+      }
+L200:
+      ;
+   }
+/* ***  MAIN LOOP OVER VARIABLES (END) */
+
+   fprintf(iwrite, " \n");
+L666:
+   return ret_val;
+
+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;
+} /* objxrf */