From e0c6872cf40896c7be36b11dcc744620f10adf1d Mon Sep 17 00:00:00 2001 From: Norbert Preining Date: Mon, 2 Sep 2019 13:46:59 +0900 Subject: Initial commit --- support/rnototex/flagops.pas | 675 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 675 insertions(+) create mode 100644 support/rnototex/flagops.pas (limited to 'support/rnototex/flagops.pas') diff --git a/support/rnototex/flagops.pas b/support/rnototex/flagops.pas new file mode 100644 index 0000000000..60603cc7d6 --- /dev/null +++ b/support/rnototex/flagops.pas @@ -0,0 +1,675 @@ +[INHERIT('UTILITYOPS','ARGOPS'), environment('flagops')] + +MODULE FLAGOPS; + +CONST + + tab = 9; + ncharsintab = 8; + +TYPE + +dsrflagtype = record + representation : char; + turnedon : boolean + end; + + +dsrflagclasses = (notaflag, control, uppercase, lowercase, quote, +space, underline, bold, overstrike, hyphenate, break, period, capitalize, +endfootnote, comment, substitute); + +flagtabletype = array[dsrflagclasses] of dsrflagtype; + +tabrecordtype = record + tabread : boolean; + charcountintab : integer + end; + +styletype = (undetermined, decimal, octal, hexidecimal, romanupper, romanlower, + romanmixed, letterupper, letterlower, lettermixed, nostyle); + +enhancmentstates = (notenhanced, singlecharenhanced, enhancmentlocked); + + + +VAR + + lastinputchar, currentchar : [EXTERNAL] char; + capitalizetext, lowercasetext : [EXTERNAL] boolean; + inputcontainstexcommands : [EXTERNAL] boolean; + inliteral : [EXTERNAL] boolean; + totallines, totalchars : [EXTERNAL] integer; + flagtable : [EXTERNAL] flagtabletype; + tabrecord : [EXTERNAL] tabrecordtype; + LOG : [EXTERNAL] text; + columncounter : [EXTERNAL] integer; + infootnote : [EXTERNAL] boolean; + boldactive : [EXTERNAL] enhancmentstates; + underlineactive : [EXTERNAL] enhancmentstates; + startnofillagain : [EXTERNAL] boolean; + fill : [EXTERNAL] boolean; + listnestlevel : [EXTERNAL] integer; + + + +[GLOBAL] PROCEDURE beginnofill( var outfile : text ); +begin + if (fill) and (listnestlevel = 0) then + begin + writeln(outfile,'{\obeylines \obeyspaces % - begin no fill'); + fill := false + end + else + begin + writeln(outfile,'% - RNOTOTEX obeylines, obeyspaces already active'); + writeln( log,'% - RNOTOTEX obeylines, obeyspaces already active') + end +end; + + + + +[GLOBAL] PROCEDURE endnofill( var outfile : text ); +begin + if (not fill) and (listnestlevel = 0) then + begin + writeln(outfile,'} % - end of no fill'); + fill := true + end + else + begin + writeln(outfile,'% - RNOTOTEX obeylines, obeyspaces not active'); + writeln( log,'% - RNOTOTEX obeylines, obeyspaces not active') + end +end; + + + + + + +[GLOBAL] PROCEDURE writeflagname( var outfile : text; f : dsrflagclasses ); +begin + case f of + notaflag : write(outfile,'?????'); + control : write(outfile,'CONTROL'); + uppercase : write(outfile,'UPPERCASE'); + lowercase : write(outfile,'LOWERCASE'); + quote : write(outfile,'QUOTE'); + space : write(outfile,'SPACE'); + underline : write(outfile,'UNDERLINE'); + bold : write(outfile,'BOLD'); + overstrike : write(outfile,'OVERSTRIKE'); + hyphenate : write(outfile,'HYPYENATE'); + capitalize : write(outfile,'CAPITALIZE'); + endfootnote : write(outfile,'END FOOTNOTE'); + comment : write(outfile,'COMMENT'); + substitute : write(outfile,'SUBSTITUTE') + end +end; + + + + + + +[GLOBAL] FUNCTION isastylespecifier( arg : argument ) : styletype; +label + routineexit; +var + s : pckstr; + classification : styletype; +begin + s := argliteral( arg, TRUE ); + classification := undetermined; + if (s.body[1] = 'D') and (s.length = 1) then + begin + classification := decimal; + goto routineexit + end; + if (s.body[1] = 'O') and (s.length = 1) then + begin + classification := octal; + goto routineexit + end; + if (s.body[1] = 'H') and (s.length = 1) then + begin + classification := hexidecimal; + goto routineexit + end; + if (s.body = 'RU') and (s.length = 2) then + begin + classification := romanupper; + goto routineexit + end; + if (s.body = 'RL') and (s.length = 2) then + begin + classification := romanlower; + goto routineexit + end; + if (s.body = 'RM') and (s.length = 2) then + begin + classification := romanmixed; + goto routineexit + end; + if (s.body = 'LU') and (s.length = 2) then + begin + classification := letterupper; + goto routineexit + end; + if (s.body = 'LL') and (s.length = 2) then + begin + classification := letterlower; + goto routineexit + end; + if (s.body = 'LM') and (s.length = 2) then + begin + classification := lettermixed; + goto routineexit + end; + routineexit : isastylespecifier := classification +end; + + + +[GLOBAL] PROCEDURE initflagtable; +var + f : dsrflagclasses; +begin + for f := notaflag to substitute do + case f of + notaflag : begin + flagtable[f].representation := blank; + flagtable[f].turnedon := false + end; + control : begin + flagtable[f].representation := '.'; + flagtable[f].turnedon := true + end; + uppercase : begin + flagtable[f].representation := '^'; + flagtable[f].turnedon := true + end; + lowercase : begin + flagtable[f].representation := '\'; + flagtable[f].turnedon := true + end; + quote : begin + flagtable[f].representation := '_'; + flagtable[f].turnedon := true + end; + space : begin + flagtable[f].representation := '#'; + flagtable[f].turnedon := true + end; + underline : begin + flagtable[f].representation := '&'; + flagtable[f].turnedon := true + end; + bold : begin + flagtable[f].representation := '*'; + flagtable[f].turnedon := false + end; + overstrike : begin + flagtable[f].representation := '%'; + flagtable[f].turnedon := false + end; + hyphenate : begin + flagtable[f].representation := '='; + flagtable[f].turnedon := false + end; + break : begin + flagtable[f].representation := '|'; + flagtable[f].turnedon := false + end; + period : begin + flagtable[f].representation := '+'; + flagtable[f].turnedon := false + end; + capitalize : begin + flagtable[f].representation := '<'; + flagtable[f].turnedon := false + end; + endfootnote : begin + flagtable[f].representation := '!'; + flagtable[f].turnedon := false + end; + comment : begin + flagtable[f].representation := '!'; + flagtable[f].turnedon := true + end; + substitute : begin + flagtable[f].representation := '$'; + flagtable[f].turnedon := false + end + end { case } +end; {initflagtable} + + + + +[GLOBAL] FUNCTION flagclass( ch : char ) : dsrflagclasses; +var + class : dsrflagclasses; + foundclass : boolean; +begin + class := control; + foundclass := false; + while (class <> substitute) and ( not foundclass) do + if (ch = flagtable[class].representation) and (flagtable[class].turnedon)then + foundclass := true + else + class := succ(class); + if foundclass then + if inliteral then + if class = control then + flagclass := control + else + flagclass := notaflag + else + flagclass := class + else + flagclass := notaflag +end; + + + + +[GLOBAL] PROCEDURE initcharreader(var f : text ); +begin + reset(f); + lastinputchar := blank; + read(f, currentchar); + totallines := 0; + totalchars := 0; + columncounter := 1; + if ord(currentchar) = tab then + begin + tabrecord.tabread := true; + tabrecord.charcountintab := ncharsintab + end + else + begin + tabrecord.tabread := false; + tabrecord.charcountintab := 0 + end +end; + + + + +[GLOBAL] PROCEDURE getnextchar( var f : text; var gotten : boolean ); + + function nexttabcolumn( startingcolumn : integer ) : integer; + var + i : integer; + begin + i := startingcolumn; + repeat + i := i + 1 + until (i-1) mod ncharsintab = 0; + nexttabcolumn := i; + writeln(log,'nexttabcolumn input = ',startingcolumn:1,', output = ',i:1) + end; + +begin + gotten := false; + if NOT eof(f) then + if NOT eoln(f) then + with tabrecord do + begin + lastinputchar := currentchar; + gotten := true; + columncounter := columncounter + 1; + if (tabread) and (charcountintab > 0) then + begin + currentchar := blank; + charcountintab := charcountintab - 1; + if charcountintab = 0 then tabread := false + end + else + begin + totalchars := totalchars + 1; + read( f, currentchar ); + if currentchar < blank then + begin + if ord(currentchar) = tab then + begin + tabread := true; + charcountintab := nexttabcolumn( columncounter ) - columncounter-1; + writeln(log,'charcountintab = ',charcountintab) + end; + currentchar := blank + end + end + end +end; + + + +[GLOBAL] PROCEDURE startunderline( var outfile : text; class : enhancmentstates); +begin + if class <> notenhanced then + case underlineactive of + notenhanced : begin + write(outfile,'\underline{'); + underlineactive := class + end; + singlecharenhanced : nullstatement; + enhancmentlocked : nullstatement + end; + underlineactive := class +end; + + + + +[GLOBAL] PROCEDURE stopunderline( var outfile : text ); +begin + case underlineactive of + notenhanced : nullstatement; + singlecharenhanced : begin + write(outfile,'} '); + underlineactive := notenhanced + end; + enhancmentlocked : nullstatement + end +end; + + + + +[GLOBAL] PROCEDURE startbold( var outfile : text; class : enhancmentstates); +begin + if class <> notenhanced then + case boldactive of + notenhanced : begin + write(outfile,'{\bf '); + boldactive := class + end; + singlecharenhanced : nullstatement; + enhancmentlocked : nullstatement + end; + boldactive := class +end; + + + + +[GLOBAL] PROCEDURE stopbold( var outfile : text ); +begin + case boldactive of + notenhanced : nullstatement; + singlecharenhanced : begin + write(outfile,'} '); + boldactive := notenhanced + end; + enhancmentlocked : nullstatement + end +end; + + + + + +[GLOBAL] PROCEDURE passblanks( var infile, outfile : text; writethem : boolean ); +var + gotten, keeppassing : boolean; +begin + keeppassing := true; + gotten := true; + repeat + if (currentchar = blank) and (gotten) then + begin + if writethem then write(outfile, blank ); + getnextchar(infile, gotten) + end + else + keeppassing := false + until NOT keeppassing +end; + + + +[GLOBAL] PROCEDURE texwrite( var f : text; ch : char ); +const + maxtrys = 2; +var + ntrys : integer; + written : boolean; +begin + ntrys := 0; + written := false; + repeat + if (inputcontainstexcommands) or (inliteral) then + write(f, ch, error := continue) + else + if ch >= blank then + if ch in ['#','$','%','&','_','^','{','}','~'] then + write(f, '\',ch, error := continue) + else + if ch = '\' then + write(f,'\backslash ', error := continue) + else + write(f, ch, error := continue); + if status(f) > 0 then + begin + writeln(f, error := continue); + ntrys := ntrys + 1 + end + else + written := true + until (written) or (ntrys > maxtrys); + if ntrys > maxtrys then + errorexit('TEXWRITE','error writing to output') +end; + + + +[GLOBAL] PROCEDURE writecurrentchar( var infile, outfile : text ); +var + gotten : boolean; +begin + if capitalizetext then + currentchar := capchar( currentchar ); + if lowercasetext then + currentchar := lcchar( currentchar ); + case flagclass(currentchar) of + notaflag : begin + stopunderline( outfile ); + stopbold( outfile ); + texwrite(outfile, currentchar) + end; + control : begin + stopunderline( outfile ); + stopbold( outfile ); + texwrite(outfile, currentchar) + end; + uppercase : begin + getnextchar(infile, gotten); + if gotten then + case flagclass(currentchar) of + underline : startunderline( outfile, enhancmentlocked); + bold : startbold( outfile, enhancmentlocked ); + otherwise texwrite(outfile, capchar(currentchar)) + end + end; + lowercase : begin + getnextchar(infile, gotten); + if gotten then + case flagclass(currentchar) of + underline : begin + if underlineactive <> notenhanced then + write(outfile,'} '); + underlineactive := notenhanced + end; + bold : begin + if boldactive <> notenhanced then + write(outfile,'} '); + boldactive := notenhanced + end; + otherwise texwrite(outfile, lcchar(currentchar)) + end + end; + quote : begin + getnextchar(infile, gotten); + if gotten then + texwrite(outfile, currentchar ) + end; + space : write(outfile,'\ '); + underline : begin + getnextchar(infile, gotten ); + if gotten then + begin + startunderline( outfile, singlecharenhanced); + texwrite(outfile, currentchar) + end + else + texwrite(outfile, currentchar) + end; + bold : begin + getnextchar(infile, gotten); + if gotten then + begin + startbold( outfile, singlecharenhanced); + texwrite(outfile, currentchar) + end + else + texwrite(outfile, currentchar) + end; + overstrike : begin + getnextchar(infile, gotten); + if gotten then + begin + startbold( outfile, singlecharenhanced); + texwrite(outfile, currentchar) + end + else + texwrite(outfile, currentchar) + end; + hyphenate : write(outfile,'--'); + break : writeln(outfile,'\linebreak'); + period : write(outfile,'\nonfrenchspacing '); + capitalize : begin + getnextchar( infile, gotten); + if gotten then + texwrite(outfile, capchar(currentchar)) + end; + endfootnote : begin + if (columncounter = 1) and (infootnote) then + begin + if not fill then + endnofill( outfile ); + writeln(outfile,'} % - end of footnote'); + writeln( log,'} % - end of footnote'); + infootnote := false; + if startnofillagain then + begin + startnofillagain := false; + beginnofill( outfile ) + end + end + else + texwrite(outfile, currentchar) + end; + comment : begin + if flagclass(lastinputchar) = control then + write(outfile,'% ') + else + texwrite(outfile,currentchar) + end; + substitute : texwrite(outfile, currentchar) + end { case } +end; + + + + +[GLOBAL] PROCEDURE newline( var infile, outfile : text; putcrlf : boolean ); +var + gotten : boolean; +begin + if eoln(infile) then + begin + readln(infile); + totallines := totallines + 1; + columncounter := 1 + end; + if putcrlf then + writeln(outfile); + while (eoln(infile)) and (not eof(infile)) do + begin + readln(infile); + writeln(outfile); + columncounter := 1; + totallines := totallines + 1 + end; + if not eof(infile) then + begin + read(infile, currentchar); + totalchars := totalchars + 1; + lastinputchar := blank + end; + if ord(currentchar) = tab then + begin + tabrecord.charcountintab := ncharsintab; + tabrecord.tabread := true + end + else + begin + tabrecord.charcountintab := 0; + tabrecord.tabread := false + end; + if currentchar < blank then currentchar := blank +end; + + + + + + +[GLOBAL] PROCEDURE changeflagchar( flag : dsrflagclasses; newchar:char); +begin + flagtable[flag].representation := newchar; + write(log,'[internal flag representation change for '); + writeflagname(log, flag); + writeln(log,' to "',newchar,'"]') +end; + + + +[GLOBAL] PROCEDURE turnflagon( flag : dsrflagclasses ); +begin + flagtable[flag].turnedon := true; + write(log,'[internal flag '); + writeflagname(log, flag); + writeln(log,' enabled]') +end; + + + +[GLOBAL] PROCEDURE turnflagoff( flag : dsrflagclasses ); +begin + flagtable[flag].turnedon := false; + write(log,'[internal flag '); + writeflagname(log, flag); + writeln(log,' disabled]') +end; + + + + +[GLOBAL] PROCEDURE texwritearg( var outfile : text; arg : argument ); +var + s : pckstr; + i, l : integer; +begin + s := argliteral( arg, false ); + l := length( s ); + for i := 1 to l do texwrite(outfile, s.body[i]); + write(outfile, blank) +end; + + +END. -- cgit v1.2.3