From 7dfcc480ba1e19bd3232349fc733caef94034292 Mon Sep 17 00:00:00 2001 From: stainer_t Date: Mon, 8 Sep 2025 13:48:49 +0200 Subject: Initial commit from Polytechnique Montreal --- Ganlib/src/clelog.c | 772 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 772 insertions(+) create mode 100644 Ganlib/src/clelog.c (limited to 'Ganlib/src/clelog.c') diff --git a/Ganlib/src/clelog.c b/Ganlib/src/clelog.c new file mode 100644 index 0000000..3c1db28 --- /dev/null +++ b/Ganlib/src/clelog.c @@ -0,0 +1,772 @@ + +/*****************************************/ +/* CLE-2000 API */ +/* AUTHOR OF FORTRAN VERSION: R. Roy */ +/* AUTHOR: A. Hebert ; 09/05/09 */ +/*****************************************/ + +#include +#include "cle2000.h" +#include "header.h" +#define min(A,B) ((A) < (B) ? (A) : (B)) +#define max(A,B) ((A) > (B) ? (A) : (B)) +#define index_f(A, B) (strstr(A, B) == NULL ? 0 : strstr(A, B) - A + 1) +#define ndecal 4 +#define nmawrd 60 +#define ndimst 128 +static char AbortString[132]; + +int_32 clelog(FILE *iredin, FILE *iwrite, kdi_file *iunito) +{ + char *nomsub="clelog"; + static char cl2000[] = "CLE2000(V3)"; + static int_32 lvelbg[] = {0, 0, 0, 0, 0, 0, 0, -1, 0, 0, -1, -1, 0, -1, -1}; + static char *clognd[] = {";", ";", ";", ";", ";", ";", ";", "THEN", "THEN", "DO", + ";", ";", "REPEAT", "ELSE", ";"}; + static int_32 lvelnd[] = {0, 0, 0, 0, 0, 0, 0, 0, 1, 1, -1, -1, 1, 0, -1}; + static char ctitle[] = "* CLE-2000 VERS 3.0 * R.ROY, EPM COPYRIGHT 1999 *"; + static char *terror[] = {"! CLELOG: UNEXPECTED CHARACTERS TO BE REPLACED WITH BLANKS", + "! CLELOG: UNBALANCED OPENING OR CLOSING STRINGS", + "! CLELOG: MISPLACED SEMICOLON ...; OR ;... OR ...;...", + "! CLELOG: CHARACTERS SUPPRESSED OUTSIDE COLUMN RANGE 1:120", + "! CLELOG: << AND >> NOT ALLOWED IN STRINGS (SUPPRESSED)", + "! CLELOG: (* ... *) INVALID COMMENTS (USE ! INSTEAD)", + "! CLELOG: QUIT \"...\" . SHOULD APPEAR ALONE A SINGLE LINE"}; + static char csemic[] = ";"; + static char digped[] = "0123456789+-.ED"; + static char onelet[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-*/%<>=;"; + static char *clogbg[] = {"INTEGER", "REAL", "STRING", "DOUBLE", "LOGICAL", "EVALUATE", "ECHO", + "ELSEIF", "IF", "WHILE", "UNTIL", "ENDWHILE", "REPEAT", "ELSE", "ENDIF"}; + +/* CLE-2000 SYSTEM: R.ROY (11/1999), VERSION 3.0 */ + +/* *CLELOG* FIRST-PASS COMPILE OF THE INPUT UNIT *IREDIN* */ +/* COMPILER COMMENTS ARE WRITTEN ON UNIT *IWRITE* */ +/* RESULT IS THE OBJECT D.A. UNIT *IUNITO* */ + +/* USE: INPUT DATA IS COPIED ON D.A. UNIT, */ +/* SENTENCES AND LOGIC DESCRIPTORS ARE SEPARATED, */ +/* LOGICAL LEVELS ARE BUILT AND LOGIC IS CHECKED. */ + +/* INPUT: *IREDIN* IS THE INPUT UNIT */ +/* *IWRITE* IS THE OUTPUT UNIT FOR COMPILER COMMENTS */ +/* *IUNITO* IS THE DIRECT ACCESS UNIT FOR OBJECT CODE */ + +/* NOTE: *CLELOG* = 0 IF NO PROBLEM WAS ENCOUNTERED WHILE COMPILING */ + + int_32 ret_val = 0, lapos1 = 0, lapos2 = 0; + int_32 ilines = 0, idblst = -1, ixrlst = -1, ioulst = -1, lnwsen = 1, lrecio = 1, l1lett = 1, + nequal = 0, nwrsen = -2, nrecio = 0, nlevel = 1, maxlvl = 0, irecor = 0, nstlvl = 0, + ninput = 1, nstack = 0, nrecor = 1; + int_32 i, iloop1, jloop2, iretcd, iofset, ilevel, ilogin=0; + int_32 maskck[nmaskc], ipacki[nmaskc]; + int_32 idebwd[nmawrd], ifinwd[nmawrd], jndlec[nmawrd]; + int_32 irclvl[ndimst], itylvl[ndimst]; + char crecbg[13], chrend[13], cerror[121]; + char recred[134+ndecal], cemask[121], myreco[121], cbla120[120], rwrite[121]; + int_32 jcm0bg, jst2bg, jfndbg; + int_32 jst1bg, jfndnd, jcm0nd; + int_32 ilengv=0, jsc0bg; + int_32 jkthen, jkelse, jkrepe, jkdodo, jquitp; + int_32 lnbprv, nwords, iapo12=0; + int_32 iwords; + char crecnd[13]; + + fprintf(iwrite, "%-120s LINE\n", ctitle); + for ( i = 0; i < 120; i++) cbla120[i] = ' '; + strcpy(crecbg, " "); + strcpy(chrend, csemic); + +/* WRITE TOP OF OBJECT FILE */ + strcpy(header.cparin, cl2000); + strcpy(header.cdatin, " "); + header.nrecor = nrecor; + header.ninput = ninput; + header.maxlvl = maxlvl; + header.nstack = nstack; + header.ixrlst = ixrlst; + header.ioulst = ioulst; + header.idblst = idblst; + header.nobjet = 0; + iretcd = kdiput_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9001; + +/* DUMP INPUT FILE TO OBJECT FILE */ + strncpy(cemask, cbla120, 120); + for ( i = 0; i < ndecal+132; i++) recred[i] = ' '; + recred[ndecal+132] = '\0'; +L10: + ++ilines; +/* READ A NEW RECORD */ + iretcd = fscanf(iredin, "%133[^\n]\n", &recred[ndecal]); + if (iretcd == EOF) goto L100; + if (strlen(&recred[ndecal]) > 132) goto L5000; + for(i = strlen(&recred[ndecal]); i < 132; i++) recred[ndecal+i] = ' '; + recred[ndecal+132] = '\0'; + strncpy(myreco, &recred[ndecal], 120); myreco[120] = '\0'; + +/* OUPUT THE RECORD */ + fprintf(iwrite, "%-120s %04d\n", myreco, (int)ilines); + +/* SUPPRESS RECORD IF ALL COMMENTS OR BLANK */ + if (strncmp(myreco, cbla120, 120) == 0) { + if (ilines == 1) { + sprintf(AbortString,"%s: empty line %d",nomsub,ilines); + xabort_c(AbortString); + } + goto L10; + } + +/* SUPPRESS ! EXCLAMATION COMMENTS FROM *RECRED* AND RECORD */ + jcm0bg = index_f(recred, "!"); + if (jcm0bg != 0) { + for ( i = jcm0bg - 1; i < ndimst; i++) recred[i]=' '; + if (jcm0bg + ndecal - 1 < 120) { + for ( i = jcm0bg - ndecal - 1; i < 120; i++) myreco[i]=' '; + } + } + if (myreco[0] == '*') goto L10; + +/* ANYTHING OUTSIDE COLUMNS NDECAL+1:NDECAL+120 RANGE IN *RECRED* */ + if (strncmp(&recred[ndecal+120], " ", 7) != 0) { + printf("%.132s\n", &recred[ndecal]); + printf("%120s????????\n", " "); + printf("%120s\n", terror[3]); + ++ret_val; + } + for (iloop1 = 0; iloop1 < 120; ++iloop1) { +/* SUPPRESS UNEXPECTED CHARACTERS */ + if (strncmp(&myreco[iloop1], " ", 1) < 0) { + cemask[iloop1] = '?'; + myreco[iloop1] = ' '; + recred[iloop1+ndecal] = ' '; + ++ret_val; + } + } + +/* SUPPRESS STRINGS OF TYPES: '...' OR "...." FROM *RECRED* */ +L25: + jst1bg = index_f(recred, " \'"); + if (jst1bg == 0) jst1bg = 132; + jst2bg = index_f(recred, " \""); + if (jst2bg == 0) jst2bg = 132; + jfndbg = min(jst1bg,jst2bg); + if (jfndbg != 132) { + if (jfndbg == jst1bg) { + jfndnd = index_f(&recred[jfndbg+1], "\' ") + jfndbg + 1; + } else { + jfndnd = index_f(&recred[jfndbg+1], "\" ") + jfndbg + 1; + } + if (jfndnd == jfndbg + 1) { + cemask[jfndbg-ndecal] = '?'; + strcpy(cerror, terror[1]); + ++ret_val; + jfndnd = 132; + } + +/* STRING IS FOUND, CHECK IF << OR >> IS CONTAINED INSIDE */ + strncpy(rwrite, &recred[jfndbg], jfndnd-jfndbg); rwrite[jfndnd-jfndbg] = '\0'; + jcm0bg = index_f(rwrite, "<<") + jfndbg; + jcm0nd = index_f(rwrite, ">>") + jfndbg; + if (jcm0bg != jfndbg) { + memcpy(&cemask[jcm0bg-ndecal-1], "??", 2); + memcpy(&myreco[jcm0bg-ndecal-1], " ", 2); + strcpy(cerror, terror[4]); + ++ret_val; + } + if (jcm0nd != jfndbg) { + memcpy(&cemask[jcm0nd-ndecal-1], "??", 2); + memcpy(&myreco[jcm0nd-ndecal-1], " ", 2); + strcpy(cerror, terror[4]); + ++ret_val; + } + for ( i = jfndbg; i < jfndnd; i++) recred[i] = ' '; + goto L25; + } + +/* CONTROL STRANGE FORMS OF TYPES: ...'... OR ..."... */ + jst1bg = index_f(recred, "'"); + if (jst1bg != 0) { + cemask[jst1bg-ndecal-1] = '?'; + strcpy(cerror, terror[1]); + ++ret_val; + recred[jst1bg-1] = ' '; + myreco[jst1bg-ndecal-1] = ' '; + } + + if (strncmp(cemask, cbla120, 120) != 0) { + fprintf(iwrite, "%-120s\n", cemask); + fprintf(iwrite, "%-120s\n", cerror); + strncpy(cemask, cbla120, 120); + } + +/* SUPPRESS OLD FORMS OF COMMENTS: (*... ...*) */ +L26: + jcm0bg = index_f(recred, "(*"); + jcm0nd = index_f(recred, "*)"); + if (jcm0bg != 0) { + strcpy(cerror, "! WARNING: (* ... *) OBSOLETE COMMENTS (USE ! INSTEAD)"); + if (jcm0nd == 0) { + strncpy(&myreco[jcm0bg-ndecal-1], cbla120, 120-(jcm0bg-ndecal-1)); + strncpy(&recred[jcm0bg-1], cbla120, 132-(jcm0bg-1)); + strcpy(cerror, terror[5]); + ++ret_val; + } else { + strncpy(&myreco[jcm0bg-ndecal-1], cbla120, jcm0nd + 1 - (jcm0bg - 1)); + strncpy(&recred[jcm0bg-1], cbla120, jcm0nd + 1 - (jcm0bg - 1)); + } + goto L26; + } else if (jcm0nd != 0) { + memcpy(&cemask[jcm0nd-ndecal-1], "??", 2); + strcpy(cerror, terror[5]); + ++ret_val; + strncpy(recred, cbla120, jcm0nd + 1); + strncpy(myreco, cbla120, jcm0nd - ndecal + 1); + goto L26; + } + + if (strncmp(cemask, cbla120, 120) != 0) { + fprintf(iwrite, "%-120s\n", cemask); + fprintf(iwrite, "%-120s\n", cerror); + strncpy(cemask, cbla120, 120); + } + +/* TO SEPARATE LOGIC, PUT RETURNS FOR INPUT LINES ENDING WITH: */ +/* *;*, *REPEAT*, *THEN*, *ELSE* OR *DO* */ +L30: + jsc0bg = index_f(recred, " ; "); + if (jsc0bg == 0) { +/* CONTROL STRANGE FORMS OF TYPES: ...; OR ;... OR ...;... */ + jsc0bg = index_f(recred, ";"); + if (jsc0bg != 0) { + cemask[jsc0bg-ndecal-1] = '?'; + strcpy(cerror, terror[2]); + ++ret_val; + recred[jsc0bg-1] = ' '; + myreco[jsc0bg-ndecal-1] = ' '; + } + jfndbg = 132; + } else { + jfndbg = jsc0bg; + ilengv = 1; + } + jkthen = index_f(recred, " THEN "); + if (jkthen == 0) jkthen = 132; + if (jkthen < jfndbg) { + jfndbg = jkthen; + ilengv = 4; + } + jkelse = index_f(recred, " ELSE "); + if (jkelse == 0) jkelse = 132; + if (jkelse < jfndbg) { + jfndbg = jkelse; + ilengv = 4; + } + jkrepe = index_f(recred, " REPEAT "); + if (jkrepe == 0) jkrepe = 132; + if (jkrepe < jfndbg) { + jfndbg = jkrepe; + ilengv = 6; + } + jkdodo = index_f(recred, " DO "); + if (jkdodo == 0) jkdodo = 132; + if (jkdodo < jfndbg) { + jfndbg = jkdodo; + ilengv = 2; + } + jquitp = index_f(recred, " QUIT "); + if (jquitp == 0) jquitp = 132; + if (jquitp < jfndbg) { + jfndbg = jquitp; + ilengv = 4; + } + + if (jfndbg == 132) { + strncpy(rwrite, myreco, 120); + strncpy(myreco, cbla120, 120); + } else { + if (jfndbg == jquitp) { + strncpy(myreco, cbla120, jfndbg - ndecal + ilengv); + goto L200; + } else { + strncpy(rwrite, cbla120, 120); + strncpy(rwrite, myreco, jfndbg - ndecal + ilengv); + strncpy(myreco, cbla120, jfndbg - ndecal + ilengv); + strncpy(&recred[jfndbg], cbla120, jfndbg + ilengv - jfndbg); + } + } + if (strncmp(cemask, cbla120, 120) != 0) { + fprintf(iwrite, "%-120s\n", cemask); + fprintf(iwrite, "%-120s\n", cerror); + strncpy(cemask, cbla120, 120); + goto L30; + } + +/* SUPPRESS RECORD IF ALL IS STILL BLANK */ + if (strncmp(rwrite, cbla120, 120) == 0) goto L10; + +/* NEW RECORD FOUND, READY TO PROCESS *RWRITE* */ + for (iloop1 = 0; iloop1 < nmaskc; ++iloop1) { + maskck[iloop1] = 0; + ipacki[iloop1] = 0; + } + +/* *** BEWARE **** FROM HERE WORDS ARE IN REVERSE ORDER... */ + +/* BEGIN: CONSTRUCT MASK NUMBERS */ + +/* PREVIOUS NON-BLANK CHARACTER (ASSUME BLANK AT START) */ + lnbprv = 0; + nwords = 0; + for (iloop1 = 120; iloop1 >= 1; --iloop1) { + jloop2 = (iloop1 + 23) / 24; + maskck[jloop2-1] <<= 1; + if (lapos1) { +/* ALL CHARACTERS ARE MASKED WHILE *LAPOS1* */ + ++maskck[jloop2-1]; + lapos1 = rwrite[iloop1-1] != '\''; + +/* MAKE AS IF PREVIOUS WAS BLANK */ + lnbprv = 0; + --idebwd[nwords-1]; + } else if (lapos2) { +/* ALL CHARACTERS ARE MASKED WHILE *LAPOS1* */ + ++maskck[jloop2-1]; + lapos2 = rwrite[iloop1-1] != '"'; + +/* MAKE AS IF PREVIOUS WAS BLANK */ + lnbprv = 0; + --idebwd[nwords-1]; + } else { + int_32 lnbcur = rwrite[iloop1-1] != ' '; + if (lnbcur) { +/* FIND A NON-BLANK CHARACTER, MASK IT */ + ++maskck[jloop2-1]; + if (lnbprv) { + --idebwd[nwords-1]; + } else { +/* PREVIOUS ONE WAS BLANK, LOOK FOR ' OR " */ + lapos1 = rwrite[iloop1-1] == '\''; + lapos2 = rwrite[iloop1-1] == '\"'; + if (lapos1 || lapos2) iapo12 = iloop1; +/* BEGIN A NEW WORD (REVERSED ORDER) */ + ++nwords; + ifinwd[nwords-1] = iloop1; + idebwd[nwords-1] = iloop1; + } + } else if (lnbprv) { +/* FIND A BLANK CHARACTER, BUT AFTER A NON-BLANK */ +/* THIS COULD BE A MISTAKE IF ' OR " ARE NOT IN USE. */ + if ((!lapos1 && rwrite[iloop1] == '\'') || (!lapos2 && rwrite[iloop1] == '\"')) { + cemask[iloop1] = '?'; + } + } + lnbprv = lnbcur; + } + } + if (lapos1 || lapos2) { + cemask[iapo12-1] = '?'; + lapos1 = 0; + lapos2 = 0; + } + if (strncmp(cemask, cbla120, 120) != 0) { + fprintf(iwrite, "%-120s\n", cemask); + fprintf(iwrite, "%-120s\n", terror[1]); + strncpy(cemask, cbla120, 120); + } +/* END: CONSTRUCT MASK NUMBERS */ + +/* BEGIN: IDENTITY TYPES AND PACK *JNDLEC* WITH (ITYP-1) DATA */ + for (iwords = 1; iwords <= nwords; ++iwords) { + char cdatin[121]; + int_32 jindex=0; + ilengv = ifinwd[iwords-1] - idebwd[iwords-1] + 1; + strncpy(cdatin, &rwrite[idebwd[iwords-1]-1], ilengv); cdatin[ilengv] = '\0'; + +/* DETERMINATION OF TYPE FOR THAT WORD */ + if (cdatin[0] == '\'' || cdatin[0] == '"') { + jndlec[iwords-1] = 2; + } else if (ilengv == 1) { + jindex = index_f(digped, &cdatin[0]); + if (jindex > 0 && jindex <= 10) { + jndlec[iwords-1] = 0; + } else { + jndlec[iwords-1] = 2; + l1lett = l1lett && index_f(onelet, &cdatin[0]) != 0; + } + } else { + int_32 ipoint = 0; + int_32 ifloat = 0; + int_32 idoubl = 0; + for (iloop1 = 1; iloop1 <= ilengv; ++iloop1) { + char cc[] = {cdatin[iloop1-1], '\0'}; + jindex = index_f(digped, cc); + if (jindex == 0) { + goto L62; + } else if (jindex == 11 || jindex == 12) { + if (iloop1 != 1) { +/* CHECK SIGN AFTER EXPONENT */ + if (iloop1 - 1 != ifloat && iloop1 - 1 != idoubl) { + jindex = 0; + goto L62; + } + } + } else if (jindex == 13) { + if (ipoint != 0) { + jindex = 0; + goto L62; + } + ipoint = iloop1; + } else if (jindex == 14) { + if (ifloat != 0 || iloop1 == 1) { + jindex = 0; + goto L62; + } + ifloat = iloop1; + } else if (jindex == 15) { + if (idoubl != 0 || iloop1 == 1) { + jindex = 0; + goto L62; + } + idoubl = iloop1; + } + } +L62: + if (jindex == 0) { + jndlec[iwords-1] = 2; + } else if (idoubl != 0) { + jndlec[iwords-1] = 3; + } else if (ifloat != 0 || ipoint != 0) { + jndlec[iwords-1] = 1; + } else { + jndlec[iwords-1] = 0; + } + } + jloop2 = (((nwords - iwords + 1) << 1) + 23) / 24; + ipacki[jloop2-1] <<= 2; + ipacki[jloop2-1] += jndlec[iwords-1]; + +/* COUNT FOR THE NUMBER OF *:=*, *<<.>>* AND *>>.<<* */ +/* AND THE NUMBER OF *$.* BEFORE *:=* */ + if (jndlec[iwords-1] == 2) { + if (ilengv == 2 && strcmp(cdatin, ":=") == 0) { + ++nequal; + } else if (ilengv >= 2) { + if (strncmp(cdatin, ">>", 2) == 0) { + lrecio = ilengv >= 5; + if (lrecio) { + lrecio = strcmp(&cdatin[ilengv-2], "<<") == 0 && cdatin[2] != '$'; + } + ++nrecio; + } else if (strncmp(cdatin, "<<", 2) == 0) { + lrecio = ilengv >= 5; + if (lrecio) { + lrecio = strcmp(&cdatin[ilengv-2], ">>") == 0 && cdatin[2] != '$'; + } + ++nrecio; + } + } + } + } +/* END: IDENTITY TYPES AND PACK *JNDLEC* WITH (ITYP-1) DATA */ + +/* NOW, LOOK FOR 1-ST WORD OF SENTENCES */ + if (lnwsen && jndlec[nwords-1] == 2 && ifinwd[nwords-1] - idebwd[nwords-1] <= 11) { + +/* RECOVER 1-ST WORD TO CHECK BEGIN OF SENTENCE */ + char cparin[13]; + strncpy(cparin, &rwrite[idebwd[nwords-1]-1], ifinwd[nwords-1] - idebwd[nwords-1] + 1); + cparin[ifinwd[nwords-1] - idebwd[nwords-1] + 1] = '\0'; + ilogin = 0; + for (iloop1 = 0; iloop1 < 15; ++iloop1) { + if (strcmp(cparin, clogbg[iloop1]) == 0) ilogin = iloop1 + 1; + } + +/* BACKWARD COMPATIBILITY ( *CHARACTER* / *PRINT* ) */ + if (strcmp(cparin, "CHARACTER") == 0) { + ilogin = 3; + strcpy(cerror, "! WARNING: *CHARACTER* => *STRING* (REPLACED)"); + fprintf(iwrite, "%s\n", cerror); + } else if (strcmp(cparin, "PRINT") == 0) { + ilogin = 7; + strcpy(cerror, "! WARNING: *PRINT* => *ECHO* (REPLACED)"); + fprintf(iwrite, "%s\n", cerror); + } + + if (ilogin == 0) { + strcpy(crecbg, " "); + strcpy(chrend, csemic); + } else { + strcpy(crecbg, clogbg[ilogin-1]); + strcpy(chrend, clognd[ilogin-1]); +/* KEYWORDS: *IF+/+WHILE+/+REPEAT* */ + if (ilogin == 9 || ilogin == 10 || ilogin == 13) { + if (nstlvl == ndimst) goto L7000; + ++nstlvl; + itylvl[nstlvl-1] = ilogin; + irclvl[nstlvl-1] = ninput + 1; +/* KEYWORDS: *ENDWHILE* */ + } else if (ilogin == 12) { + if (itylvl[nstlvl-1] != 10) goto L7001; +/* KEYWORDS: *UNTIL* */ + } else if (ilogin == 11) { + if (itylvl[nstlvl-1] != 13) goto L7001; +/* KEYWORD: *ELSEIF+/+ELSE* */ + } else if (ilogin == 8 || ilogin == 14) { + if (nstlvl == 0) goto L7000; + if (itylvl[nstlvl-1] != 8 && itylvl[nstlvl-1] != 9) goto L7001; + itylvl[nstlvl-1] = ilogin; +/* KEYWORD: *ENDIF* */ + } else if (ilogin == 15) { + if (itylvl[nstlvl-1] != 8 && itylvl[nstlvl-1] != 9 && itylvl[nstlvl-1] != 14) goto L7001; + } + +/* KEYWORDS: *UNTIL+/+ENDWHILE+/+ENDIF* */ + if (ilogin == 11 || ilogin == 12 || ilogin == 15) { + int_32 jrecor = ninput + 1; + if (nstlvl == 0) goto L7002; + irecor = irclvl[nstlvl-1]; + --nstlvl; + +/* REWRITE OLD RECORD TO KEEP LINK WITH THIS END */ + iofset = (irecor - 1) * lrclen; + iretcd = kdiget_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9003; + record1.irecor = jrecor; + iretcd = kdiput_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9001; + } + } + } + + if (ilogin == 0) { + ilevel = 0; +/* STATEMENTS OUTSIDE CLE-2000, STRINGS MUST BE '...' */ + for (iwords = 1; iwords <= nwords; ++iwords) { + if (jndlec[iwords-1] == 2 && rwrite[idebwd[iwords-1]-1] == '\"') { + cemask[idebwd[iwords-1]-1] = '?'; + cemask[ifinwd[iwords-1]-1] = '?'; + fprintf(iwrite, "%-120s\n", cemask); + strcpy(cerror, "! WARNING: OUTSIDE CLE-2000, ENCLOSE STRINGS IN '...' (REPLACED)"); + strncpy(cemask, cbla120, 120); + rwrite[idebwd[iwords-1]-1] = '\''; + rwrite[ifinwd[iwords-1]-1] = '\''; + } + } + } else { +/* FOR CLE-2000 STATEMENTS, */ +/* AND INVALID *ILENGV* > 12 FOR STRINGS NOT ENCLOSED BY "..." */ + for (iwords = 1; iwords <= nwords; ++iwords) { + if (jndlec[iwords-1] == 2 && rwrite[idebwd[iwords-1]-1] != '\"') { + if (rwrite[idebwd[iwords-1]-1] == '\'') { + cemask[idebwd[iwords-1]-1] = '?'; + cemask[ifinwd[iwords-1]-1] = '?'; + fprintf(iwrite, "%-120s\n", cemask); + strcpy(cerror, "! WARNING: INSIDE CLE-2000, ENCLOSE STRINGS IN \"...\" (REPLACED)"); + strncpy(cemask, cbla120, 120); + rwrite[idebwd[iwords-1]-1] = '\"'; + rwrite[ifinwd[iwords-1]-1] = '\"'; + } else { + if (ifinwd[iwords-1] - idebwd[iwords-1] > 11) goto L5012; + } + } + } + ilevel = nlevel + lvelbg[ilogin-1]; + maxlvl = max(maxlvl,ilevel); + nwrsen += nwords; + } + +/* RECOVER LAST WORD TO CHECK END OF SENTENCE */ + if (jndlec[0] == 2 && ifinwd[0] - idebwd[0] <= 11) { + strncpy(crecnd, &rwrite[idebwd[0]-1], ifinwd[0] - idebwd[0] + 1); + crecnd[ifinwd[0] - idebwd[0] + 1] = '\0'; + } else { + strcpy(crecnd, " "); + } + +/* WRITE RECORD OR PART OF IT */ + ++ninput; + iofset = (ninput - 1) * lrclen; + strcpy(record1.cparin, crecbg); + rwrite[120] = '\0'; + strcpy(record1.myreco, rwrite); + record1.ilines = ilines; + record1.ilevel = ilevel; + record1.irecor = irecor; + for (i = 0; i < nmaskc; i++) record1.maskck[i] = maskck[i]; + for (i = 0; i < nmaskc; i++) record1.ipacki[i] = ipacki[i]; + iretcd = kdiput_c(iunito, (int_32 *)&record1, iofset, kdisize(record1)); + if (iretcd != 0) goto L9001; + if (!lrecio) goto L7005; + irecor = 0; + strcpy(crecbg, " "); + lnwsen = (strcmp(crecnd, chrend) == 0); + if (lnwsen) { + if (ilogin != 0) { + nlevel += lvelnd[ilogin-1]; + if (nrecio != 0) goto L7005; + if (!l1lett) goto L5001; +/* KEYWORDS: *INTEGER+/+REAL+/+STRING+/+DOUBLE+/+LOGICAL* */ + if (ilogin <= 5) { + if (nequal == 0) { + if (nwrsen <= 0) goto L7004; + } else if (nequal == 1) { + if (nwrsen <= 2) goto L7004; + } else { + goto L7003; + } + if (nlevel != 1) goto L7006; +/* KEYWORD: *EVALUATE+/ */ + } else if (ilogin == 6) { + if (nequal != 1) goto L7003; + if (nwrsen <= 2) goto L7004; +/* KEYWORDS: *ECHO+/+ELSEIF+/+IF+/+WHILE+/+UNTIL* */ + } else if (ilogin >= 7 && ilogin <= 11) { + if (nequal != 0) goto L7003; + if (nwrsen <= 0) goto L7004; +/* KEYWORDS: *REPEAT+/+ELSE* */ + } else if (ilogin == 13 || ilogin == 14) { + if (nequal != 0) goto L7003; + if (nwrsen != -1) goto L7004; +/* KEYWORDS: *ENDWHILE+/+ENDIF* */ + } else if (ilogin == 12 || ilogin == 15) { + if (nequal != 0) goto L7003; + if (nwrsen != 0) goto L7004; + } + } else { +/* USE OF <<.>> OR >>.<<, BUT STILL NO CLE-2000 INSTRUCTION */ + if (maxlvl == 0 && nrecio != 0) goto L7005; + } +/* RESET NUMBER OF EQUALS, WORDS, <<.>> >>.<<, $. */ + nequal = 0; + nwrsen = -2; + nrecio = 0; + l1lett = 1; + } + if (strncmp(myreco, cbla120, 120) != 0) goto L30; + goto L10; +L100: + memcpy(myreco, "QUIT .", 6); + fprintf(iwrite, "%-120sIMPLICIT\n",myreco); + memcpy(myreco, " .", 6); +L200: + if (nlevel != 1 || strcmp(chrend, csemic) != 0) goto L7007; + fprintf(iwrite, " \n"); + strncpy(rwrite, cbla120, 120); + jfndbg = index_f(myreco, "\""); + if (jfndbg != 0) { + jfndnd = index_f(&myreco[jfndbg], "\"") + jfndbg; + if (jfndnd == jfndbg) { + cemask[jfndbg-1] = '?'; + printf("%s\n", cemask); + printf("%s\n", terror[6]); + ++ret_val; + strncpy(cemask, cbla120, 120); + } else { + strncpy(rwrite, &myreco[jfndbg], jfndnd - jfndbg - 1); + strncpy(&myreco[jfndbg-1], cbla120, jfndnd - jfndbg + 1); + } + } + if (index_f(rwrite, "NODEBUG") == 0) { + if (index_f(rwrite, "DEBUG") != 0) idblst = 1; + } + if (index_f(rwrite, "NOXREF") == 0) { + if (index_f(rwrite, "XREF") != 0) ixrlst = 1; + } + if (index_f(rwrite, "NOLIST") == 0) { + if (index_f(rwrite, "LIST") != 0) ioulst = 1; + } + jfndnd = index_f(myreco, "."); + if (jfndnd == 0) { + printf("%s\n", terror[6]); + ++ret_val; + } else { + myreco[jfndnd-1] = ' '; + } + if (strncmp(myreco, cbla120, 120) != 0) { + printf("%s\n", terror[6]); + ++ret_val; + } + +/* REWRITE TOP OF OBJECT FILE TO KEEP THE NUMBER OF RECORDS */ +/* AND THE MAXIMUM LEVEL; TRANSMIT LAST STRING AS TITLE */ + nrecor = ninput; + rwrite[120] = '\0'; + strcpy(header.cdatin, rwrite); + header.nrecor = nrecor; + header.ninput = ninput; + header.maxlvl = maxlvl; + header.nstack = nstack; + header.ixrlst = ixrlst; + header.ioulst = ioulst; + header.idblst = idblst; + iretcd = kdiput_c(iunito, (int_32 *)&header, 0, kdisize(header)); + if (iretcd != 0) goto L9001; + +L666: + return ret_val; + +L5000: + printf("! %s: INPUT LINE OVERFLOW\n", nomsub); + strncpy(myreco, &recred[65], 120); myreco[120] = '\0'; + printf("! -->%s<--\n",myreco); + ret_val = 5000; + goto L666; +L5001: + printf("! %s: INVALID 1-CHARACTER WORD IN CLE-2000\n", nomsub); + ret_val = 5001; + goto L666; +L5012: + printf("! %s: MORE THAN 12-CHARACTER WORD IN CLE-2000\n", nomsub); + ret_val = 5012; + goto L666; +L7000: + printf("! %s: KEYWORD= *%s*, BUT MAXIMUM NUMBER OF LEVELS IS ACHIEVED\n", nomsub, clogbg[ilogin-1]); + printf("! %s: REVISE YOUR LOGIC\n", nomsub); + ret_val = 7000; + goto L666; +L7001: + printf("! %s: AFTER *%s*, NOT EXPECTING KEYWORD= *%s\n", + nomsub, clogbg[itylvl[nstlvl-1]-1], clogbg[ilogin-1]); + printf("! %s: REVISE YOUR LOGIC\n", nomsub); + ret_val = 7001; + goto L666; +L7002: + printf("! %s: KEYWORD= *%s*, BUT NOTHING LEFT FOR THIS LEVEL\n", nomsub, clogbg[ilogin-1]); + printf("! %s: REVISE YOUR LOGIC\n", nomsub); + ret_val = 7002; + goto L666; +L7003: + printf("! %s: KEYWORD= *%s*, BUT THE NUMBER OF EQUALS *:=* IS %d\n", + nomsub, clogbg[ilogin-1], (int)nequal); + ret_val = 7003; + goto L666; +L7004: + printf("! %s: KEYWORD= *%s*, BUT THE NUMBER OF WORDS IS %d\n", + nomsub, clogbg[ilogin-1], (int)nwrsen); + ret_val = 7003; + goto L666; +L7005: + printf("! %s: INVALID <<.>> OR >>.<< INSTRUCTION\n", nomsub); + ret_val = 7005; + goto L666; +L7006: + printf("! %s: DECLARATION AS *%s* MUST APPEAR AT LOGIC LEVEL 1\n", nomsub, clogbg[ilogin-1]); + ret_val = 7006; + goto L666; +L7007: + printf("! %s: INCONSISTENT END-OF-FILE, LOGIC LEVEL IS %d > 1\n", nomsub, (int)nlevel); + printf("! %s: EXPECTING *%s* AT THE END OF STATEMENT\n", nomsub, crecbg); + ret_val = 7007; + goto L666; +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; +} /* clelog */ -- cgit v1.2.3