TITLE 'SNOSTORM - A SNOBOL PREPROCESSOR' SUBTITLE 'INITIALIZATIONS' -NOFAIL -INCLUDE "HOST.inc" *** ENHANCEMENTS YET TO BE MADE *** * generate a warning with a label is the same as a SNOSTORM * keyword, it's probably an error. * Do better unstacking error processing. * Print label index at end of listing. *** VERSION = ' 1.01 ' -- installed June 27, 1982 * allows comments starting with '--' *** VERSION = ' 1.02 ' -- installed July 7, 1982 * fixes error when '-' operator precedes appended '--' *** VERSION = '83.01 ' -- installed April 20, 1983 * allows assignment in LOOP FOR... BY clause * This makes linked list traversal easy. *** VERSION = '83.02 ' -- installed July 19, 1983 * choked on some parenthesized logic exps with blanks, fixed. *** VERSION = ' 84.01 ' -- installed Jan 30, 1984 * takes the RETURN off the $CONTINUE WITH *SPITLIB VERSION = ' 93.01 ' -- First version for the Mac.` ******************************************************************** * * Adapting SNOSTORM to other systems. * * The SNOSTORM preprocessor, as it is used most often, consists * of a small assembly language root module which successively links * to the actual SNOSTORM preprocessor and then the SPITBOL compiler. * This results in an easy, one-step, usage. There is no * difficulty in doing this preprocessing in two stages if * such is the desire of the user. * * SNOSTORM is written in SNOSTORM itself. When it is distributed, * both the source written in SNOSTORM and the corresponding * SPITBOL source are distributed. * * If you find bugs or have any suggestions to make, I'd be * pleased to hear from you. Just send them to: * * Fred Swartz (swartz@merit.edu) * * (1) System Interfaces * * * (2) SPITBOL Dialect * * Additional, but probably minor, problems may arise from the * use of the SPITBOL dialect of SNOBOL in the implementation of * SNOSTORM. The additional SPITBOL features that are knowingly * made use of are: * BREAKX() * LPAD() * RPAD() * -NOFAIL * -COPY * * ******************************************************************** SUBTITLE 'INITIALIZATION' *** &FULLSCAN = 1 &ANCHOR = 1 &TRIM = 1 &STLIMIT = -1 *** MISC VALUES *** OUTLN = 1000 INTERNAL = 1000 INITIAL &CODE = 12 STMNO = 0 NUM = '0123456789' ALPHA = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ_.' QUOTES = '"' "'" B = SPAN(' ') *** STACK, THE ELEMENTS THAT GO ON IT, AND THE STACK POINTER *** STACK = ARRAY(50) STKPTR = 0 *** TELLS WHETHER LAST STATEMENT WAS A 'QUEUED' ONE (BY IF). FROMQUEUE = 'NO' *** SET UP A STACK FOR THE LISTING ON/OFF STATUS LISTSTK = ARRAY(10) LISTPTR = 0 ERRORS = ARRAY(50) INITTITLE = DUPL(' ',70) TITLETEXT = INITTITLE SUBTITLETEXT = NULL LPP = 59 PAGENO = 1 LINENO = 99999 VERYFIRST = 'YES' *** This accomodates to the first page eject *** BDUPL = ARRAY('0:132') B132 = DUPL(' ',132) BDUPL<0> = NULL I = 1 LOOP WHILE LE(I,132) BDUPL = SUBSTR(B132,1,I) I = I + 1 ENDLOOP B5 = DUPL(' ',5) B15 = DUPL(' ',15) B16 = DUPL(' ',16) B70 = DUPL(' ',70) B16STAR = B16 '*' STAR72 = DUPL('*',72) BOXTOP = '1' B16 STAR72 BOXLINE1 = ' ' B16 '*' B70 '*' BOXBOT = ' ' B16 STAR72 COLHEAD = ' STMNO FILELINE' B70 *** The CONTNT array contains a table of contents which is built up *** of titles and subtitles. It is printed at the end of the listing. *** The variable 'NXTCON' points to the first unused element in the *** CONTNT array. CONTNT = ARRAY(200) NXTCON = 1 *** The PROCINDEX array contains each procedure name and the fileline *** number at which it was defined. It is printed at the end of the *** listing. The variable NXTPNAME points to the first unused *** element in the PROCINDEX array. PROCINDEX = ARRAY('1:200,2') NXTPNAME = 1 SUBTITLE 'PATTERNS' SQSTRING = "'" FENCE BREAK("'") "'" DQSTRING = '"' FENCE BREAK('"') '"' STRING = SQSTRING | DQSTRING *** THESE TWO PATTERNS (ZLB AND ZLC) ARE USED TO FIND A *** ZERO LEVEL COMMA FOR THE IF STATEMENT. ZLB = BREAK('(<>)' QUOTES) FENCE + ( STRING FENCE *ZLB + | '(' *ZLB ')' FENCE *ZLB + | '<' *ZLB '>' FENCE *ZLB + | NULL) ZLC = BREAK(',(<>)' QUOTES) FENCE + ( STRING FENCE *ZLC + | '(' *ZLB ')' FENCE *ZLC + | '<' *ZLB '>' FENCE *ZLC + | NULL) *** PATTERN TO LOOK FOR UNQUOTED SEMICOLON (FOR ERROR CHECKING) UQSEMI = BREAK(';' QUOTES) (STRING FENCE *UQSEMI | NULL) *** pattern to find '--' comment indicator *** DASHDASH = BREAK('-' QUOTES) ( '--' + | STRING FENCE *DASHDASH + | '-' FENCE *DASHDASH + ) NUMBER = SPAN(NUM) STRNUM = (STRING | NUMBER) RP0 = RPOS(0) P0 = POS(0) B = SPAN(' ') OPTB = (B | '') OPTN = (NUMBER | NULL) . N QPBAL = ARBNO(NOTANY(QUOTES '<()>') + | STRING + | '(' *QPBAL ')' + | '<' *QPBAL '>') EXPPAT = QPBAL *** THE PATTERNS WHICH MATCH THE STATEMENTS *** LISTINGSTMT = 'LIST' | 'TITLE' | 'SPACE' | 'EJECT' | 'SUBTITLE' STMPAT = (BREAK(' ') . LL B ) . LABEL + (NOTANY('CDEILNPST') ABORT | FENCE) + ( 'END' OPTB FENCE + ( 'IF' | 'WHILE' | 'UNTIL' | 'DO' | 'LOOP' + | 'CASE' | 'PROC' ('EDURE' | NULL) | 'INITIAL') + | 'CASE' + | 'IFNOT' + | 'IF' + | 'ELSE' OPTB FENCE + ( 'IFNOT' + | 'IF' + | 'CASE' + | RPOS(0)) + | 'DO' OPTB FENCE + ( 'WHILE' (OPTB 'NOT' | '') + | 'UNTIL' (OPTB 'NOT' | '') + | 'CASE' + | RPOS(0)) + | 'LOOP' + | 'NEXT' FENCE ('LOOP' | 'DO') + | 'EXIT' FENCE OPTB ('LOOP' | 'DO' | 'PROC' ('EDURE' | NULL)) + | 'INITIAL' + | 'PROC' ('EDURE' | NULL) + | LISTINGSTMT + | 'DEBUGGER' RPOS(0) + ) + . TYPE FENCE (B | RPOS(0) | @PS BREAK('(') POS(*PS)) REM . REST ENDINITIAL SUBTITLE 'MORE INITIALIZATIONS' *** I/O DEFINITIONS *** filename = GETFILE("Snostorm source", "TEXT") INPUT(.INPUT, 1, filename) OUTPUT(.PUNCH,2,filename ".spt[-a]") OUTPUT(.SERCOM,3,'Messages') OUTPUT(.PRINTER,4,'Terminal') *** GET TIME OF DAY. TODAY = DATE() PAGEPFX = ' ' TODAY ' PAGE ' SUBTITLE 'PROCESS OPTIONS IN PAR FIELD' *** PERMISSIBLE OPTIONS: *** *** COM - WRITE THE COMMENTS INTO TARGET MODULE. *** NOCOM - DON'T WRITE COMMENTS INTO TARGET MODULE. *** LIST - PRODUCE SOURCE LISTING *** NOLIST - DON'T PRODUCE A SOURCE LISTING *** INDENT='S' - SET THE INDENT STRING TO 'S' *** NOINDENT - DO NOT INDENT THE SOURCE *** CONVERT - CONVERT FROM OLD TO NEW SNOSTORM FORMS *** DEBUG - PRODUCE *SPITDEBUG STUFF ???? *** FRED - STARTS WITH DEBUG() CALL IN SNOSTORM ITSELF *** AND CALLS DEBUG AFTER EVERY SOURCE ERROR. *** INITIAL PARNAME = SPAN(ALPHA) . PAR (ANY(',=') | RPOS(0)) ENDINITIAL COM = 'NO' LISTING = 'NO' DOINDENT = 'YES' INDENTAMT = '. ' DEBUG = 'DEFAULT' FRED = 'NO' PARFIELD = HOST(0) ALLPARS = PARFIELD IF DIFFER(PARFIELD,NULL) LOOP WHILE PARFIELD PARNAME = DO CASE (PAR) CASE ('COM') COM = 'YES' CASE ('NOCOM') COM = 'NO' CASE ('INDENT') IF NOT PARFIELD "'" BREAK("'") . INDENTAMT "'" (',' | RPOS(0)) = ERR('BAD INDENT SPECIFICATION: INDENT=' PARFIELD) EXITLOOP ENDIF DOINDENT = 'YES' CASE ('NOINDENT') DOINDENT = 'NO' CASE ('LIST') LISTING = 'YES' CASE ('NOLIST') LISTING = 'NO' CASE ('CONVERT') IF DIFFER(ALLPARS,'CONVERT') ERR('CONVERT OPTION MAY ONLY BE USED ALONE') *** THIS IS BECAUSE OF THE MAIN PROGRAM, Q.V. *** ELSE CONVERTOLD() ENDIF :(RCEND) CASE ('DEBUG') *** PRODUCE LABELS AND GOTOS FOR ALL STATEMENTS *** DEBUG = 'YES' CASE ('NODEBUG') *** DON'T PRODUCE -COPY *SPITDEBUG *** ???? DEBUG = 'NO' CASE ('FRED') FRED = 'YES' DEBUG('YES MASTER?') ELSECASE ERR('UNRECOGNIZED PAR OPTION:' PAR) EXITLOOP ENDCASE ENDLOOP ENDIF COMPUTE_INDENT(INDENTAMT) *** put out beginning of goto chain for case and proc PUTSTMT(' :(SNOINIT1);SNOBEGIN') STMNO = STMNO + 1 NEXTINIT = 1 SNOSTORMINFO = ' COMPILED BY SNOSTORM VERSION' VERSION 'ON ' TODAY IF DIFFER(PARFIELD,NULL) SNOSTORMINFO = HEADER ', PAR=' PARFIELD ENDIF *** THESE LINES ARE COUNTED BECAUSE OF 'VERYFIRST' SWITCH IF IDENT(LISTING,'YES') PRINTER = SNOSTORMINFO PRINTER = ' ' ENDIF PUTSTMT(' SNOSTORM_INFO = "' SNOSTORMINFO '"') SUBTITLE 'THE MAIN LOOP' INITIAL *** SET UP SOME STATEMENT SCANNING PATTERNS *** OLDPAT = '-' ('SPACE' | 'EJECT' | 'TITLE' | 'STITL') + . WHERETO REM . REST COM1PAT = '-' NOTANY('-') COM2PAT = B ('*' | '--' | RPOS(0)) LASTPAT = 'END' (B | RPOS(0)) ENDINITIAL NEXT LOOP WHILE STM = GETSTMT() LISTLEVEL = STKPTR *** CHECK FOR COMMENT TYPE LINE *** STM OLDPAT :S($('OLD' WHERETO)) IF STM COM1PAT *** JUST PASS CONTROL LINES ON THROUGH *** LISTCOM(STM) PUTCOM(STM) :(NEXT) ELSEIF STM '*' *** SNOBOL COMMENT *** LISTCOM(STM) IF IDENT(COM,'YES') PUTCOM(STM) ENDIF :(NEXT) ELSEIF STM '--' *** SNOSTORM comment in column one *** LISTCOM(STM) IF IDENT(COM,'YES') PUTCOM('*' STM) ENDIF :(NEXT) ELSEIF STM COM2PAT *** SNOSTORM comment starting with * or -- past *** *** column one or an all blank statement. *** IF IDENT(COM,'YES') OUTSTM = STM OUTSTM LEN(1) = '*' PUTCOM(OUTSTM) ENDIF ELSEIF STM LASTPAT *** END OF THE PROGRAM *** :(ENDPGM) ELSEIF STM UQSEMI ERR('Multiple statements per line not allowed by SNOSTORM') ELSEIF STM STMPAT *** THIS IS A SNOSTORM STATEMENT *** IF IDENT(DEBUG,'YES') AND DIFFER(FROMQUEUE,'YES') DEBUGOUT() ENDIF :($DELB(TYPE)) ELSE *** IT MUST BE A REGULAR SNOBOL STATEMENT *** *** COPY OUT THE ORIGINAL SOURCE, NOT THE *** *** CONCATENATED SOURCE. *** IF IDENT(DEBUG,'YES') AND DIFFER(FROMQUEUE,'YES') DEBUGOUT() ENDIF PUTSOURCE() ENDIF NEXTI LISTLINE() ENDLOOP SUBTITLE 'TERMINATION PROCESSING' *** FINISH PROCESSING HERE *** TERM LOOP WHILE DATATYPE(POP()) ARB . TYP 'ELEM' ERR('THE STRUCTURE ' TYP ' IS UNCLOSED.') ENDLOOP *** PRINT OUT TABLE OF CONTENTS *** IF IDENT(LISTING,'YES') AND GT(PAGENO,3) IF GT(NXTCON,2) *** Print out the table of contents *** *** but only if there are more than 3 entries and *** the listing is already at least 4 pages long. PRINTER = '1TABLE OF CONTENTS' PRINTER = '0LINE NUMBER TITLE/SUBTITLE' PRINTER = ' ' LOOP FOR I = 1 WHILE PRINTER = CONTNT ENDLOOP PRINTER = '-' ENDIF IF GT(NXTPNAME,2) *** Print the procedure index *** PRINTER = '-PROCEDURE INDEX' PRINTER = '0Line number - Procedure name' PRINTER = ' ' TABSORT(PROCINDEX,,NXTPNAME - 1) LOOP FOR I = 1 TO NXTPNAME - 1 PRINTER = ' ' PROCINDEX ' ' PROCINDEX ENDLOOP ENDIF ENDIF *** WARN ABOUT USE OF OLD FORMS *** IF DIFFER(OLDIES,NULL) OLDIES ',' = SERCOM = ' ' SERCOM = ' ********************************************' SERCOM = ' *' SERCOM = ' * This program contains some obsolete SNOSTORM' SERCOM = ' * constructions. The CONVERT option of SNOSTORM' SERCOM = ' * can be used to convert these old, obsolete' SERCOM = ' * statements to the new forms.' SERCOM = ' * The particular old forms are:' SERCOM = ' * ' OLDIES SERCOM = ' *' SERCOM = ' *********************************************' SERCOM = ' ' ENDIF RCEND IF EQ(&CODE,12) *** If &CODE is unchanged from initial value, all's OK *** &CODE = 0 ENDIF :(END) SUBTITLE 'LOOP STATEMENTS' * The SNOSTORM loop statement may optionally be followed by * one or more of the following clauses * nothing - meaning loop forever * FOR v = initial_value (BY increment|assignment) (TO final_value) * WHILE sexp * UNTIL sexp * *------------------------------------------------------------------ LOOP *** it is necessary to process the FOR clause first *** INITIAL DATA('LOOPELEM(BEGLABEL,ENDLABEL,NEXTLABEL)') *** *** ONE 'LOOPELEM' THING IS PUT ON THE STACK FOR EACH LOOP *** *** BEGLABEL: LABEL AT THE TOP OF THE LOOP *** ENDLABEL: LABEL AFTER THE END OF THE LOOP *** NEXTLABEL: LABEL ON FINAL LOOP CONDITIONS. IF THERE *** ARE NO SUCH CONDITIONS, THIS LABEL IS PUT *** ON THE BRANCH BACK TO 'BEGLABEL'. THIS *** FIELD IS NULL UNLESS THERE IS A 'NEXTLOOP' *** STATEMENT WITHIN THE LOOP. *** FORCLAUSE = (NULL | QPBAL) . F 'FOR' B QPBAL . FORARG (' UNTIL ' | ' WHILE ' | RP0) . BACK FORINITPAT = QPBAL . VAR OPTB '=' OPTB QPBAL . INIT (' BY ' | ' TO ' | RP0) . BACK FORBYPAT = QPBAL . F ' BY ' QPBAL . INCR (RP0 | ' TO ') . BACK FORBYPAT2 = QPBAL '=' FORTOPAT = OPTB 'TO' B QPBAL . FINAL RP0 WHILECLAUSE = OPTB 'WHILE' . WU B QPBAL . LEXP (' UNTIL ' | RP0) . BACK UNTILCLAUSE = OPTB 'UNTIL' . WU B QPBAL . LEXP (' WHILE ' | RP0) . BACK CONSTEST = OPTB ('-' | NULL) . SIGN NUMBER OPTB RPOS(0) WHILEORUNTIL = WHILECLAUSE | UNTILCLAUSE ENDINITIAL PUTLABEL(LABEL) LA = NULL LB = NULL IF IDENT(REST,NULL) *** INFINITE LOOP *** LA = GENLABEL() PUTLABEL(LA) ELSE IF REST FORCLAUSE = F BACK *** there is a for loop, generate the equivalent code *** INIT = NULL INCR = NULL FINAL = NULL IF FORARG FORINITPAT = BACK IF FORARG FORBYPAT = F BACK ENDIF IF FORARG FORTOPAT IF NOT FINAL CONSTEST *** MAKE COPY OF VALUE *** NEWVAR = GENVAR() PUTSTMT(' ' NEWVAR ' = ' FINAL) FINAL = NEWVAR ENDIF ENDIF IF INCR FORBYPAT2 *** The increment is defined as an assignment *** statement. In this case, the statement can *** be used without further processing. INCRSTMT = ' ' INCR ELSE *** The increment is an expression. COMP = ' GT(' IF IDENT(INCR,NULL) *** DEFAULT INCREMENT IS ONE *** INCR = 1 ELSEIF NOT INCR CONSTEST *** IF NOT A CONSTANT, COPY VALUE *** NEWVAR = GENVAR() PUTSTMT( ' ' NEWVAR ' = ' INCR) INCR = NEWVAR ELSE *** It must be a constant *** *** If it's negative, make sure to reverse final test IF IDENT(SIGN,'-'), COMP = ' LT(' ENDIF INCRSTMT = ' ' VAR ' = ' VAR ' + ' INCR ENDIF *** first generate the initialization *** LX = GENLABEL() IF DIFFER(VAR,TRIM(INIT)) *** assign initial value to loop variable. PUTSTMT(' ' VAR ' = ' INIT ' :(' LX ')') ELSE *** optimize the case where the loop variable *** and it's initial value are the same. *** I.e., no need to generate that assignment. PUTSTMT(' :(' LX ')') ENDIF *** now the label and increment *** LA = GENLABEL() PUTLABEL(LA) PUTSTMT(' ' INCRSTMT) *** and now the final test, if any *** PUTLABEL(LX) IF DIFFER(FINAL,NULL) *** there is a final value to test against *** LB = GENLABEL() PUTSTMT(COMP VAR ',' FINAL ') :S(' LB ')') ENDIF ELSE ERR('INCORRECTLY FORMED FOR CLAUSE ON LOOP') ENDIF ENDIF *** NOW GET THE NEXT WHILE OR UNTIL CLAUSE *** IF DIFFER(REST,NULL) IF IDENT(LA,NULL) *** THIS MUST BE THE FIRST LOOP CLAUSE *** LA = GENLABEL() PUTLABEL(LA) ENDIF IF IDENT(LB,NULL) *** THIS MUST BE THE FIRST TERMINATION CONDITI LB = GENLABEL() ENDIF LOOP WHILE REST WHILEORUNTIL = BACK DO CASE (WU) CASE ('WHILE') LOGIC(LEXP,LB,'F') CASE ('UNTIL') LOGIC(LEXP,LB,'S') ELSECASE *** HERE ONLY IF SOMETHING IS WRONG *** ERR('SNOSTORM GOT SICK ON THAT LAST LOOP STATEMENT') ENDCASE ENDLOOP *** MAKE SURE EVERYTHING WAS PROCESSED *** IF DIFFER(REST,NULL) ERR('UNRECOGNIZABLE LOOP OPTIONS:' REST) ENDIF ENDIF ENDIF PUSH(LOOPELEM(LA,LB,NULL)) :(NEXTI) SUBTITLE 'ENDLOOP STATEMENT' ENDLOOP ELEM = UNSTACK('ENDLOOP','LOOP') :F(NEXTI) LISTLEVEL = LISTLEVEL - 1 LA = BEGLABEL(ELEM) LB = ENDLABEL(ELEM) LC = NEXTLABEL(ELEM) IF DIFFER(LC,NULL) *** THIS LABEL COULD ONLY HAVE BEEN GENERATED BY *** A NEXTLOOP STATEMENT. ALL WE HAVE TO DO IS *** PUT THE LABEL OUT IN THE GENERATED TEXT. PUTLABEL(LC) ENDIF IF REST 'REPEAT' SPAN(' ') = *** THERE ARE SOME CLAUSES TO BE DEALT WITH *** LOOP WHILE REST WHILEORUNTIL = BACK DO CASE (WU) CASE ('WHILE') *** THERE ARE TWO POSSIBILITIES HERE. *** (1) IF THERE IS A WHILE CLAUSE EITHER WITHOUT *** AN UNTIL CLAUSE, OR IF THE UNTIL CLAUSE *** HAS ALREADY BEEN GENERATED, CODE WILL BE *** GENERATED TO FALL THROUHGH ON FAILURE *** AND BRANCH BACK TO LA ON SUCCESS. *** (2) IF THE UNTIL CLAUSE HAS YET TO BE GENERATED *** THE THE BRANCH OUT WILL BE ON FAILURE AND *** THE FALL THROUGH WILL BE ON SUCCESS. *** IF IDENT(REST,NULL) *** NO MORE CLAUSES, BRANCH ON SUCCESS *** LOGIC(LEXP,LA,'S') ELSE *** ANOTHER CLAUSE COMING, BRANCH ON FAILURE *** IF IDENT(LB,NULL) *** THE FIRST TERMINATION CONDITION *** LB = GENLABEL() ENDIF LOGIC(LEXP,LB,'F') ENDIF CASE ('UNTIL') *** IF THIS IS THE ONLY OR LAST TEST, BRANCH ON *** FAILURE TO THE FRONT AND FALL THROUGH ON SUCCES *** IF THERE ARE MORE TESTS, BRANCH TO THE END *** ON SUCCESS AND FALL THROUGH ON FAILURE. IF IDENT(REST,NULL) *** NO MORE CLAUSES, BRANCH ON FAILURE *** LOGIC(LEXP,LA,'F') ELSE *** ANOTHER CLAUSE COMING, BRANCH ON SUCCESS *** IF IDENT(LB,NULL) *** THE FIRST TERMINATION CONDITION *** LB = GENLABEL() ENDIF LOGIC(LEXP,LB,'S') ENDIF ELSECASE *** HERE ONLY IF SOMETHING IS WRONG *** ERR('SNOSTORM IS SICK OF LOOP STATEMENTS') ENDCASE ENDLOOP ELSE *** THERE ARE NO TERMINATION CONDITIONS *** PUTSTMT( ' :(' LA ')') ENDIF IF DIFFER(REST,NULL) ERR('UNRECOGNIZED ENDLOOP OPTIONS') ENDIF *** PUT OUT THE TERMINATION LABEL *** IF DIFFER(LB,NULL) PUTLABEL(LB) ENDIF :(NEXTI) SUBTITLE 'EXITLOOP AND NEXTLOOP STATEMENTS' EXITLOOP IF NOT ELEM = FINDLOOP() *** THERE SHOULD HAVE BEEN AN ENCLOSING LOOP *** ERR('EXITLOOP WITH NO ENCLOSING LOOP') ENDIF IF IDENT(ENDLABEL(ELEM),NULL) ENDLABEL(ELEM) = GENLABEL() ENDIF PUTSTMT(' :(' ENDLABEL(ELEM) ')') :(NEXTI) NEXTLOOP *** SO THAT POSSIBLE CONDITIONS AT THE END OF THE LOOP *** MAY BE TESTED, IT IS NECESSARY TO REFER TO A LABEL *** WHICH WILL BE DEFINED AT THE BEGINNING OF THE CODE *** GENERATED AT LOOP TERMINATION. IF NOT ELEM = FINDLOOP() ERR('NEXTLOOP WITHOUT ENCLOSING LOOP') ENDIF IF IDENT(NEXTLABEL(ELEM),NULL) NEXTLABEL(ELEM) = GENLABEL() ENDIF PUTSTMT(' :(' NEXTLABEL(ELEM) ')') :(NEXTI) SUBTITLE 'DO LOOPS' *** DO *** INITIAL DATA('DOELEM(BEGLABEL,ENDLABEL)') DATA('DOWHILEELEM(BEGLABEL,ENDLABEL)') DATA('DOUNTILELEM(BEGLABEL,ENDLABEL,NEXTLABEL,EPILOG)') *** BEGLABEL = LABEL AT TOP OF LOOP *** ENDLABEL = LABEL AFTER END OF LOOP *** NEXTLABEL = LABEL AT BEGINNING OF UNTIL EPILOGUE, *** GENERATED ONLY FOR A NEXTDO. ENDINITIAL DO OLD('DO') L = GENLABEL() PUSH(DOELEM(L)) PUTLABEL(L) :(NEXTI) *** ENDDO *** ENDDO ELEM = UNSTACK('ENDDO','DO') :F(NEXTI) LISTLEVEL = LISTLEVEL - 1 PUTSTMT(LABEL ' :(' BEGLABEL(ELEM) ')') DOSUFFIX IF DIFFER(ENDLABEL(ELEM),'') PUTLABEL(ENDLABEL(ELEM)) ENDIF :(NEXTI) *** DO WHILE / DO WHILE NOT *** DOWHILE OLD('DOWHILE') SF = ' :F(' :(DW) DOWHILENOT OLD('DOWHILENOT') SF = ' :S(' DW LA = GENLABEL() LB = GENLABEL() PUTLABEL(LA) PUTSTMT(LABEL REST SF LB ')') PUSH(DOWHILEELEM(LA,LB)) :(NEXTI) *** END WHILE *** ENDWHILE IF ELEM = UNSTACK('ENDWHILE','DOWHILE') LISTLEVEL = LISTLEVEL - 1 PUTSTMT(' :(' BEGLABEL(ELEM) ');' ENDLABEL(ELEM)) STMNO = STMNO + 1 ENDIF :(NEXTI) *** DO UNTIL / DO UNTIL NOT *** DOUNTIL OLD('DOUNTIL') SF = ' :F(' :(DU) DOUNTILNOT OLD('DOUNTILNOT') SF = ' :S(' DU LA = GENLABEL() PUTLABEL(LA) PUSH(DOUNTILELEM(LA,,,' ' REST SF LA ')')) :(NEXTI) *** END UNTIL *** ENDUNTIL ELEM = UNSTACK('ENDUNTIL','DOUNTIL') :F(NEXTI) LISTLEVEL = LISTLEVEL - 1 IF DIFFER(NEXTLABEL(ELEM),NULL) *** THERE MUST HAVE BEEN A NEXTDO *** PUTLABEL(NEXTLABEL(ELEM)) ENDIF PUTSTMT(EPILOG(ELEM)) :(DOSUFFIX) SUBTITLE 'NEXTDO / EXITDO' *** NEXTDO *** NEXTDO OLD('NEXTDO') IF ELEM = FINDLOOP() IF IDENT(DATATYPE(ELEM),'DOUNTIL') IF IDENT(NEXTLABEL(ELEM,NULL)) NEXTLABEL(ELEM) = GENLABEL() ENDIF L = NEXTLABEL(ELEM) ELSE L = BEGLABEL(ELEM) ENDIF PUTSTMT(LABEL REST ' :S(' L ')') ELSE *** COULDN'T FIND AN ENCLOSING LOOP *** ERR('NEXTDO WITHOUT ENCLOSING DO LOOP') ENDIF :(NEXTI) *** EXITDO *** EXITDO OLD('EXITDO') IF ELEM = FINDLOOP() IF IDENT(ENDLABEL(ELEM),NULL) ENDLABEL(ELEM) = GENLABEL() ENDIF PUTSTMT(LABEL REST ' :S(' ENDLABEL(ELEM) ')') ELSE ERR('EXITDO WITHOUT ENCLOSING DO LOOP') ENDIF :(NEXTI) SUBTITLE 'IF / ELSEIF / ELSE / ENDIF' *** IF / IFNOT *** INITIAL DATA('IFELEM(FLABEL,ENDLABEL,LASTCLAUSE)') *** *** ONE 'IFELEM' IS STACKED FOR EACH IF *** *** FLABEL - WHERE TO GO IF S FAILS (ELSEIF,ELSE,ENDIF) *** ENDLABEL - THIS IS THE LABEL AFTER THE ENDIF. IT *** IS USED ONLY AT THE END OF ELSEIF CLAUSES. *** LASTCLAUSE - 'IF', 'ELSEIF', OF 'ELSE' AS WAS THE *** THE LAST CLAUSE PROCESSED. *** ENDINITIAL IF PUTLABEL(LABEL) L = GENLABEL() *** DECIDE WHETHER IT IS A SIMPLE OR A BLOCK IF *** IF REST ZLC . LEXP ',' = *** THIS IS A SIMPLE IF *** IF DIFFER(REST,NULL) *** MAKE DON HAPPY BY CHECKING FOR NULL STMT LOGIC(LEXP,L,'F') QUEUEIT(L) QUEUEIT(' ' REST) ELSE ERR('MISSING IF STATEMENT OBJECT') ENDIF ELSE *** A BLOCK IF *** LOGIC(REST,L,'F') PUSH(IFELEM(L,,'IF')) ENDIF :(NEXTI) *** PROCESS AN ELSE *** ELSE ELEM = UNSTACK('ELSE','IF') :F(NEXTI) LISTLEVEL = LISTLEVEL - 1 IF IDENT(LASTCLAUSE(ELEM),'IF') *** PRECEDED BY AN IF *** L = GENLABEL() PUTSTMT(LABEL ' :(' L ');' FLABEL(ELEM)) STMNO = STMNO + 1 PUSH(IFELEM(L,,'ELSE')) ELSEIF IDENT(LASTCLAUSE(ELEM),'ELSEIF') *** PRECEDED BY AN ELSEIF *** PUTSTMT(LABEL ' :(' ENDLABEL(ELEM) ');' FLABEL(ELEM)) STMNO = STMNO + 1 PUSH(IFELEM(ENDLABEL(ELEM),,'ELSE')) ELSE ERR('TOO MANY ELSES IN IF STATEMENT') ENDIF :(NEXTI) *** ELSEIF *** ELSEIF IF ELEM = UNSTACK('ELSEIF','IF') LISTLEVEL = LISTLEVEL - 1 IF IDENT(ENDLABEL(ELEM),'') *** THIS MUST BE THE FIRST ELSEIF *** ENDLABEL(ELEM) = GENLABEL() ENDIF PUTSTMT(LABEL ' :(' ENDLABEL(ELEM) ');' FLABEL(ELEM)) STMNO = STMNO + 1 L = GENLABEL() LOGIC(REST,L,'F') PUSH(IFELEM(L,ENDLABEL(ELEM),'ELSEIF')) ENDIF :(NEXTI) *** ENDIF *** ENDIF IF ELEM = UNSTACK('ENDIF','IF') LISTLEVEL = LISTLEVEL - 1 IF IDENT(LASTCLAUSE(ELEM),'ELSEIF') PUTLABEL(ENDLABEL(ELEM)) ENDIF PUTLABEL(FLABEL(ELEM)) ENDIF :(NEXTI) *////////////////////// OLD CONSTRUCTIONS ////////////////////////// IFNOT OLD('IFNOT') REST = 'NOT ' REST :(IF) ELSEIFNOT OLD('ELSEIFNOT') REST = 'NOT ' REST :(ELSEIF) SUBTITLE 'INITIAL / ENDINITIAL' * THE INITIAL / ENDINITIAL STRUCTURE BRACKETS STATEMENTS WHICH * SHOULD ONLY BE PERFORMED ONCE FOR INITIALIZATION. INITIAL DATA('INITIALELEM(ENDLABEL)') ENDINITIAL INITIAL L = GENLABEL() PUTSTMT(' :(' L ')') PUTINITLABEL() PUSH(INITIALELEM(L)) :(NEXTI) ENDINITIAL IF ELEM = UNSTACK('ENDINITIAL','INITIAL') LISTLEVEL = LISTLEVEL - 1 PUTINITGOTO() PUTLABEL(ENDLABEL(ELEM)) ENDIF :(NEXTI) SUBTITLE 'DOCASE / CASE / ENDCASE' * THE CASE STRUCTURE IS OF THE FORM: * DO CASE * CASE ,... * . * . * . * CASE ,... * . * AND AS MANY MORE CASE CLAUSES AS WISHED. * . * ELSECASE * . * . * . * ENDCASE * THIS IS IMPLEMENTED BY BUILDING A TABLE WHERE EACH OF THE * CASE EXPRESSIONS IS INSERTED ALONG WITH THE CORRESPONDING * GENERATED LABEL FOR THE APPROPRIATE CASE CLAUSE. * THE TABLE IS GENERATED AT RUN TIME BY BRANCHING THROUGH * THE PROGRAM AT THE BEGINNING OF EXECUTION MAKING THE * NECESSARY TABLE ENTRY ASSIGNMENTS. INITIAL *** THE CASE STRUCTURE PUTS AN ENTRY ON THE STACK WITH THE *** FOLLOWING FORMAT: DATA('CASEELEM(ENDLABEL,ELSELABEL,CASETAB)') *** ENDLABEL = LABEL AFTER THE END OF THE CASE STRUCTURE *** ELSELABEL = LABEL OF THE ELSECASE CLAUSE. *** CASETAB = THE CASE TABLE ENDINITIAL DOCASE ELSECASELABEL = GENLABEL() CASETABLE = GENLABEL() *** PUT OUT STMT TO GET THE LABEL FOR THIS CASE *** PUTSTMT(' ZZZZZ = ' CASETABLE '<' REST '> :F(' ELSECASELABEL ')') *** PUT OUT STMT TO GO TO ELSECASE IF THERE IS NO LABEL *** PUTSTMT(' DIFFER(ZZZZZ,) :S($ZZZZZ)F(' ELSECASELABEL ')') *** PUT OUT THE INITIALIZATION OF THIS CASE TABLE *** PUTINITLABEL() PUTSTMT(' ' CASETABLE ' = TABLE(11)') IDENT(LABEL,NULL) :S(DOCASE1) PUTLABEL(LABEL) DOCASE1 PUTINITGOTO() *** STACK THE CASE STRUCTURE *** PUSH(CASEELEM(GENLABEL(),ELSECASELABEL,CASETABLE)) :(NEXTI) INITIAL CASE_PSTRIP = OPTB '(' BREAKX(')') . REST ')' RPOS(0) CASE_VALUE = STRNUM . L OPTB ',' OPTB ENDINITIAL CASE *** CHECK TO MAKE SURE WE ARE IN A PROPER CASE *** ELEM = UNSTACK('CASE','CASE') :F(NEXTI) LISTLEVEL = LISTLEVEL - 1 *** PUT OUT A GOTO TO THE END FOR THE END OF THE PREVIOUS CASE PUTSTMT(' :(' ENDLABEL(ELEM) ')') *** PUT THE CASE ELEMENT BACK ON THE STACK *** PUSH(ELEM) *** STRIP OFF THE PARENS IF ANY *** *** THIS IS FOR COMPATIBILITY WITH AN OLDER VERSION *** WHICH REQUIRED THE PARENS IF REST CASE_PSTRIP ENDIF *** AFTER THE GOTO TO THE END OF THE PREVIOUS CASE AND *** BEFORE THE LABEL FOR THIS CASE IS WHERE THE INITIALIZATION *** FOR THE CASE TABLE IS TO GO. HERE = GENLABEL() PUTINITLABEL() LS = REST ',' LOOP WHILE LS CASE_VALUE = PUTSTMT(' ' CASETAB(ELEM) '<' L '> = "' HERE '"') ENDLOOP PUTINITGOTO() *** TEST TO SEE IF EVERYTHING WAS PROCESSED *** DIFFER(LS,NULL) :S(ERRCASE) *** PUT OUT THE LABEL FOR THIS CASE *** PUTLABEL(HERE) :(NEXTI) ERRCASE ERR('BAD SYNTAX IN CASE LIST:' LS) :(NEXTI) EJECT 20 ELSECASE *** MAKE SURE WE ARE IN A CASE STRUCTURE *** IF ELEM = UNSTACK('ELSECASE','CASE') LISTLEVEL = LISTLEVEL - 1 *** PUT OUT THE GOTO TO END THE PRECEDING CASE CLAUSE *** PUTSTMT(' :(' ENDLABEL(ELEM) ')') *** PUT OUT THE ELSECASE LABEL AND CLEAR IT *** IF IDENT(ELSELABEL(ELEM),NULL) ERR('ONLY ONE ELSECASE IS ALLOWED') :(ELC1) ENDIF PUTLABEL(ELSELABEL(ELEM)) ELSELABEL(ELEM) = NULL *** RESTACK THE CASE STRUCTURE *** PUSH(ELEM) ENDIF :(NEXTI) ENDCASE *** MAKE SURE WE ARE IN A CASE STRUCTURE *** IF ELEM = UNSTACK('ENDCASE','CASE') LISTLEVEL = LISTLEVEL - 1 *** IF THERE WAS NO ELSECASE, GENERATE ERROR *** IF DIFFER(ELSELABEL(ELEM),NULL) *** FIRST, PUT OUT THE GOTO TO END THE PRECEDING CASE CLAUSE *** PUTSTMT(' :(' ENDLABEL(ELEM) ')') PUTLABEL(ELSELABEL(ELEM)) ERR('MISSING ELSECASE') ENDIF *** PUT OUT A LABEL AFTER THE END OF THE CASE STRUCTURE *** PUTLABEL(ENDLABEL(ELEM)) ENDIF :(NEXTI) SUBTITLE 'PROC / ENDPROC' INITIAL DATA('PROCELEM(ENDLABEL,PROCPROTO)') *** ENDLABEL = LABEL AFTER THE PROC DEFINITION *** *** PROCPROTO = PROCEDURE DEFINITION TEXT (WITHOUT *** " DEFINE('" AT BEGINNING OR "')" AT *** END. THIS HAS TO BE SAVED UNTIL THE END *** OF THE PROCEDURE BECAUSE ANY LOCAL *** VARIABLES THAT MIGHT BE GENERATED, *** E.G., BY LOOP FOR, MUST BE ADDED TO *** THE LIST OF LOCAL VARIABLES. ENDINITIAL PROCEDURE PROC LOOP WHILE GT(STKPTR,0) DATATYPE(STACK) ARB . TEMP 'ELEM' ERR('UNCLOSED ' TEMP ' STRUCTURE BEFORE PROCEDURE ' LL) STKPTR = STKPTR - 1 ENDLOOP *** PUT OUT A GOTO AROUND BOTH THE 'DEFINE' FOR THE *** PROCEDURE AND THE BODY OF THE PROCEDURE LABE = GENLABEL() PUTSTMT(' :(' LABE ')') *** PUT OUT THE 'DEFINE' FOR THE INITIALIZATION *** LOOP WHILE REST BREAK(' ') . F ' ' = F *** GET RID OF ALL BLANKS IN PROTOTYPE *** ENDLOOP IF IDENT(REST,NULL) REST = '()' ENDIF INDEXPROC(LL) PUTCOM('*** ' LL ' PROCEDURE ' REST) *** PUT OUT THE PROCEDURE LABEL *** PUTSTMT(LL) *** PUT THE PROCEDURE STRUCTURE ON THE STACK *** PUSH(PROCELEM(LABE,LL REST)) *** MAKE SURE THIS PROCEDURE HAS SOME BLANK SPACE IN FRONT *** OF IT ON THE LISTING. IF GT(LINENO,LPP - 8) *** NOT ENOUGH ROOM ON THIS PAGE, EJECT *** LINENO = 123456 ENDIF :(NEXTI) SPACE 5 INITIAL RETTYPE = ('FAILURE' | 'FAIL' | 'NAME' | 'SUCCEED' | 'SUCCESS' | NULL) . RT RPOS(0) RETMTAB = TABLE() RETMTAB<'FAIL'> = 'F' RETMTAB<'FAILURE'> = 'F' RETMTAB<'NAME'> = 'N' RETMTAB<'SUCCEED'> = '' RETMTAB<'SUCCESS'> = '' ENDINITIAL ENDPROCEDURE ENDPROC IF NOT REST RETTYPE ERR('ENDPROC RETURN TYPE ILLEGAL:' REST) ENDIF IF ELEM = UNSTACK('ENDPROC','PROC') LISTLEVEL = LISTLEVEL - 1 PUTSTMT(' :(' RETMTAB 'RETURN)') PUTINITLABEL() PUTSTMT(" DEFINE('" PROCPROTO(ELEM) "')") PUTINITGOTO() PUTSTMT(ENDLABEL(ELEM)) ENDIF :(NEXTI) EXITPROCEDURE EXITPROC IF NOT REST RETTYPE ERR('EXITPROC RETURN TYPE ILLEGAL:' REST) ENDIF PUTSTMT(' :(' RETMTAB 'RETURN)') :(NEXTI) SUBTITLE 'END STATEMENT' INITIAL END_PAT = 'END' B REM . FIRSTLABEL ENDINITIAL ENDPGM IF NOT STM END_PAT *** ASSUME WE BEGIN AT SNOBEGIN *** FIRSTLABEL = 'SNOBEGIN' ENDIF PUTSTMT(' :(END)') PUTINITLABEL() IF DIFFER(DEBUG,'NO') ** PUT IN IF EITHER 'YES' OR 'DEFAULT' *** *????* PUTSTMT('-COPY *SPITDEBUG') ENDIF IF IDENT(DEBUG,'YES') PUTSTMT(' DEBUG()') ENDIF PUTSTMT(' :(' FIRSTLABEL ')') PUTSTMT('END') :(NEXTI) SUBTITLE 'OLD LISTING CONTROL FUNCTIONS' INITIAL OLDSPACE_PAT = OPTB NUMBER . N ENDINITIAL OLDSPACE IF NOT REST OLDSPACE_PAT N = 1 ENDIF GT(LINENO + N,LPP) :S(OLDEJECT) LOOP WHILE GT(N,0) LISTERINE(' ') N = N - 1 ENDLOOP :(NEXT) OLDEJECT LINENO = 0 :(NEXT) OLDTITLE :(TITLE1) OLDSTITL :(SUBTITLE1) SUBTITLE 'NEW LISTING CONTROL FUNCTIONS' INITIAL SPACE_PAT = OPTN . N1 OPTB (',' | NULL) OPTB OPTN . N2 RPOS(0) ENDINITIAL SPACE IF LE(LINENO,LPP) IF NE(FIRSTL,LINENO) IF NOT REST SPACE_PAT ERR('UNINTELLIGIBLE PARAMETER ON SPACE STATEMENT') N1 = 1 N2 = NULL ENDIF DIFFER(N2,NULL) :S(EJECT1) *** WE DON'T DO THE SPACING IF ALREADY AT THE TOP OF *** A PAGE. IF IDENT(N1,NULL) N1 = 1 ENDIF IF GT(LINENO + N1,LPP) LINENO = 123456 ELSE LOOP WHILE GT(N1,0) LISTERINE(' ') N1 = N1 - 1 ENDLOOP ENDIF ENDIF ENDIF :(NEXT) ******************************** INITIAL EJECT_PAT = OPTB NUMBER . N1 OPTB (',' | NULL) OPTB OPTN . N2 RPOS(0) ENDINITIAL EJECT IF LT(LINENO,LPP) *** DON'T DO THE EJECT IF WE ARE AT THE TOP OF *** A PAGE ALREADY. IF REST EJECT_PAT *** THERE IS A NUMBER ON THE EJECT *** EJECT1 IF GT(N1,LPP - LINENO) *** EJECT IF THERE'S NOT ENOUGH ROOM ON PAGE *** LINENO = 123456 ELSE *** space if so requested *** IF GT(LINENO + N2,LPP) LINENO = 123456 ELSE LOOP WHILE GT(N2,0) LISTERINE(' ') N2 = N2 - 1 ENDLOOP ENDIF ENDIF ELSE *** ALWAYS EJECT IF NO OPERAND ON EJECT *** LINENO = 123456 ENDIF ENDIF :(NEXT) * THE LIST COMMAND MAY BE FOLLOWED BY ONE OF THE FOLLOWING KEYWORDS: * LIST (ON | OFF | PUSHON | PUSHOFF | POP) LIST DOCASE (REST) CASE ('ON','') LISTING = 'YES' CASE ('OFF') LISTING = 'NO' CASE ('PUSHON') IF GT(LISTPTR,9) ERR('TOO MANY LIST PUSHONS') ELSE LISTPTR = LISTPTR + 1 LISTSTK = LISTING ENDIF LISTING = 'YES' CASE ('PUSHOFF') IF GT(LISTPTR,9) ERR('TOO MANY LIST PUSHOFFS') ELSE LISTPTR = LISTPTR + 1 LISTSTK = LISTING ENDIF LISTING = 'NO' CASE ('POP') IF LE(LISTPTR,0) ERR('TOO MANY LISTING POPS') LISTING = 'YES' ELSE LISTING = LISTSTK LISTPTR = LISTPTR - 1 ENDIF ELSECASE ERR('UNKNOWN LIST OPTION:' REST) ENDCASE :(NEXT) TITLE IF NOT REST "'" BREAK("'") . REST RPOS(1) ERR("TITLE TEXT WITHOUT QUOTES") ENDIF TITLE1 TITLETEXT = CENTER(REST,70) SUBTITLETEXT = '' IF IDENT(COPYCOM,'YES') PUTSTMT('*TITLE ' REST) ENDIF LINENO = 123456 NEWHEADER = 'YES' IF DIFFER(REST,NULL) *** PUT TITLE IN TABLE OF CONTENTS *** TABCON(REST) ENDIF :(NEXT) SPACE 3 SUBTITLE IF NOT REST "'" BREAK("'") . REST RPOS(1) ERR("SUBTITLE TEXT WITHOUT QUOTES") ENDIF SUBTITLE1 SUBTITLETEXT = CENTER(REST,70) IF IDENT(COPYCOM,'YES') PUTSTMT('*SUBTITLE ' REST) ENDIF LINENO = 123456 NEWHEADER = 'YES' IF DIFFER(REST,NULL) *** PUT SUBTITLE IN TABLE OF CONTENTS *** TABCON(REST) ENDIF :(NEXT) DEBUGGER IF IDENT(FRED,'YES') DEBUG('YES MASTER') ENDIF :(NEXT) SUBTITLE 'OLD TO NEW SNOSTORM CONVERTER' INITIAL CONVTAB = TABLE() CONVTAB<'-SPACE' > = ' SPACE' CONVTAB<'IFNOT' > = 'IF NOT' CONVTAB<'ELSEIFNOT' > = 'ELSEIF NOT' CONVTAB<'DOWHILE' > = 'LOOP WHILE' CONVTAB<'DOWHILENOT'> = 'LOOP WHILE NOT' CONVTAB<'ENDWHILE' > = 'ENDLOOP' LABELFIELD = (BREAK(' ') SPAN(' ')) . LABEL CONV1PAT = '-SPACE' . TYPE NULL . LABEL | + LABELFIELD + ( 'IFNOT' | 'ELSEIFNOT' + | 'DO' OPTB 'WHILE' ('NOT' | NULL) + | 'END' OPTB 'WHILE' + ) . TYPE (B | RPOS(0)) CONV2PAT = ('-' ('TITLE' | 'STITL')) . TYPE B REM . REST | + LABELFIELD + ( 'DO' OPTB 'UNTIL' ('NOT' | NULL) + | 'END' OPTB 'UNTIL' + | 'NEXT' OPTB 'DO' + | 'EXIT' OPTB 'DO' + ) . TYPE (B | RPOS(0)) REM . REST ENDINITIAL CONVERTOLD PROC () *** THIS PROCEDURE CONVERTS THE OLD SNOSTORM FORMS TO *** THE NEW SNOSTORM FORMS. LOOP WHILE STM = GETLINE(.LINE,.INTERNAL) IF STM CONV1PAT = LABEL CONVTAB ' ' *** THESE WERE THE EASY ONES *** ELSEIF STM CONV2PAT *** THESE ARE THE HARDER ONES *** DO CASE (DELB(TYPE)) CASE ('DOUNTIL') *** STACK UNTIL CONDITION *** PUSH(REST) STM = LABEL 'LOOP' CASE ('DOUNTILNOT') *** STACK UNTIL CONDITION *** PUSH('NOT ' REST) STM = LABEL 'LOOP' CASE ('ENDUNTIL') *** POP THE UNTIL CONDITION *** STM = LABEL 'ENDLOOP REPEAT UNTIL ' POP() CASE ('NEXTDO') *** MOVE EXPRESSION TO IF *** IF DIFFER(REST,NULL) STM = LABEL 'IF ' REST ', NEXTLOOP' ELSE STM = LABEL 'NEXTLOOP' ENDIF CASE ('EXITDO') *** MOVE EXPRESSION TO IF *** IF DIFFER(REST,NULL) STM = LABEL 'IF ' REST ', EXITLOOP' ELSE STM = LABEL 'EXITLOOP' ENDIF CASE ('-TITLE') *** Put quotes around text *** STM = " TITLE '" REST "'" CASE ('-STITL') *** Put quotes around text *** STM = " SUBTITLE '" REST "'" ELSECASE *** SOMETHING IS WRONG WITH CONVERT OPTION *** ERR('ERROR IN CONVERT OPTION:' STM) ENDCASE ENDIF PUTSTMT(STM) ENDLOOP :(RCEND) ENDPROC INITIAL DELB_PAT = BREAK(' ') . F B ENDINITIAL DELB PROC (DELB)F *** THIS PROCEDURE DELETES BLANKS FROM ITS PARAMETER *** LOOP WHILE DELB DELB_PAT = F ENDLOOP ENDPROC SUBTITLE 'MISC FUNCTIONS' GENLABEL PROC () *** GENERATE A LABEL *** LNUM = LNUM + 1 GENLABEL = 'ZZ' LPAD(LNUM,4,'0') ENDPROC GENVAR PROC ()E,PT *** GENERATE A VARIABLE NAME. THIS USES GENLABEL TO *** ACTUALLY GENERATE THE NAME. IN ADDITION, IT IS *** NECESSARY TO ADD THIS VARIABLE TO THE LIST OF *** LOCAL VARIABLES FOR AN ENCLOSING PROCEDURE. GENVAR = GENLABEL() IF E = POPTOP() IF IDENT(DATATYPE(E),'PROCELEM') *** WE ARE IN A PROCEDURE, ADD THIS VARIABLE *** TO THE LIST OF LOCAL VARIABLES. PT = PROCPROTO(E) IF PT RTAB(1) ')' PROCPROTO(E) = PT GENVAR ELSE PROCPROTO(E) = PT ',' GENVAR ENDIF ENDIF ENDIF ENDPROC SUBTITLE 'STACK PROCEDURES' PUSH PROC (ARG) *** PUSH ONE ELEMENT ONTO THE STRUCTURE STACK *** STKPTR = STKPTR + 1 STACK = ARG :(RETURN) ENDPROC POP PROC () *** POP ONE ELEMENT FROM THE STRUCTURE STACK *** POP = STACK :F(FRETURN) STKPTR = STKPTR - 1 ENDPROC POPTOP PROC () *** RETURN THE TOP ELEMENT FROM THE STACK *** LE(STKPTR,0) :S(FRETURN) POPTOP = STACK<1> ENDPROC POPC PROC (MUSTBE) *** THE POPC PROCEDURE POPS THE TOP ELEMENT OFF THE STACK *** AND IN ADDITION CHECKS TO MAKE SURE THAT THE TY *** FIELD IS THE SAME AS THE PARAMETER 'MUSTBE'. IF NOT, *** POPC ATTEMPTS TO GENERATE THE MOST APPROPRIATE ERROR *** COMMENT AND LEAVE THE STACK POSITIONED CORRECTLY BY *** EXAMINING THE STACK ELEMENTS ADJACENT TO THE TOP. *** THE SITUATIONS ARE DESCRIBED BELOW WHERE AN 'X' *** STANDS FOR AN INCORRECT ELEMENT AND 'C' STANDS FOR A *** CORRECT ELEMENT. *** *** XXX - POP STACK AND GIVE ERROR *** XXC - DON'T POP STACK - EXTRA C *** CXX - POP STACK TWICE - MISSING X BEGINNING *** CXC - DON'T POP STACK - EITHER MISSING BEG X OR ? IF POPC = STACK *** THERE WAS SOMETHING THERE *** IF IDENT(DATATYPE(POPC),MUSTBE) *** EVERYTHING IS OK *** STKPTR = STKPTR - 1 :(RETURN) ELSE *** NOT VERY GOOD *** IF IDENT(DATATYPE(STACK),MUSTBE) *** PROBABLY AN EXTRA ENDER *** ERR("TOO MANY " MUSTBE "'S") ELSE *** LET'S SEE WHAT CAME BEFORE *** IF GT(STKPTR,1) IF IDENT(DATATYPE(STACK),MUSTBE) *** PROBABLY MISSING END FOR TOP *** ERR('MISSING END FOR ' STACK) STKPTR = STKPTR - 2 ELSE ERR('MISSING BEGINNING FOR ' MUSTBE) ENDIF ELSE ERR('MISSING BEGINNING FOR ' MUSTBE) ENDIF :(FRETURN) ENDIF ENDIF ELSE ERR('MISSING ' MUSTBE) :(FRETURN) ENDIF ENDPROC UNSTACK PROC (AT,WANT)TAI *** THE UNSTACK FUNCTION *** *** *** THIS FUNCTION TAKES TWO PARAMETERS: *** 1. AT - THE TYPE OF STATEMENT THAT IS BEING PROCESSED *** USED ONLY FOR ERROR COMMENTS. *** 2. WANT - THE TYPE OF ELEMENT THAT IS WANTED *** AT THE TOP OF THE STACK. *** *** UNSTACK RETURNS THE TOP ELEMENT OF THE STACK *** AND FAILS IF THERE IS NO CORRECT ONE TO BE FOUND. IF UNSTACK = POP() DATATYPE(UNSTACK) ARB . TAI 'ELEM' IDENT(TAI,WANT) :S(RETURN) ENDIF ERR( AT ' SHOULD BE PRECEDED BY ' WANT) IDENT(UNSTACK,'') :S(FRETURN) ERR(' THIS OCCURRED WITHIN THE SCOPE OF A/AN ' TAI) :(FRETURN) ENDPROC INITIAL *** A FINDLOOP PATTERN *** FLPAT = ('LOOP' | 'DO' ('UNTIL' | 'WHILE' | NULL)) 'ELEM' ENDINITIAL FINDLOOP PROC ()TLEV *** FIND THE NEXT OUTER LOOP *** *** USED BY EXITLOOP AND NEXTLOOP *** *** DOES NOT CHANGE THE STACK *** TLEV = STKPTR + 1 NFL TLEV = TLEV - 1 LE(TLEV,0) :S(FRETURN) DATATYPE(STACK) FLPAT :F(NFL) FINDLOOP = STACK ENDPROC SUBTITLE 'MISC PROCEDURES' PUTINITLABEL PROC () *** PUT OUT NEXT LABEL IN INITIALIZATION CHAIN *** PUTSTMT('SNOINIT' NEXTINIT) NEXTINIT = NEXTINIT + 1 ENDPROC PUTINITGOTO PROC () *** PUT OUT NEXT GOTO IN INITIALIZATION CHAIN *** PUTSTMT(' :(SNOINIT' NEXTINIT ')') ENDPROC PUTSTMT PROC (STATE) *** WRITE OUT A TARGET STATEMENT *** WRITELINE(STATE) STMNO = STMNO + 1 ENDPROC PUTCOM PROC (COM) *** WRITE A COMMENT TO THE TARGET MODULE *** WRITELINE(COM) ENDPROC PUTLABEL PROC (LABE) *** WRITE A LABEL TO THE TARGET MODULE *** IF DIFFER(LABE,NULL) WRITELINE(LABE) STMNO = STMNO + 1 ENDIF ENDPROC WRITELINE PROC (LINE) *** THIS PROCEDURE WRITES A LINE PUNCH = LINE ENDPROC COMPUTE_INDENT PROC (IND)INDL,I *** COMPUTES THE INDENTATION TO BE USED IN THE *** LISTING. THIS IS CALLED TO INITIALIZE THE *** GLOBAL INDENT ARRAY AND CALLED AGAIN IF THE *** INDENTATION STRING IS EVER CHANGED. INDENT = ARRAY('0:20') INDENT<0> = ' ' INDENT<20> = ' ' DUPL(IND,20) INDL = SIZE(IND) I = 1 LOOP WHILE LE(I,19) *** CALCULATE THE INDENTATION VALUES *** INDENT = SUBSTR(INDENT<20>,1,I * INDL + 6) I = I + 1 ENDLOOP ENDPROC ERR PROC (ERRCOM) &CODE = 8 ERRNO = ERRNO + 1 IF GT(ERRNO,50) IF CANREPLY() SERCOM = ' **** SNOSTORM TRANSLATION TERMINATED ****' SERCOM = ' **** MORE THAN 50 ERRORS IS UNNATURAL ****' ENDIF :(RCEND) ENDIF ERRORS = FILELINE ' *** ' ERRCOM IF CANREPLY() SERCOM = ' ' SERCOM = ' ' FILELINE ' ' STMT SERCOM = ' *** ' ERRCOM IF IDENT(FRED,'YES') DEBUG() ENDIF ENDIF LISTERINE('**** ' ERRCOM) ENDPROC OLD PROC (OLDSTMT) *** RECORDS OLD SNOSTORM FORMS SO THAT A MESSAGE MAY BE *** ISSUED AT THE END OF COMPILATION ON SERCOM. IF NOT OLDIES ARB OLDSTMT *** RECORD IT IF NOT ALREADY THERE *** OLDIES = OLDIES ',' OLDSTMT ENDIF ENDPROC SUBTITLE 'STATEMENT EXPRESSION DECOMPOSITION' INITIAL LOG_PARPAT = '(' OPTB QPBAL . SEXP ')' RPOS(0) LOG_NOTPAT = 'NOT' B REM . X LOG_ANDPAT = EXPPAT . X B 'AND' B EXPPAT . Y RPOS(0) LOG_ORPAT = EXPPAT . X B 'OR' B EXPPAT . Y RPOS(0) ENDINITIAL LOGIC PROC (SEXP,GOTO,COND)L,X,Y *** THE LOGIC PROCEDURE TAKES A STATEMENT EXPRESSION *** ALONG WITH THE CONDITION TO GOTO A LABEL AND *** PRODUCES THE APPROPRIATE SERIES OF SNOBOL STATEMENTS *** TO DO SO. *** *** SEXP - STATEMENT EXPRESSION *** GOTO - WHERE TO GO *** COND - WHAT CONDITION TO GOTO LABEL ON (S OF F) *** *** SEXP IS DEFINED AS FOLLOWS: *** SEXP = ANY SNOBOL STATEMENT *** | (SEXP) *** | NOT SEXP *** | SEXP OR SEXP *** | SEXP AND SEXP *** *** PRECEDENCE: "NOT" BEFORE "AND" BEFORE "OR". *** FIRST TAKE OFF THE PARENS *** LOOP WHILE SEXP LOG_PARPAT SEXP = TRIM(SEXP) ENDLOOP IF SEXP LOG_ORPAT *** AN "OR" *** IF IDENT(COND,'F') *** BRANCH OUT ON FAILURE *** L = GENLABEL() LOGIC(X,L,'S') LOGIC(Y,GOTO,'F') PUTLABEL(L) ELSE *** BRANCH OUT ON SUCCESS *** LOGIC(X,GOTO,'S') LOGIC(Y,GOTO,'S') ENDIF ELSEIF SEXP LOG_ANDPAT *** AN "AND" *** IF IDENT(COND,'F') *** BRANCH OUT ON FAILURE *** LOGIC(X,GOTO,'F') LOGIC(Y,GOTO,'F') ELSE *** BRANCH OUT ON SUCCESS *** L = GENLABEL() LOGIC(X,L,'F') LOGIC(Y,GOTO,'S') PUTLABEL(L) ENDIF ELSEIF SEXP LOG_NOTPAT *** A "NOT" *** IF IDENT(COND,'F') LOGIC(X,GOTO,'S') ELSE LOGIC(X,GOTO,'F') ENDIF ELSE *** NONE OF THE ABOVE, IT MUST BE A REGULAR STATEMENT PUTSTMT(' ' SEXP ' :' COND '(' GOTO ')') ENDIF ENDPROC CENTER PROC (T,S) *** CENTER RETURNS A STRING OF LENGTH S WITH *** *** THE STRING T CENTERED IN IT WITH *** *** SURROUNDING BLANKS. *** CENTER = RPAD(LPAD(T,(S + SIZE(T)) / 2,' '),S,' ') ENDPROC TABCON PROC (TXT) *** THIS PROCEDURE ADDS THE ENTRY 'TXT' TO THE *** TABLE OF CONTENTS ARRAY, ALONG WITH THE CURRENT *** PAGE NUMBER. CONTNT = ' ' FILELINE ' ' TXT NXTCON = NXTCON + 1 ENDPROC INDEXPROC PROC (PN) *** This procedure adds the procedure name 'PN' to the *** index of all procedures. PROCINDEX = PN PROCINDEX = FILELINE NXTPNAME = NXTPNAME + 1 ENDPROC INITIAL DEBUGOUT_PAT = VARPAR . L (' ' | RPOS(0)) ENDINITIAL DEBUGOUT PROC ()L *** PUT OUT A LABEL ON EACH STATEMENT SO THAT *** A *SPITDEBUG BREAK STATEMENT MAY BE ISSUED. *** ONLY PUT OUT LABELS ON UNLABELED STATEMENTS. *** BECAUSE THE TRACE FUNCTION WILL ONLY TRAP *** BRANCHES, NOT FALL INTOS, TO A LABEL, IT IS ALSO *** NECESSARY TO PUT OUT AN UNCONDITIONAL GOTO IN *** FRONT OF THE LABEL, EITHER THE ORIGINAL OR THE *** GENERATED LABEL. IF STM ' ' *** THERE IS NO LABEL ON THIS LINE YET *** *** PUT OUT A LABEL THE SAME AS THE FILE LINE # *** L = DELB(FILELINE) IF L BREAK('.') . L RPOS(1) ENDIF PUTSTMT(' :(LINE_' L ');LINE_' L) STMNO = STMNO + 1 ELSE *** PUT OUT GOTO TO THE USER'S LABEL *** IF STM DEBUGOUT_PAT PUTSTMT(' :(' L ')') ENDIF ENDIF ENDPROC CANREPLY PROC () ENDPROC RPADDER PROC (S,N) RPADDER = RPAD(S, N - 1) ' ' :S(RETURN) RPADDER = S ' ' ENDPROC TABSORT PROC (A,I,N)J,K,CRITERION * *** Entry point: If more than 2 items remain skip. *** If only one item is to be sorted, just return. IF IDENT(I,NULL) I = 1 ENDIF IF IDENT(N,NULL) PROTOTYPE(A) SPAN('0123456789') . N N = CONVERT(N,'INTEGER') ENDIF IF LE(N - I,1) GE(I,N) :S(RETURN) IF LGT(A,A) SWAP(I,N) ENDIF :(RETURN) ENDIF *** Obtain CRITERION to be used for partitioning array *** into two groups. CRITERION = A<(I + N) / 2,1> *** J will move through the array from the bottom looking *** for an element >= CRITERION. K will move through the *** array from the top looking for an element <= CRITERION J = I - 1 K = N + 1 TABSORT_UP J = J + 1 LLE(CRITERION,A) :F(TABSORT_UP) TABSORT_DOWN K = K - 1 LLE(A,CRITERION) :F(TABSORT_DOWN) *** If J is still < K, interchange and go back. IF LT(J,K) SWAP(J,K) :(TABSORT_UP) ENDIF *** We are done partitioning the elements. K will serve *** as a convenient dividing line. Sorting will be *** accomplished by sorting the 2 subarrays. Might as *** well use TABSORT to do this. TABSORT(A,I,K) TABSORT(A,K + 1,N) ENDPROC SWAP PROC (I,J)TEMP TEMP = A A = A A = TEMP TEMP = A A = A A = TEMP ENDPROC SUBTITLE 'INPUT ROUTINES' INITIAL DATA('INLINE(TEXT,TEXTNOCOM,INLN,EXLN,INTYPE,CONT,NEXT)') *** THIS DATA STRUCTURE IS USED TO HOLD AND BUFFER *** THE INPUT RECORDS AS THEY ARE READ OR CREATED. *** TEXT - THE TEXT OF THE INPUT RECORD *** TEXTNOCOM - input text with -- comments removed *** used for regular statement output *** INLN - THE INTERNAL FORM OF THE LINE NUMBER *** EXLN - THE EXTERNAL FORM OF THE LINE NUMBER *** INTYPE - NULL = REGULAR INPUT RECORD. *** 'Q' = QUEUED FROM IF STATEMENT. *** THIS AFFECTS THE LISTING STATUS. *** THIS ALSO SETS THE 'FROMQUEUE' *** SWITCH WHICH CONTROLS DEBUG *** OUTPUT. *** 'EOF'= LAST THING READ WAS AN EOF. *** CONT - CONTINUATION RECORD, NULL IF NONE. *** NEXT - NEXT INPUT RECORD, NULL IF NOT READ YET CURRENT_SOURCE = NULL *** THIS VARIABLE ALWAYS HOLDS THE 'INLINE' RECORD *** OF THE SOURCE STATEMENT THAT IS BEING WORKED ON. NEXT_INPUT = NULL *** THIS ALWAYS CONTAINS THE 'INLINE' RECORD OF THE *** NEXT INPUT RECORD. IF NO INPUT RECORD IN BUFFERED, *** THIS IS NULL. ENDINITIAL GETLINE PROC (LN,INTLN) *** GET NEXT LINE FROM SOURCE FILE *** IF GETLINE = INPUT $LN = ' 1. ' ELSE EOF = 'YES' :(FRETURN) ENDIF ENDPROC QUEUEIT PROC (S)R *** THIS PROCEDURE TAKES A STATEMENT (FROM THE SIMPLE *** IF) AND QUEUES IT SO THAT THE NEXT CALL ON *** GETSTMT WILL RETURN THE NEXT QUEUED STATEMENT. R = INLINE() TEXT(R) = S TEXTNOCOM(R) = S INTYPE(R) = 'Q' INLN(R) = INLN(CURRENT_SOURCE) EXLN(R) = EXLN(CURRENT_SOURCE) NEXT(R) = NEXT_INPUT NEXT_INPUT = R ENDPROC GIMMELINE PROC ()T *** THIS PROCEDURE READS A LINE AND BUILDS THE *** INPUT LINE DATA STRUCTURE. GIMMELINE = INLINE() IF T = GETLINE(.FILELINE,.INTERNAL) TEXT(GIMMELINE) = T TEXTNOCOM(GIMMELINE) = UNCOMMENT(T) INLN(GIMMELINE) = INTERNAL EXLN(GIMMELINE) = FILELINE ELSE INTYPE(GIMMELINE) = 'EOF' ENDIF ENDPROC GETSTMT PROC ()R,C *** THIS PROCEDURE GETS ONE INPUT STMT FROM THE *** SOURCE STREAM. THIS STATEMENT MAY HAVE BEEN *** QUEUED BY THE IF STATEMENT OR MAY ALREADY *** HAVE BEEN READ, OR MAY HAVE YET TO BE READ. IF IDENT(NEXT_INPUT,NULL) *** READ A LINE *** NEXT_INPUT = GIMMELINE() ENDIF IDENT(INTYPE(NEXT_INPUT),'EOF') :S(FRETURN) *** COLLECT ALL CONTINUATIONS UP TO NEXT STATEMENT *** C = NEXT_INPUT LOOP WHILE IDENT(NEXT(NEXT_INPUT),NULL) *** THERE IS NO NEXT LINE, SO WE BETTER READ *** A BIT TO MAKE SURE WE HAVE ALL CONTINUATIONS. R = GIMMELINE() IF TEXT(R) '+' *** THIS IS A CONTINUATION LINE *** CONT(C) = R C = R ELSE *** MUST BE THE NEXT RECORD *** NEXT(NEXT_INPUT) = R ENDIF ENDLOOP *** BUILD THE CONCATENATED STATEMENT *** GETSTMT = TEXTNOCOM(NEXT_INPUT) INTERNAL = INLN(NEXT_INPUT) R = CONT(NEXT_INPUT) LOOP WHILE DIFFER(R,NULL) *** concatenate all of the continuation lines GETSTMT = GETSTMT ' ' SUBSTR(TEXTNOCOM(R),2,SIZE(TEXTNOCOM(R)) - 1) R = CONT(R) ENDLOOP IF IDENT(INTYPE(NEXT_INPUT),'Q') FROMQUEUE = 'YES' ELSE FROMQUEUE = 'NO' ENDIF CURRENT_SOURCE = NEXT_INPUT NEXT_INPUT = NEXT(NEXT_INPUT) ENDPROC UNCOMMENT PROCEDURE (S) *** removes any '--' comments from text *** unless preceded only by blanks. IF S DASHDASH . UNCOMMENT IF UNCOMMENT OPTB ('--' | '*') *** leave statement of only comment for later UNCOMMENT = S ELSE *** strip off the -- UNCOMMENT = SUBSTR(UNCOMMENT,1,SIZE(UNCOMMENT) - 2) ENDIF ELSE UNCOMMENT = S ENDIF ENDPROCEDURE PUTSOURCE PROC () *** THIS PROCEDURE WRITES THE ORIGINAL SOURCE TEXT *** INTO THE OBJECT FILE. IT IS CALLED FOR REGULAR *** SPITBOL STATEMENTS. OVERDRIVE STATEMENTS ARE *** WRITTEN OUT USING THE PUTSTMT PROCEDURE. R = CURRENT_SOURCE LOOP WHILE DIFFER(R,NULL) INTERNAL = INLN(R) WRITELINE(TEXTNOCOM(R)) R = CONT(R) ENDLOOP STMNO = STMNO + 1 ENDPROC SUBTITLE 'LISTING ROUTINES' LISTERINE PROC (LL)LSIZE,LINE,CARRIAGE,BOXLINE,RIGHTD,LEFTD,LINE,PN DIFFER(LISTING,'YES') :S(RETURN) IDENT(FROMQUEUE,'YES') :S(RETURN) LINENO = LINENO + 1 IF GT(LINENO,LPP) OR LE(LINENO,0) *** A NEW PAGE *** PN = PAGEPFX PAGENO IF IDENT(NEWHEADER,'YES') *** A BOX TOP FOR THE NEW HEADER *** LEFTD = B16STAR RIGHTD = '*' CARRIAGE = ' ' BOXLINE = BOXLINE1 IF IDENT(VERYFIRST,'YES') *** GLITCH BECAUSE SPITBOL DOES PAGE EJECT *** PRINTER = BOXBOT PN *** START LINENO AT 3 BECAUSE OF VERSION *** LINE (AND BLANK) PUT OUT AT VERY BEGINNING. LINENO = 3 ELSE PRINTER = BOXTOP PN PRINTER = BOXLINE LINENO = 2 ENDIF PN = NULL ELSE *** NO BOX *** LEFTD = B15 RIGHTD = '' BOXLINE = ' ' LINENO = 0 IF IDENT(VERYFIRST,'YES') CARRIAGE = ' ' ELSE CARRIAGE = '1' ENDIF ENDIF IF IDENT(VERYFIRST,'YES') PRINTER = BOXLINE LINENO = LINENO + 4 VERYFIRST = 'NO' ENDIF *** TITLE TEXT, IF ANY *** IF DIFFER(TITLETEXT,INITTITLE) PRINTER = CARRIAGE LEFTD TITLETEXT PN CARRIAGE = ' ' PN = '' PRINTER = BOXLINE LINENO = LINENO + 2 ENDIF *** SUBTITLE TEXT, IF ANY *** IF DIFFER(SUBTITLETEXT,'') PRINTER = CARRIAGE LEFTD SUBTITLETEXT RIGHTD PN CARRIAGE = ' ' PN = '' PRINTER = BOXLINE LINENO = LINENO + 2 ENDIF *** CLOSE OUT THE BOX, IF THERE WAS ONE *** IF IDENT(NEWHEADER,'YES') PRINTER = BOXBOT LINENO = LINENO + 1 NEWHEADER = 'NO' ENDIF *** COLUMN HEADERS (LEV STMNO FILELINE) *** PRINTER = CARRIAGE COLHEAD PN LINENO = LINENO + 1 PAGENO = PAGENO + 1 *** REMEMBER FIRST LINE COUNT SO CAN IGNORE SPACES *** AND EJECTS WHEN THEY OCCUR AT TOP OF PAGE FIRSTL = LINENO ENDIF IF GT(SIZE(LL),132) *** break down the line into shorter parts *** LL LEN(132) . PRINTER = LOOP WHILE LL (LEN(100) | LEN(1) REM) . LINE = PRINTER = ' Continuation: ' LINE LINENO = LINENO + 1 ENDLOOP ELSE PRINTER = LL ENDIF ENDPROC LISTCOM PROC (L)SDI *** THIS PROCEDURE LISTS COMMENTS THAT SHOULD NOT *** BE INDENTED. SDI = DOINDENT DOINDENT = 'NO' LISTERINE(B5 EXLN(CURRENT_SOURCE) L) DOINDENT = SDI ENDPROC EJECT INITIAL *** Pattern to find label in LISTLINE *** LLLABPAT = BREAK(' ') . L B . INTAB REM . PART2 + | REM . L '' . INTAB . PART2 ENDINITIAL LISTLINE PROC ()L,P1,INTAB,IAMOUNT,SL,OUTLEV,TABSIZE,PART2,LNOUT,EXTRA,LPFX,MOVEIN *** WRITES THE CURRENT SOURCE IN THE LISTING *** DIFFER(LISTING,'YES') :S(RETURN) IDENT(FROMQUEUE,'YES') :S(RETURN) IF NE(STMNO,LASTSTMNO) LPFX = LPAD(STMNO,5,' ') LASTSTMNO = STMNO ELSE LPFX = ' ' ENDIF IF IDENT(DOINDENT,'YES') *** INDENT THE LINE *** IAMOUNT = INDENT IF TEXT(CURRENT_SOURCE) LLLABPAT TABSIZE = SIZE(L) + SIZE(INTAB) *** TABSIZE IS COLUMN OF ORIGINAL STMT START *** SL = CURRENT_SOURCE LOOP WHILE DIFFER(SL,NULL) *** OUTPUT EACH LINE, FIRST AND ALL CONTINUATION TEXT(SL) LLLABPAT LNOUT = EXLN(SL) *** EXTRA IS THE NUMBER OF BLANKS EACH *** CONTINUATION LINE IS INDENTED PAST *** THE FIRST LINE. EXTRA = SIZE(L) + (SIZE(INTAB) - TABSIZE) IF LT(EXTRA,0) EXTRA = 0 ENDIF MOVEIN = IAMOUNT IF DIFFER(L,NULL) *** THERE IS A LABEL TO TAKE INTO ACCOUNT IF GE(SIZE(L),SIZE(MOVEIN)) *** JUST PUT OUT THE LABEL FOLLOWED BY ONE BLANK MOVEIN = L ' ' ELSE *** REPLACE INITIAL PART OF INDENTATION WITH LABEL MOVEIN LEN(SIZE(L) + 1) = L ' ' ENDIF ENDIF LISTERINE(LPFX LNOUT P1 MOVEIN BDUPL PART2) SL = CONT(SL) ENDLOOP ELSE ERR('UNLISTABLE STATEMENT???????') ENDIF ELSE *** NO AUTOMATIC INDENTATION *** SL = CURRENT_SOURCE LOOP WHILE DIFFER(SL,NULL) LISTERINE(LPFX EXLN(SL) TEXT(SL)) SL = CONT(SL) ENDLOOP ENDIF IF LINE BREAK(' ') . L SPAN(' ') = *** INDENT THIS STATEMENT *** MOVEIN = INDENT IF DIFFER(L,NULL) IF GE(SIZE(L),SIZE(MOVEIN)) *** JUST PUT OUT THE LABEL FOLLOWED BY ONE BLANK MOVEIN = L ' ' ELSE *** REPLACE INITIAL PART OF INDENTATION WITH LABEL MOVEIN LEN(SIZE(L) + 1) = L ' ' ENDIF ENDIF LINE = MOVEIN LINE ENDIF INTLABELS = NULL ENDPROC END