{ NOTICE OF COPYRIGHT AND OWNERSHIP OF SOFTWARE: Copyright 1980, 1981, 1982, 1983 by Oregon Software, Inc. All Rights Reserved. Whether this program is copied in whole or in part and whether this program is copied in original or in modified form, ALL COPIES OF THIS PROGRAM MUST DISPLAY THIS NOTICE OF COPYRIGHT AND OWNERSHIP IN FULL. Text formatting documentation utility Release version: 2.1A Level: 5 Date: 13-Jun-1983 14:02:40 Processor: ALL System: ALL Based on software created by John P. Strait. Permission is granted by Oregon Software to all parties to copy without charge Oregon Software's enhancements of this "Prose" software. } {[b+]---------------------------------------------------------------- Prose is a formatting program, designed for document preparation. Complete external documentation is available, and it is maintained in prose form. Refer to that for an overview of prose. --------------------------------------------------------------------} program prose(input, output, infile, outfile); const infinity = 1000; { largest number + 1 } maintitle = true; { title indicator } maxinxlength = 60; { max length of index entries } maxiwidth = 132; { maximun input width } maxkeep = 9; { maximum keep value } maxmargin = 132; { largest right margin } maxnumberwidth = 20; { max number of digits in a number } maxowidth = 200; { maximum output width } maxpage = 999; { maximum page number } maxshift = 50; { max output shift } maxskip = 100; { maximum skip count } maxsplit = 20; { maximum number of split points } maxstringlength = 154; { max length of text lines } min = 10; { general reasonable mimimum } subtitle = false; { subtitle indicator } tabinterval = 8; {tab interval in input text} { certain constraints are applied to the min/max values, } { to eliminate array overflow checks and other error checks:} { } { maxstringlength >= maxiwidth + maxnumberwidth + 2 } { maxmargin <= maxstringlength - 2 } { (everything) < infinity } { (everything) > (reasonable) } {[s=4] the ascii character set: } nul = 0; blank = 32; at = 64; grav = 96; soh = 1; exclaim = 33; a = 65; smalla = 97; stx = 2; dquote = 34; b = 66; smallb = 98; etx = 3; hash = 35; c = 67; smallc = 99; eot = 4; dollar = 36; d = 68; smalld = 100; enq = 5; percent = 37; e = 69; smalle = 101; ack = 6; ampersand = 38; f = 70; smallf = 102; bel = 7; squote = 39; g = 71; smallg = 103; bs = 8; lparen = 40; h = 72; smallh = 104; ht = 9; rparen = 41; i = 73; smalli = 105; lf = 10; star = 42; j = 74; smallj = 106; vt = 11; plus = 43; k = 75; smallk = 107; ff = 12; comma = 44; l = 76; smalll = 108; cr = 13; minus = 45; m = 77; smallm = 109; so = 14; period = 46; n = 78; smalln = 110; si = 15; slash = 47; o = 79; smallo = 111; dle = 16; zero = 48; p = 80; smallp = 112; dc1 = 17; one = 49; q = 81; smallq = 113; dc2 = 18; two = 50; r = 82; smallr = 114; dc3 = 19; three = 51; s = 83; smalls = 115; dc4 = 20; four = 52; t = 84; smallt = 116; nak = 21; five = 53; u = 85; smallu = 117; syn = 22; six = 54; v = 86; smallv = 118; etb = 23; seven = 55; w = 87; smallw = 119; can = 24; eight = 56; x = 88; smallx = 120; em = 25; nine = 57; y = 89; smally = 121; sub = 26; colon = 58; z = 90; smallz = 122; esc = 27; semicolon = 59; lbracket = 91; lbrace = 123; fs = 28; less = 60; backslash = 92; verticalbar = 124; gs = 29; equal = 61; rbracket = 93; rbrace = 125; rs = 30; greater = 62; caret = 94; tilde = 126; us = 31; question = 63; underscore = 95; del = 127; {[s=1]} type alfa = packed array [1..8] of char; ascii = 0..127; asciix = 0..255; { the type ascii is extended for internal use } { in the following manner: } { } { c + 200b indicates that c is underlined. } charclass = packed record digit: boolean; { zero..nine } formchar: boolean; { c,d,e,l,p,s,t,w,hash,lbracket,rbracket, slash,dquote,squote,rparen,blank } inputchar: boolean; { b,c,d,h,k,u,w,blank } letter: boolean; { a..z,smalla..smallz } marginchar: boolean; { k,l,r,blank } numform: boolean; { n,smalln,l,small,r,smallr,blank } optionchar: boolean; { e,f,j,k,l,m,p,r,s,u,blank } outputchar: boolean; { e,p,s,u,w,blank } paragraphchar: boolean; { c,i,k,n,p,u,blank } plusorminus: boolean; { plus,minus } quote: boolean; { dquote,squote } sortinxchar: boolean; { l,m,p,r,s,blank } end; ch3 = packed array [1..3] of asciix; ch10 = packed array [1..10] of asciix; direct = (bre, { break } com, { comment } cou, { count } frm, { form } ind, { indent } inp, { input } inx, { inx } lit, { literal } mar, { margin } opt, { option } out, { output } pag, { page } par, { paragraph } res, { reset } sel, { select } ski, { skip } sor, { sortindex } sbt, { subtitle } ttl, { title } und, { undent } weo, { weos } exc, { except (used by reset) } ill, { illegal } { the following are not directives, but it is convenient } { to include them in this table. } ast, { ascii terminal } lpt, { line printer } vtr, { video terminal } xer, { Xerox 1650 printer } xep, { Xerox 1650 with proportional spacing } ilt); { illegal } dirset = set of direct; inputsettings = packed record defined: boolean; b, c, d, h, u: ascii; w: 0..infinity end; pinxentry = ^inxentry; inxentry = record x: packed array [1..maxinxlength] of asciix; xl: integer; { length of entry } xp: integer; { page number } next: pinxentry end; marginsettings = packed record defined: boolean; l, r: 0..infinity end; numberform = (numeric, upperalpha, loweralpha, upperroman, lowerroman, nonumbering); optionsettings = packed record defined: boolean; e, f, l, m, p, r, u: boolean; j, s: 0..infinity end; paragraphsettings = packed record defined: boolean; c: 0..infinity; f: ascii; i: - infinity..infinity; n: numberform; p: 0..infinity; s: 0..infinity; w: 0..infinity end; remember = 0..maxkeep; splitpoint = packed record point: 0..infinity; { position of split point within word } inpnt: 0..infinity; { position of split point within inline } hypnt: boolean { split point represents possible hyphen } end; pstring = packed array [1..maxstringlength] of asciix; string = array [1..maxstringlength] of { str[1].c always = '' } packed record c: asciix; { character } nbl: 0..infinity { if c='', number of blanks, else charwidth } end; var badjustify: integer; { j option } blankcount: integer; { accumulated blank output line counter } blankline: boolean; { blank output line indicator } casech: ascii; { c input } class: array [ascii] of charclass; { character classifications } ch: char; {next character on command line} charwidth: integer; { char width in printer units } dirch: ascii; { d input } directline: boolean; { input line is a directive } directs: array [direct] of ch3; { directive names } eject: boolean; { e output } endofinput: boolean; { internal eof indicator } ensure2: boolean; { p option } errorn1: integer; { error in number } errorn2: integer; { error in number } errors: boolean; { errors in this prose run } errorsmall: boolean; { number is too small } error1: asciix; { error text } error10: ch10; { error text } eol: boolean; { internal eoln indicator } explicitblank: ascii; { b input } filecount: 0..63; {input file index on command line (1110)} fill: boolean; { f option } firsterror: boolean; { first error on this line } form: pstring; { form buffer } formindex: integer; { current form position } formlength: integer; { form length } formnext: pstring; { form for next page } formnlength: integer; { length of formnext } gaps: array [0..maxstringlength] of 1..maxstringlength; { pointers to word gaps } hyphen: ascii; { h option } inchar: asciix; { current input character } incolumn: integer; { current input column } infile: text; {input file, attached as needed} inlength: integer; { length of current input line } inline: string; { current input line } inwidth: integer; { w input } inxbase: pinxentry; { base of index entry list } inxlast: pinxentry; { last index entry } keepinp: integer; { current input keep buffer } keepmar: integer; { current margin keep buffer } keepopt: integer; { current option keep buffer } keeppar: integer; { current paragraph keep buffer } leftjustify: boolean; { l option } leftmargin: integer; { l margin } linecount: integer; { output line count (within page) } linenumber: integer; { input line count (for error messes) } linenums: boolean; { line numbers exist on input file } lockeddent: integer; { i/u paragraph } lowercase: boolean; { for upper to lower case conversion } lowerdir: boolean; { lowercase flag in directives } months: array [1..12] of ch3; { month names } moreonleft: boolean; { indicator for justifying } multipleblanks: boolean; { m option } nblanks: integer; { blank count on input } nchars: integer; { width of output line } newinline: boolean; { begin input line indicator } newoutline: boolean; { begin output line indicator } newparagraph: boolean; { begin paragraph indicator } ngaps: integer; { number of word gaps } nicedate: ch10; { date as yy mmm dd } nsplits: integer; { number of split points in word } nwords: integer; { number of words in output line } numbering: numberform; { n paragraph } numberwidth: integer; { n paragraph } outfile: text; {output file} outlength: integer; { length of output line } outline: string; { output line } outwidth: integer; { w output } pagenumber: integer; { current page number } parachar: ascii; { p paragraph } paracount: integer; { paragraph counter } parapage: integer; { p paragraph } paraskip: integer; { s paragraph } pause: boolean; { p output } printerrors: boolean; { e option } rawclock: ch10; { clock time as hh:mm:ss } rawdate: ch10; { date as yy/mm/dd } rightjustify: boolean; { r option } rightmargin: integer; { r margin } saveinp: array [remember] of inputsettings; { input stack } savemar: array [remember] of marginsettings; { margin stack } saveopt: array [remember] of optionsettings; { option stack } savepar: array [remember] of paragraphsettings; { paragraph stack } selection: packed array [0..maxpage] of boolean; {select directive setting} shift: integer; { s output } shiftup: boolean; { u option } space: integer; { s option } splits: array [1..maxsplit] of splitpoint; { split points within word } terminaltype: direct; { output terminal type } texts: string; { for building form specifications } textindex: integer; { current text position } textlength: integer; { length of text } title: array [boolean] of pstring; { title and subtitle buffers } titlelength: array [boolean] of integer; { title and subtitle lengths } underavail: boolean; { u output } underchar: ascii; { u input } underlining: boolean; { underlining flag } underdir: boolean; { underlining flag in directives } wallclock: ch10; { clock time as hh:mm am } word: string; { current word } wordlength: integer; { length of word } day, month, year, hrs, mins, secs: integer; {Dec time interface vars} procedure timestamp(var day, month, year: integer; {date} var hour, minute, second: integer {time} ); external; procedure error(n: integer); forward; procedure validate(var num: integer; min, max, err: integer); forward; procedure reinitialize(which: dirset); forward; {*---------------------------------* | Read and Process Command String | *---------------------------------*} const %include csicon; InputExt = 'prs'; OutputExt = 'doc'; CSIprompt = 'PRS>'; {prompt to use if on RSX system} type ArgType = (UnknownArg, InputFileArg, OutputFileArg, MalformedArg, MissingArg); SubArgType = 0..0; %include csityp; InputListPtr = ^InputList; InputList = record Next: Inputlistptr; Arg: ArgValue; end; var InputListHead, NextInput: InputListPtr; {input filename list} %include csipro; {CSI standard procedures} %include getcs; %include fixarg; procedure exitst(i: Integer); external; procedure csi; {Read and process command line. } const {[f-]} ArgDefs = ArgDefTable ( ((' ', 1, 0), 0, OptionalArg, NullArg), (('Input_File ', 11, 10), 1, RequiredArg, FileArg), (('Output_File ', 2, 11), 2, OptionalArg, FileArg), ((' ', 1, 0), 0, OptionalArg, NullArg), ((' ', 1, 0), 0, OptionalArg, NullArg)); {[f+]} type ErrorMsg = (UnknownArgMsg, MalformedArgMsg, MissingArgMsg, ExtraOutputMsg); var OutputFlg: (No, Yes, Unknown); OutputArg: ArgValue; error: Boolean; procedure SetupError(msg: ErrorMsg; arg: ArgValue); begin case msg of UnknownArgMsg: write('Unknown argument'); MalformedArgMsg: write('Bad argument syntax'); MissingArgMsg: write('Required argument missing'); ExtraOutputMsg: write('Extra output file'); end; if arg.Len > 0 then write(' (', arg.txt: arg.Len, ')'); writeln; error := true; end; procedure ProcessArg(arg: ArgValue; typ: ArgType); var i: iArgValue; NewInput: InputListPtr; begin case typ of UnknownArg: SetupError(UnknownArgMsg, arg); OutputFileArg: begin if OutputFlg <> Unknown then SetupError(ExtraOutputMsg, arg); OutputArg := arg; OutputFlg := Yes; end; InputFileArg: begin new(NewInput); NewInput^.next := nil; NewInput^.arg := arg; if InputListHead = nil then InputListHead := NewInput else NextInput^.next := NewInput; NextInput := NewInput; FixFileArg(NextInput^.arg, ActualFile, InputExt, NextInput^.arg); end; MalformedArg: SetupError(MalformedArgMsg, arg); MissingArg: SetupError(MissingArgMsg, arg); end; end; begin InputListHead := nil; OutputFlg := Unknown; error := false; GetCS(ArgDefs, ProcessArg); if error then exitst(4); if OutputFlg = Yes then FixFileArg(OutputArg, ActualFile, OutputExt, OutputArg) else FixFileArg(NextInput^.arg, DefaultFile, OutputExt, OutputArg); rewrite(Outfile, OutputArg.txt); NextInput := InputListHead; end; {csi} procedure GetNextInput(var done: boolean {set if file not found} ); { Retrieve next input file from saved argument list } var OldInput: InputListPtr; {to save for dispose} begin if NextInput <> nil then begin done := false; reset(infile, NextInput^.arg.txt); OldInput := NextInput; NextInput := NextInput^.next; dispose(OldInput); end else done := true; end; {GetNextInput} {$p----------------* | General Utility | *-----------------*} { asciichar - convert literal host character to ascii. } function asciichar(ch: char): ascii; begin { asciichar } asciichar := ord(ch); end { asciichar } ; { upper - convert alphabetic characters to upper case. } function upper(ch: asciix): asciix; begin { upper } if class[ch mod 128].letter then if ch mod 128 >= smalla then upper := ch - 32 else upper := ch else upper := ch end { upper } ; { lower - convert to lower case if alphabetic. } function lower(ch: asciix): asciix; begin { lower } if class[ch mod 128].letter then if ch mod 128 <= z then lower := ch + 32 else lower := ch else lower := ch end { lower } ; { numform - determine the numeric form. * * param ch = n, smalln, l, smalll, r, smallr. * err = error if bad numeric form. } function numform(ch: ascii; err: integer): numberform; begin { numform } if class[ch].numform then case ch of n, smalln: numform := numeric; l: numform := upperalpha; smalll: numform := loweralpha; r: numform := upperroman; smallr: numform := lowerroman; blank: numform := nonumbering end else begin error1 := ch; error(err); numform := numeric end end { numform } ; { convertnumber - convert number from binary to text. * * param str - output string. * len - length of output string. * num - number to convert. * fw - field width of number. * form- form of conversion. } procedure convertnumber(var str: string; var len: integer; num, fw: integer; form: numberform); var digit: array [1..maxnumberwidth] of ascii; { digit array } nextnum: integer; { for decomposition } x1, x2: integer; { loop indeces } { send1 - send one digit. * * param dig - digit to send. } procedure send1(dig: ascii); begin { send1 } if x1 < maxnumberwidth then begin x1 := x1 + 1; digit[x1] := dig end end { send1 } ; begin { convertnumber } x1 := 0; case form of numeric: repeat nextnum := num div 10; send1(num - 10 * nextnum + zero); num := nextnum until num = 0; loweralpha, upperalpha: repeat num := num - 1; nextnum := num div 26; send1(num - 26 * nextnum + a); num := nextnum until num = 0; lowerroman, upperroman: begin while num >= 1000 do begin send1(m); num := num - 1000 end; if num >= 900 then begin send1(d); send1(m); num := num - 900 end else if num >= 500 then begin send1(d); num := num - 500 end else if num >= 400 then begin send1(c); send1(d); num := num - 400 end; while num >= 100 do begin send1(c); num := num - 100 end; if num >= 90 then begin send1(x); send1(c); num := num - 90 end else if num >= 50 then begin send1(l); num := num - 50 end else if num >= 40 then begin send1(x); send1(l); num := num - 40 end; while num >= 10 do begin send1(x); num := num - 10 end; if num >= 9 then begin send1(i); send1(x); num := num - 9 end else if num >= 5 then begin send1(v); num := num - 5 end else if num >= 4 then begin send1(i); send1(v); num := num - 4 end; while num >= 1 do begin send1(i); num := num - 1 end end; nonumbering: end; if len + fw > maxstringlength then fw := maxstringlength - len; for x2 := x1 + 1 to fw do begin len := len + 1; with str[len] do begin c := blank; nbl := charwidth end end; if len + x1 > maxstringlength then x1 := maxstringlength - len; if form in [numeric, loweralpha, upperalpha] then for x2 := x1 downto 1 do begin len := len + 1; with str[len] do begin if form = loweralpha then c := digit[x2] + 32 else c := digit[x2]; nbl := charwidth end end else for x2 := 1 to x1 do begin len := len + 1; with str[len] do begin if form = lowerroman then c := digit[x2] + 32 else c := digit[x2]; nbl := charwidth end end end { convertnumber } ; { shiftstring - convert string to upper/lower case, * considering stuttering and case shift. } procedure shiftstring(var str: string; var len: integer; var lcs: boolean); var intch: ascii; { internal character } oldch: ascii; { previous internal character } oldoldch: ascii; { previous previous character } x1, x2: integer; { loop indices } begin { shiftstring } oldch := blank; oldoldch := blank; x1 := 0; x2 := 1; if len >= 1 then if str[1].c = parachar then begin x1 := 1; x2 := 2 end; for x2 := x2 to len do begin intch := lower(str[x2].c); if intch = casech then lcs := not lcs else if intch = oldch then if (oldoldch = blank) and class[intch].letter then begin str[x1].c := upper(intch); lcs := true end else begin x1 := x1 + 1; if lcs then str[x1].c := intch else str[x1].c := upper(intch) end else begin x1 := x1 + 1; if lcs then str[x1].c := intch else str[x1].c := upper(intch) end; oldoldch := oldch; oldch := intch end; len := x1 end { shiftstring } ; { understring - set underlined characters in string, * considering underline character. * this is also done in readpstring. } procedure understring(var str: string; var len: integer; var uln: boolean); var intch: ascii; { internal character } x1, x2: integer; { loop indices } begin { understring } x1 := 0; for x2 := 1 to len do begin intch := str[x2].c; if intch = underchar then uln := not uln else begin x1 := x1 + 1; if (intch <> blank) and uln then str[x1].c := intch + 128 else str[x1].c := intch end end; if x1 > 0 then while (str[x1].c = blank) and (x1 > 1) do x1 := x1 - 1; if x1 = 1 then if str[x1].c = blank then x1 := 0; len := x1 end { understring } ; { justify - left justify, right justify, and/or center * an output line. } procedure justify; const floor = 0.0; { makes trunc do floor } cieling = 0.9999; { makes trunc do cieling } var fc: real; { to select floor or cieling } ib: integer; { insert blanks } nb: integer; { number blanks (total) } ng: integer; { number gaps (actual) } begin { justify } ng := ngaps - 1; nb := (rightmargin - nchars) * charwidth; if leftjustify then begin if rightjustify then begin if moreonleft then fc := floor else fc := cieling; for ng := ng downto 1 do begin ib := trunc(fc + nb / ng); with outline[gaps[ng]] do nbl := nbl + ib; nb := nb - ib end end end else with outline[gaps[0]] do if rightjustify then nbl := nbl + nb else nbl := nbl + trunc(nb / 2); moreonleft := not moreonleft end { justify } ; {$p-------* | Output | *--------*} { write1 - write one character, do conversion from ascii * to the host character set. * * param ch - character to write. } procedure write1(ch: asciix); var c: char; {actual char to write} begin { write1 } {$norange The following kluge is necessary because RSTS screws things up} c := chr(ch mod 128); if rsts then if ch = esc then c := chr(ch + 128); write(outfile, c); {$range} end { write1 } ; { endline - terminate and count an output line. } procedure endline; begin { endline } if selection[pagenumber] then if blankline then blankcount := blankcount + 1 else writeln(outfile); if linecount <> infinity then linecount := linecount - 1 end { endline } ; { writeblanklines - write accumulated blank lines. } procedure writeblanklines; begin { writeblanklines } blankline := false; while blankcount > 0 do begin blankcount := blankcount - 1; if linecount <> infinity then linecount := linecount + 1; endline end end { writeblanklines } ; { writestring - write a string to the output file. * * param str = string to write. * len = length of str. } procedure writestring(var str: string; len: integer); var x1, x2, x3: integer; { general index variables } lastunderline: integer; {index of last underline found} underlining: boolean; {underline attribute set} procedure startunderlining; begin {start underlining on a video terminal or Xerox printer} if terminaltype = vtr then begin write1(esc); write1(lbracket); write1(four); write1(smallm); end else if terminaltype in [xer, xep] then begin write1(esc); write1(e); end; underlining := true; end; {startunderlining} procedure stopunderlining; begin {stop underlining on a video terminal or Xerox printer} if terminaltype = vtr then begin {turn off underlining} write1(esc); write1(lbracket); write1(smallm); end else if terminaltype in [xer, xep] then begin write1(esc); write1(r); end; underlining := false; end; {stopUnderlining} begin { writestring } underlining := false; if selection[pagenumber] then begin while (str[len].c = blank) and (len > 1) do len := len - 1; if str[len].c = blank then len := 0; blankline := len = 0; if not blankline then begin writeblanklines; lastunderline := 0; str[1].nbl := str[1].nbl + shift; if explicitblank <> nul then for x1 := 1 to len do with str[x1] do if c mod 128 = explicitblank then begin c := blank + (c div 128) * 128; nbl := charwidth end; if shiftup then for x1 := 1 to len do str[x1].c := upper(str[x1].c); for x1 := 1 to len do with str[x1] do if c = blank then begin if underlining then stopunderlining; for x2 := 1 to nbl do write1(blank); end else begin if c div 128 <> 0 then if terminaltype = ast then begin if underavail then begin write1(underscore); write1(bs); end end else if terminaltype in [vtr, xer, xep] then begin if underavail and not underlining then startunderlining; end else lastunderline := x1 else if underlining then stopunderlining; write1(c); end; if underlining then stopunderlining; if (terminaltype = lpt) and (lastunderline <> 0) and underavail then begin write1(cr); for x1 := 1 to lastunderline do with str[x1] do if c = blank then for x2 := 1 to nbl do write1(blank) else if c div 128 <> 0 then write1(underscore) else write1(blank); end; str[1].nbl := str[1].nbl - shift; end end else blankline := false end { writestring } ; { advanceform - advance form to next l specification. } procedure advanceform; var ch: ascii; { key character } formch: asciix; { current form character } fw: integer; { field width of current item } tl: integer; { local title length } which: boolean; { which title (main,sub) } x1: integer; { general index } { nextch - advance to next form character. } procedure nextch; begin { nextch } formindex := (formindex mod formlength) + 1; formch := form[formindex] end { nextch } ; { number - read a number from the form. * * param def = default number. } function number(def: integer): integer; var num: integer; { number begin built } begin { number } if class[formch].digit then begin num := 0; repeat num := num * 10 + formch - zero; if num >= infinity then num := infinity - 1; nextch until not class[formch].digit; number := num end else number := def end { number } ; { fieldwidth - read optional field width specification. * * param def = default field width. * min = minimum field width. } procedure fieldwidth(def, min: integer); begin { fieldwidth } fw := def; if formch = colon then begin nextch; fw := number(def) end; if fw < min then fw := min end { fieldwidth } ; { send1 - send one character to the text line. * * param ch = character to be sent. } procedure send1(ch: asciix); begin { send1 } textindex := textindex + 1; if textindex + shift > maxowidth then begin textindex := 1; error( - 1) end; texts[textindex].c := ch; texts[textindex].nbl := charwidth; if textindex > textlength then textlength := textindex end { send1 } ; { send10 - send up to 10 characters to the text line, * determining field width. * * param ch = 10 characters. * def = default field width. * min = minimum field width. } procedure send10(ch: ch10; def, min: integer); var x1: integer; { index into ch } begin { send10 } fieldwidth(def, min); if fw < def then { send rightmost fw characters } for x1 := def - fw + 1 to def do send1(ch[x1]) else { send leading blanks and all def characters } begin for x1 := 1 to fw - def do send1(blank); for x1 := 1 to def do send1(ch[x1]) end end { send10 } ; { writetext - write text buffer. } procedure writetext; begin { writetext } writestring(texts, textlength); endline; textlength := 1; textindex := 1 end { writetext } ; { wait - wait for operator acknowledgement. * heavily system dependant. } procedure wait; begin { wait } if terminaltype = ast then begin write(outfile, chr(bel)); readln(input) end end { wait } ; begin { advanceform } ch := upper(form[formindex]); if not class[ch].quote then nextch; if class[ch].formchar then case ch of c: send10(rawclock, 8, 0); d: send10(rawdate, 8, 0); e: send10(nicedate, 9, 0); l: begin if textlength > 1 then writetext; linecount := number(1) end; p: begin if (formch = colon) or (formch = blank) then ch := n else begin ch := formch; nextch end; fieldwidth(3, 0); convertnumber(texts, textindex, pagenumber, fw, numform(ch, - 4)); if textindex > textlength then textlength := textindex end; s, t: begin which := (ch = t) or (ch = smallt); tl := titlelength[which]; fieldwidth(tl, 0); if fw < tl then { send last fw characters } for x1 := tl - fw + 1 to tl do send1(title[which][x1]) else { send leading blanks and all tl characters } begin for x1 := 1 to fw - tl do send1(blank); for x1 := 1 to tl do send1(title[which][x1]) end end; w: send10(wallclock, 8, 0); hash: begin x1 := number(1); while textindex < x1 do send1(blank); textindex := x1 end; lbracket: begin if textlength > 1 then writetext; if selection[pagenumber] then begin if eject then begin blankcount := 0; if terminaltype = lpt then page(outfile) else write1(ff) end else if terminaltype <> lpt then writeblanklines; if pause then wait end; if formnlength > 0 then begin form := formnext; formlength := formnlength; formindex := 0; repeat nextch until formch = lbracket; nextch; formnlength := 0 end end; rbracket: begin if textlength > 1 then writetext; pagenumber := pagenumber + 1; validate(pagenumber, 0, infinity - 1, - 3) end; slash: for x1 := 1 to number(1) do writetext; dquote, squote: repeat nextch; while formch <> ch do begin send1(formch); nextch end; nextch; if formch = ch then send1(ch) until formch <> ch; blank: end else begin error1 := ch; error( - 2) end end { advanceform } ; { beginline - begin output line, advance form as necessary. } procedure beginline; var fix: integer; { local copy of formindex } fnl: integer; { local copy of formnlength } begin { beginline } if linecount <= 0 then { make linecount >0 } begin fix := formindex; fnl := formnlength; repeat if fnl <> formlength then begin fix := formindex; fnl := formnlength end; advanceform until (linecount > 0) or ((fix = formindex) and (fnl = 0)); if linecount <= 0 then { bad form } begin error( - 5); linecount := infinity end end; blankline := true end { beginline } ; { writenull - write a null line. } procedure writenull; begin { writenull } beginline; writestring(outline, 1); endline end { writenull } ; { skip - skip output lines. } procedure skip(n: integer); var x1: integer; begin { skip } if n > linecount then n := linecount; for x1 := 1 to n do writenull end { skip } ; { writeline - write the output line. } procedure writeline; begin { writeline } beginline; writestring(outline, outlength); endline; if space <> 0 then skip(space); outlength := 1; outline[1].nbl := leftmargin * charwidth; nchars := leftmargin; nwords := 0; ngaps := 0; gaps[0] := 1; newoutline := true end { writeline } ; { page - conditionally produce a page eject. } procedure newpage(n: integer); begin { new_page } if linecount < n then repeat while linecount > 0 do writenull; while (form[formindex] <> lbracket) and (linecount <= 0) do advanceform until form[formindex] = lbracket else if linecount = infinity then if 5 < n then skip(5) end { new_page } ; { ------------------------------------------------------------------ } { } { input } { } { } { ------------------------------------------------------------------ } { nextchar - advance to the next input character, and * convert from host character set to ascii. } procedure nextchar; { readline - read an input line, convert into ascii, * considering case shift and underlining. } procedure readline; var extch: char; { external character } x1, x2: integer; { general index variables } begin { readline } newinline := true; x1 := 0; while not eoln(infile) and (x1 < inwidth) do begin read(infile, extch); if ord(extch) = ht then repeat x1 := x1 + 1; inline[x1].c := blank; until x1 mod tabinterval = 0 else if ord(extch) >= blank then begin x1 := x1 + 1; inline[x1].c := ord(extch) end; end; inline[x1 + 1].c := blank; for x2 := 1 to x1 + 1 do inline[x2].nbl := charwidth; if inline[1].c = dirch then begin directline := true; lowerdir := true end else directline := directline and (inline[1].c = plus); if casech <> nul then if directline then shiftstring(inline, x1, lowerdir) else shiftstring(inline, x1, lowercase); if x1 > 1 then while (inline[x1].c = blank) and (x1 > 1) do x1 := x1 - 1; if x1 = 1 then if inline[x1].c = blank then x1 := 0; inlength := x1; readln(infile); firsterror := true; end { readline } ; begin { nextchar } incolumn := incolumn + 1; if incolumn > inlength then begin if eol then begin if not endofinput then if eof(infile) then getnextinput(endofinput); if not endofinput then begin readline; incolumn := 1; if linenums then begin if class[inline[1].c].digit then begin linenumber := 0; repeat linenumber := linenumber * 10 + inline[incolumn].c - zero; incolumn := incolumn + 1 until not class[inline[incolumn].c].digit end; incolumn := incolumn + 1 end else linenumber := linenumber + 1; eol := incolumn > inlength; if eol then inchar := blank else inchar := inline[incolumn].c end end else begin eol := true; inchar := blank end end else inchar := inline[incolumn].c end { nextchar } ; { nextline - advance to beginning of next input line. } procedure nextline; begin { nextline } incolumn := inlength + 1; eol := true; nextchar end { nextline } ; { ------------------------------------------------------------------ } { } { directive processing } { } { } { ------------------------------------------------------------------ } { break - cause a break in justification. } procedure break; begin { break } if not newoutline then begin if not (leftjustify and rightjustify) then justify; writeline end; underlining := false; newparagraph := true end { break } ; { inundent - schedule an indent or undent. * * param inun > 0 for indent, * < 0 for undent. } procedure inundent(inun: integer); begin { inundent } break; nchars := leftmargin + inun; if nchars < 0 then nchars := 0; outline[1].nbl := nchars * charwidth end { inundent } ; { inpsave - save input settings } procedure inpsave; begin { inpsave } validate(keepinp, 0, maxkeep, 1151); with saveinp[keepinp] do begin defined := true; b := explicitblank; c := casech; d := dirch; h := hyphen; u := underchar; w := inwidth end end { inpsave } ; { inprestore - restore previous input settings. } procedure inprestore; begin { inprestore } validate(keepinp, 0, maxkeep, 1151); with saveinp[keepinp] do if defined then begin explicitblank := b; if casech <> c then begin casech := c; lowercase := casech <> nul end; dirch := d; hyphen := h; underchar := u; inwidth := w end else error(1105) end { inprestore } ; { marsave - save margin settings. } procedure marsave; begin { marsave } validate(keepmar, 0, maxkeep, 151); with savemar[keepmar] do begin defined := true; l := leftmargin; r := rightmargin end end { marsave } ; { marrestore - restore previous margin settings. } procedure marrestore; begin { marrestore } validate(keepmar, 0, maxkeep, 151); with savemar[keepmar] do if defined then begin leftmargin := l; rightmargin := r end else error(105) end { marrestore } ; { optsave - save option settings. } procedure optsave; begin { optsave } validate(keepopt, 0, maxkeep, 251); with saveopt[keepopt] do begin defined := true; e := printerrors; f := fill; j := badjustify; l := leftjustify; m := multipleblanks; p := ensure2; r := rightjustify; s := space; u := shiftup end end { optsave } ; { optrestore - restore previous option settings. } procedure optrestore; begin { optrestore } validate(keepopt, 0, maxkeep, 251); with saveopt[keepopt] do if defined then begin printerrors := e; fill := f; badjustify := j; leftjustify := l; multipleblanks := m; ensure2 := p; rightjustify := r; space := s; shiftup := u end else error(205) end { optrestore } ; { parsave - save paragraph settings. } procedure parsave; begin { parsave } validate(keeppar, 0, maxkeep, 351); with savepar[keeppar] do begin defined := true; c := 0; { it would seem that this is superfluous } f := parachar; i := lockeddent; n := numbering; p := parapage; s := paraskip; w := numberwidth end end { parsave } ; { parrestore - restore previous paragraph settings. } procedure parrestore; begin { parrestore } validate(keeppar, 0, maxkeep, 351); with savepar[keeppar] do if defined then begin paracount := c; parachar := f; lockeddent := i; numbering := n; parapage := p; paraskip := s; numberwidth := w end else error(305) end { parrestore } ; { directive - process one directive } procedure directive; var dir: direct; { current directive } fullword: ch10; { current directive word } word: ch3; { 3 letters of current directive word } wordlength: integer; { length of current directive word } x1, x: integer; { general index variables } { nextch - advance to nextchar, considering continuations. } procedure nextch; begin { nextch } nextchar; if eol and (infile^ = '+') then begin nextchar; inchar := blank end end { nextch } ; { switch - determine a switch option, considering * the default. * * param def = default. } function switch(def: boolean): boolean; begin { switch } if class[inchar].plusorminus then begin switch := inchar = plus; nextch end else switch := def end { switch } ; { character - determine a character option, considering * the default. * * param def = default. } function character(def: ascii): ascii; begin { character } if inchar <> blank then begin character := inchar; nextch end else character := def end { character } ; { number - determine a numeric option, considering * the default and the previous value. * * param def = default. * last = previous value, if < 0 then * relative form is not recognized. * min = minimum allowed value. * max = maximum allowed value. * err = error number (if out of range). } function number(def, last, min, max, err: integer): integer; var num: integer; { number being built } sign: ascii; { plus or minus sign } begin { number } if class[inchar].plusorminus and (last >= 0) then begin sign := inchar; nextch end else begin sign := plus; last := 0 end; if class[inchar].digit then begin num := 0; repeat num := num * 10 + inchar - zero; if num >= infinity then num := infinity - 1; nextch until not class[inchar].digit end else num := def; if sign = plus then num := last + num else num := last - num; if num < 0 then num := 0; validate(num, min, max, err); number := num end { number } ; { readword - read the next directive word. } procedure readword; var x1: integer; { loop index } begin { readword } wordlength := 0; while class[inchar].letter do begin wordlength := wordlength + 1; if wordlength <= 10 then begin fullword[wordlength] := inchar; if wordlength <= 3 then word[wordlength] := upper(inchar) end; nextch end; for x1 := wordlength + 1 to 10 do fullword[x1] := blank; for x1 := wordlength + 1 to 3 do word[x1] := blank end { readword } ; { readpstring - read a pstring until a terminator character. * * param str = pstring to be read. * len = length of predefined portion of str, updated * to new length. * endc = terminator character. } procedure readpstring(var str: pstring; var len: integer; endc: ascii); begin { readpstring } underdir := false; while (inchar <> endc) and not eol do begin if inchar = underchar then underdir := not underdir else if len < maxstringlength then begin len := len + 1; if underdir then str[len] := inchar + 128 else str[len] := inchar end; nextch end end { readpstring } ; { lookup - look up the directive word. * * param first = first acceptable directive word. * illegal = last+1 acceptable directive word. } function lookup(first, illegal: direct): direct; var d: direct; { lookup loop index } begin { lookup } directs[illegal] := word; d := first; while (directs[d][1] <> word[1]) or (directs[d][2] <> word[2]) or (directs[d][3] <> word[3]) do d := succ(d); lookup := d end { lookup } ; { input - process input directive. } procedure inputd; var ch: ascii; { key character } begin { inputd } if inchar = lparen then begin nextch; keepinp := keepinp + 1; while (inchar <> rparen) and not eol do begin ch := upper(inchar); nextch; if class[ch].inputchar then case ch of b: explicitblank := character(nul); c: begin ch := character(nul); if ch <> casech then begin casech := ch; lowercase := casech <> nul end end; d: dirch := character(period); h: hyphen := character(nul); k: keepinp := number(0, - 1, 0, maxkeep, 1151); u: underchar := character(nul); w: inwidth := number(150, - 1, min, maxiwidth, 1154); blank: end else begin error1 := ch; error(1101) end end; if inchar = rparen then nextch else error(1102); inpsave end else begin if class[inchar].digit then keepinp := number(0, - 1, 0, maxkeep, 1151) else keepinp := keepinp - 1; inprestore end end { inputd } ; { literal - process literal directive. } procedure literal; var ch: asciix; { literal character } i: integer; { loop index } litlength: integer; { length of litstring } litstring: pstring; { argument of literal directive } begin { literal } litlength := 0; readpstring(litstring, litlength, nul); for i := 1 to litlength do begin ch := litstring[i]; if ch = explicitblank then write1(blank) else write1(ch) end; writeln end { literal } ; { margin - process margin directive. } procedure margin; var ch: ascii; { key character } begin { margin } if inchar = lparen then begin nextch; keepmar := keepmar + 1; while (inchar <> rparen) and not eol do begin ch := upper(inchar); nextch; if class[ch].marginchar then case ch of k: keepmar := number(0, - 1, 0, maxkeep, 151); l: leftmargin := number(0, leftmargin, 0, infinity, 0); r: rightmargin := number(70, rightmargin, 0, infinity, 0); blank: end else begin error1 := ch; error(101) end end; if inchar = rparen then nextch else error(102); validate(rightmargin, min, maxmargin, 152); validate(leftmargin, 0, rightmargin, 153); marsave end else begin if class[inchar].digit then keepmar := number(0, - 1, 0, maxkeep, 151) else keepmar := keepmar - 1; marrestore end; nchars := leftmargin; outline[1].nbl := nchars * charwidth end { margin } ; { option - process option directive. } procedure option; var ch: ascii; { key character } begin { option } if inchar = lparen then begin nextch; keepopt := keepopt + 1; while (inchar <> rparen) and not eol do begin ch := upper(inchar); nextch; if class[ch].optionchar then case ch of e: printerrors := switch(true); f: fill := switch(true); j: badjustify := number(0, - 1, 3, infinity, 265) - 2; k: keepopt := number(0, - 1, 0, maxkeep, 251); l: leftjustify := switch(true); m: multipleblanks := switch(true); p: ensure2 := switch(true); r: rightjustify := switch(true); s: space := number(1, - 1, 1, 3, 266) - 1; u: shiftup := switch(false); blank: end else begin error1 := ch; error(201) end end; if inchar = rparen then nextch else error(202); optsave end else begin if class[inchar].digit then keepopt := number(0, - 1, 0, maxkeep, 251) else keepopt := keepopt - 1; optrestore end; end { option } ; { output - process output directive. } procedure outputd; var ch: ascii; { key character } begin { outputd } if linecount < 0 then begin if inchar = lparen then begin repeat nextch until (inchar <> blank) or eol; readword; if wordlength <= 3 then terminaltype := lookup(ast, ilt) else terminaltype := ilt; if terminaltype = ilt then begin error(1009); terminaltype := lpt end; while (inchar <> rparen) and not eol do begin ch := upper(inchar); nextch; if class[ch].outputchar then case ch of e: eject := switch(false); p: pause := switch(false); s: shift := number(0, - 1, 0, maxshift, 1064); u: underavail := switch(true); w: outwidth := number(maxowidth, - 1, 0, maxowidth, 1054); blank: end else begin error1 := ch; error(1001) end end; if inchar = rparen then nextch else error(1002); shift := shift * charwidth; linecount := 0 end end else error(1010) end { outputd } ; { paragraph - process paragraph directive. } procedure paragraph; var ch: ascii; { key character } begin { paragraph } savepar[keeppar].c := paracount; if inchar = lparen then begin nextch; keeppar := keeppar + 1; paracount := 0; while (inchar <> rparen) and not eol do begin ch := upper(inchar); nextch; if class[ch].paragraphchar then case ch of c: paracount := number(0, - 1, 0, infinity, 0); f: parachar := character(nul); i: lockeddent := number(5, - 1, 0, rightmargin - min, 355); k: keeppar := number(0, - 1, 0, maxkeep, 351); n: begin if not class[inchar].digit then numbering := numform(character(blank), 307) else numbering := numeric; numberwidth := number(3, - 1, 0, maxnumberwidth, 356) end; p: parapage := number(0, - 1, 0, infinity, 0); s: paraskip := number(0, paraskip, 0, maxskip, 357); u: lockeddent := - number(0, - 1, 0, infinity, 0); blank: end else begin error1 := ch; error(301) end end; if inchar = rparen then nextch else error(302); parsave; end else if class[inchar].digit then begin keeppar := number(0, - 1, 0, maxkeep, 351); parrestore; paracount := 0 end else begin keeppar := keeppar - 1; parrestore end end { paragraph } ; { readform - read the form specificatio to the form buffer. } procedure readform; var nobracket: boolean; { if no lbracket in the form } quote: ascii; { outer quote character for a string } { addch - add a character to the form. * * param ch - character to add. } procedure addch(ch: ascii); begin { addch } formnlength := formnlength + 1; formnext[formnlength] := ch end { addch } ; begin { readform } formnlength := 0; nobracket := true; if inchar = lparen then begin nextch; while (inchar <> rparen) and not eol do begin addch(inchar); nobracket := nobracket and (inchar <> lbracket); if class[inchar].quote then begin quote := inchar; nextch; readpstring(formnext, formnlength, quote); if inchar = quote then nextch else error(403); addch(quote) end else nextch end; if inchar = rparen then nextch else error(402); if formnlength = 0 then linecount := infinity else if nobracket then addch(lbracket); end else linecount := infinity end { readform } ; { readinx - read an index entry. } procedure readinx; var index: pstring; { index buffer } indexlength: integer; {length of index } p: pinxentry; { pointer to new index entry } x1: integer; { general index variable } begin { readindex } indexlength := 0; readpstring(index, indexlength, nul); new(p); if indexlength > maxinxlength then indexlength := maxinxlength; with p^ do begin xl := indexlength; xp := pagenumber; for x1 := 1 to indexlength do x[x1] := index[x1]; for x1 := indexlength + 1 to maxinxlength do x[x1] := nul end; if inxbase = nil then inxbase := p else inxlast^.next := p; inxlast := p end {readinx } ; { reset - process reset directive. } procedure reset; var d: direct; { reset directive name } except: boolean; { except keyword is present } first: boolean; { first directive name } which: dirset; { which directives to reset } begin { reset } if inchar = lparen then begin first := true; except := false; which := []; nextch; while inchar <> rparen do if inchar = blank then nextch else if class[inchar].letter then begin readword; d := lookup(bre, ill); if d in [cou, frm, inp, inx, mar, opt, out, pag, par, sel, sbt, ttl] then which := which + [d] else if d = exc then if first then except := true else error(1211) else begin error10 := fullword; if d = ill then error(1206) else error(1212) end; first := false end else begin error1 := inchar; error(1201); nextch end; if except then which := [bre..ill] - which end else which := [bre..ill]; while not eol do nextch; if [out, pag, frm] * which <> [] then begin newpage(infinity); if linecount < infinity then advanceform end; reinitialize(which) end { reset } ; { select - process select directive. } procedure select; var x1, x2: integer; { general index variables } begin { select } if inchar = lparen then begin nextch; for x1 := 0 to maxpage do selection[x1] := false; while (inchar <> rparen) and not eol do if class[inchar].digit then begin x1 := number(0, - 1, 0, maxpage, 504); if inchar = colon then begin nextch; for x1 := x1 to number(x1, x1, x1, maxpage, 504) do selection[x1] := true end else selection[x1] := true end else begin if inchar <> blank then begin error1 := inchar; error(501) end; nextchar end; if inchar = rparen then nextch else error(502) end else for x1 := 0 to maxpage do selection[x1] := true end { select } ; { sortinx - sort and print index entries. } procedure sortinx; var firstinx: pinxentry; { first entry for sorting } lastinx: pinxentry; { last entry for sorting } leftwidth: integer; { l specification } margin: integer; { m specification } pagecol: integer; { p specification } rightwidth: integer; { r specification } sortcol: integer; { s specification } { parse - parse the sortindex directive. } procedure parse; var ch: ascii; { key character } begin { parse } leftwidth := 2; margin := 0; pagecol := 0; rightwidth := 2; sortcol := 1; if inchar = lparen then begin nextch; while (inchar <> rparen) and not eol do begin ch := upper(inchar); nextch; if class[ch].sortinxchar then case ch of l: leftwidth := number(2, - 1, 0, 30, 658); m: margin := number(0, - 1, 0, 30, 659); p: pagecol := number(0, - 1, 0, maxinxlength + min, 660); r: rightwidth := number(2, - 1, 0, 30, 661); s: if (inchar = p) or (inchar = smallp) then begin sortcol := - 1; nextch end else sortcol := number(1, - 1, 1, maxinxlength - min, 662); blank: end else begin error1 := ch; error(601) end end; if inchar = rparen then nextch else error(602) end end { parse } ; { sort - sort the index entries. } procedure sort; var p: pinxentry; { for traversing the index list } s1, s2: pinxentry; { temps for sorting } x1: integer; { general index variable } begin { sort } new(firstinx); new(lastinx); with firstinx^ do begin xl := 0; next := lastinx; for x1 := 1 to maxinxlength do x[x1] := nul; end; with lastinx^ do begin xl := 0; next := nil; for x1 := 1 to maxinxlength do x[x1] := del end; if sortcol < 0 then begin if inxlast <> nil then inxlast^.next := lastinx; firstinx^.next := inxbase; inxbase := nil end else begin p := inxbase; if inxlast <> nil then inxlast^.next := nil; while p <> nil do begin inxbase := p^.next; s2 := firstinx; repeat s1 := s2; s2 := s1^.next; x1 := sortcol; while (x1 < maxinxlength) and (upper(p^.x[x1]) = upper(s2^.x[x1])) do x1 := x1 + 1 until upper(p^.x[x1]) < upper(s2^.x[x1]); s1^.next := p; p^.next := s2; p := inxbase end end end { sort } ; { print - print the index entries. } procedure print; var p: pinxentry; { for traversing the index list } x1: integer; { general index variable } { send1 - send one character to the output line. * * param ch - character to send. } procedure send1(ch: asciix); begin { send1 } outlength := outlength + 1; with outline[outlength] do begin c := ch; nbl := charwidth end end { send1 } ; begin { print } p := firstinx^.next; while p <> lastinx do with p^ do begin for x1 := 1 to margin do send1(blank); for x1 := 1 to pagecol do if x1 > xl then send1(blank) else send1(x[x1]); convertnumber(outline, outlength, xp, leftwidth, numeric); for x1 := 1 to rightwidth do send1(blank); for x1 := pagecol + 1 to xl do send1(x[x1]); writeline; dispose(firstinx); firstinx := p; p := firstinx^.next end; dispose(lastinx) end { print } ; begin { sortinx } parse; sort; print end { sortinx } ; begin { directive } repeat nextch; readword; dir := lookup(bre, ill); while (inchar = blank) and not eol do nextch; if dir in [bre, frm, ind, mar, opt, pag, res, ski, sor, und, weo] then break; case dir of bre: ; com: while not eol do nextch; cou: pagenumber := number(1, pagenumber, 0, maxpage, 759); frm: readform; ind: inundent(number(5, - 1, 0, rightmargin, 856)); inp: inputd; inx: readinx; lit: literal; mar: margin; opt: option; out: outputd; pag: newpage(number(infinity, - 1, 0, infinity, 0)); par: paragraph; res: reset; sel: select; ski: skip(number(5, - 1, 0, maxskip, 957)); sor: sortinx; sbt: begin titlelength[subtitle] := 0; readpstring(title[subtitle], titlelength[subtitle], nul) end; ttl: begin titlelength[maintitle] := 0; readpstring(title[maintitle], titlelength[maintitle], nul) end; und: inundent( - number(infinity, - 1, 0, infinity, 0)); weo: {putseg(output)} ; {****} exc, ill: begin error10 := fullword; error(006) end end; while (inchar <> dirch) and not eol do begin if inchar <> blank then begin error1 := inchar; error(1) end; nextch end until eol end { directive } ; { --------------------------------------------- } { } { text formatting } { } { } { --------------------------------------------- } { nextword - read the next input word, process directives * when appropriate. } procedure nextword; var x1: integer; { loop index } begin { nextword } wordlength := 0; newinline := false; while eol and not endofinput do begin nextchar; if eol and not endofinput then begin break; writenull end else if inchar = dirch then directive else if inchar = parachar then begin break; if paraskip > 0 then skip(paraskip); if parapage > 0 then newpage(parapage); inundent(lockeddent); if numbering <> nonumbering then begin paracount := paracount + 1; convertnumber(word, wordlength, paracount, numberwidth, numbering) end; nextchar end end; if not endofinput then begin nblanks := 0; if wordlength = 0 then while inchar = blank do begin nblanks := nblanks + 1; nextchar end; if newinline then begin if (nblanks > 0) or not fill then break; if underchar <> nul then begin understring(inline, inlength, underlining); incolumn := incolumn - 1; nextchar end end else if not multipleblanks and (nblanks > 1) then nblanks := 1; nsplits := 0; while inchar <> blank do begin if inchar mod 128 = hyphen then begin if nsplits < maxsplit then begin nsplits := nsplits + 1; with splits[nsplits] do begin point := wordlength; if incolumn > 1 then hypnt := class[inline[incolumn - 1].c mod 128].letter and class[inline[incolumn + 1].c mod 128].letter else hypnt := false; inpnt := incolumn end end end else begin wordlength := wordlength + 1; with word[wordlength] do begin c := inchar; nbl := charwidth end end; nextchar end end end { nextword } ; { packword - pack a word into the output line. } procedure packword; var nb: integer; { number blanks (preceding word) } nc: integer; { nchars predicted after adding word } { addword - add the word to the output line. } procedure addword; var x1: integer; { general index variable } begin { addword } with outline[outlength] do nbl := nbl + nb * charwidth; for x1 := 1 to wordlength do begin outlength := outlength + 1; outline[outlength] := word[x1] end; outlength := outlength + 1; with outline[outlength] do begin c := blank; nbl := 0 end; nchars := nc; if nchars >= leftmargin then begin ngaps := ngaps + 1; gaps[ngaps] := outlength end else gaps[0] := outlength end { addword } ; { setup - set up for packword. } procedure setup; var x1: integer; { loop index } begin { setup } if newparagraph then nb := nblanks else if newoutline then nb := 0 else begin if newinline then nb := nblanks + 1 else nb := nblanks; if ensure2 and (outline[outlength - 1].c mod 128 = period) and (nblanks < 2) and (nchars >= leftmargin) then nb := 2 end; nc := nchars + nb + wordlength; if nc > rightmargin then if rightmargin - nchars > badjustify * (ngaps - 1) then begin { going to insert too many blanks } if nsplits > 0 then begin x1 := nsplits; while x1 > 0 do with splits[x1] do begin nc := nchars + nb + point + ord(hypnt); if nc <= rightmargin then begin x1 := 0; { exit loop } incolumn := inpnt; { reset input stream } eol := false; nextchar; wordlength := point + ord(hypnt); if hypnt then word[wordlength].c := minus; end else x1 := x1 - 1; end; end; if nc > rightmargin then begin error(008); end; end; newoutline := false; newparagraph := false end { setup } ; begin { packword } setup; if nc <= rightmargin then addword; if nc >= rightmargin then { don-t call packword, to prevent unending recursion in } { the case of a word that doesn-t fit between the margins } begin justify; writeline; if nc > rightmargin then begin setup; addword; if nc >= rightmargin then begin justify; writeline end end end end { packword } ; { --------------------------------------------- } { } { error processing } { } { } { --------------------------------------------- } { error - issue an error message. * * param n = error number. n is negative for errors detected during form * processing to prevent unending recursion. * for positive n, the following convention is used: * n div 100 indicates which directive the * refers to. * n mod 100 selects a particular error message. * n mod 100 is >= 50 for numeric errors. * global variables error10, error1, errorn1,errorn2, * and errorsmall are used for printing specific * values which are in error. } procedure error { n : integer } ; type host5 = packed array [1..5] of char; host10 = packed array [1..10] of char; host20 = packed array [1..20] of char; var len: integer; { length of str } str: string; { for printing inline } x1, x2: integer; { general loop index } { wr5,wr10,wr20- write host characters to str. } procedure wr5(cs: host5; nc: integer); var x1: integer; begin { wr5 } for x1 := 1 to nc do begin len := len + 1; with str[len] do begin c := asciichar(cs[x1]); nbl := charwidth end end end { wr5 } ; procedure wr10(cs: host10; nc: integer); var x1: integer; begin { wr10 } for x1 := 1 to nc do begin len := len + 1; with str[len] do begin c := asciichar(cs[x1]); nbl := charwidth end end end { wr10 } ; procedure wr20(cs: host20; nc: integer); var x1: integer; begin { wr20 } for x1 := 1 to nc do begin len := len + 1; with str[len] do begin c := asciichar(cs[x1]); nbl := charwidth end end end { wr20 } ; begin { error } if printerrors then begin errors := true; str[1].c := blank; str[1].nbl := 0; len := 1; wr5('---- ', 5); if n < 0 then begin wr20('form error: ', 12); case n of - 1: wr20('line too long ', 13); - 2: begin len := len + 1; with str[len] do begin c := error1; nbl := charwidth end end; - 3: wr20('pagenumber too large', 20); - 4: wr20('bad numeric form ', 16); - 5: wr20('no "L" found ', 12); end; writestring(str, len); endline end else begin if firsterror { first error on this line } then begin convertnumber(str, len, linenumber, 4, numeric); wr5('. ', 2); for x1 := 1 to inlength do str[len + x1] := inline[x1]; len := len + inlength; writestring(str, len); endline; firsterror := false; str[1].nbl := 0; len := 6 end; case n div 100 of 0: ; 1: wr10('margin ', 6); 2: wr10('option ', 6); 3: wr10('paragraph ', 9); 4: wr5('form ', 4); 5: wr10('select ', 6); 6: wr10('sortindex ', 9); 7: wr5('count', 5); 8: wr10('indent ', 6); 9: wr5('skip ', 4); 10: wr10('output ', 6); 11: wr5('input', 5); 12: wr5('reset', 5); end; wr10(' error: ', 8); wr10(' error: ', 8); n := n mod 100; if n < 50 then case n of 1: begin len := len + 1; with str[len] do begin c := error1; nbl := charwidth end end; 2: wr10('missing ) ', 9); 3: wr20('unmatched quote ', 15); 4: wr20('pagenumber too large', 20); 5: begin wr20('undefined keep buffe', 20); wr5('r ', 1) end; 6: begin wr20('unknown directive: ', 19); for x1 := 1 to 10 do begin len := len + 1; with str[len] do begin c := error10[x1]; nbl := charwidth end end end; 7: wr20('bad numeric form ', 16); 8: begin wr20('hyphenation needed: ', 20); for x1 := 1 to wordlength do if len < maxstringlength then begin len := len + 1; str[len] := word[x1] end end; 9: wr20('bad terminal type ', 17); 10: begin wr20('must be in initial d', 20); wr20('irective group ', 14) end; 11: begin wr20('"except" must be fir', 20); wr5('st ', 2) end; 12: begin wr20('directive not allowe', 20); wr5('d: ', 3); for x1 := 1 to 10 do begin len := len + 1; with str[len] do begin c := error10[x1]; nbl := charwidth end end end; 13: begin wr20('aj pitch must be 10 ', 20); wr5('or 12', 5) end; end else begin case n of 51: wr5('keep ', 4); 52: wr20('right margin ', 12); 53: wr20('left margin ', 11); 54: wr5('width', 5); 55: wr10('indent ', 6); 56: wr20('number width ', 12); 57: wr5('skip ', 4); 58: wr10('left width', 10); 59: wr10('margin ', 6); 60: wr20('page column ', 11); 61: wr20('right width ', 11); 62: wr20('sort column ', 11); 64: wr5('shift', 5); 65: wr20('justification limit ', 19); 66: wr10('spacing ', 7); end; wr5(' of ', 4); if errorn1 < 0 then begin wr5('- ', 1); errorn1 := - errorn1 end; convertnumber(str, len, errorn1, 0, numeric); wr10(' is too ', 8); if errorsmall then wr5('small', 5) else wr5('large', 5); wr5(', ', 2); convertnumber(str, len, errorn2, 0, numeric); wr5(' used', 5) end; writestring(str, len); endline end end end { error } ; { validate numeric option. * * param num = number to test. * min = minimum allowed value. * max = maximum allowed value. * err = error number if not in range. } procedure validate { var num : integer; min,max,err : integer } ; begin { validate } errorn1 := num; errorsmall := num < min; if errorsmall then begin num := min; errorn2 := num; error(err) end else if num > max then begin num := max; errorn2 := num; error(err) end end { validate } ; { --------------------------------------------- } { } { secondary initialization } { } { } { --------------------------------------------- } { reinitialize - re-initialize global variables. } procedure reinitialize; var d: direct; { directive loop index } x1: integer; { loop index } { initform - initialize default form. } procedure initform; var default: packed array [1..40] of char; { default form } x1: integer; { loop index } begin { initform } default := '[//T#62E///L54///#33"- "PN:1" -"////] '; for x1 := 1 to 40 do form[x1] := asciichar(default[x1]); formlength := 40; formnlength := 0; formindex := 1; textlength := 1; textindex := 1; texts[1].c := blank; texts[1].nbl := 0; end { initform } ; { initinp - initialize input settings. } procedure initinp; var x1: integer; { loop index } begin { initinp } lowercase := true; lowerdir := true; underdir := false; underlining := false; keepinp := 0; explicitblank := nul; casech := nul; dirch := period; hyphen := nul; underchar := nul; inwidth := 150; for x1 := 0 to maxkeep do saveinp[x1].defined := false; inpsave end { initinp } ; { initinx - initialize inx variables. } procedure initinx; var ip: pinxentry; { to dispose index entries } begin { initinx } while inxbase <> nil do begin ip := inxbase; inxbase := inxbase^.next; dispose(ip) end; inxlast := nil end { initinx } ; { initmar - initialize margin settings. } procedure initmar; var x1: integer; { loop index } begin { initmar } keepmar := 0; leftmargin := 0; rightmargin := 70; for x1 := 0 to maxkeep do savemar[x1].defined := false; nchars := 0; outline[1].nbl := 0; marsave end { initmar } ; { initopt - initialize option settings. } procedure initopt; var x1: integer; { loop index } begin { initopt } keepopt := 0; printerrors := true; fill := true; badjustify := 1; leftjustify := true; multipleblanks := true; ensure2 := true; rightjustify := true; space := 0; shiftup := false; for x1 := 0 to maxkeep do saveopt[x1].defined := false; optsave end { initopt } ; { initout- initialize output settings. } procedure initout; begin { initout } blankcount := 0; blankline := false; linecount := - 1; terminaltype := lpt; charwidth := 1; eject := false; pause := false; shift := 0; underavail := true; outwidth := maxowidth end { initout } ; { initpar - initialize paragraph settings. } procedure initpar; var x1: integer; { loop index } begin { initpar } keeppar := 0; paracount := 0; parachar := nul; lockeddent := 0; numbering := nonumbering; parapage := 0; paraskip := 0; numberwidth := 3; for x1 := 0 to maxkeep do savepar[x1].defined := false; parsave end { initpar } ; begin { reinitialize } for d := bre to ill do if d in which then case d of bre: ; com: ; cou: pagenumber := 1; frm: initform; ind: ; inp: initinp; inx: initinx; lit: ; mar: initmar; opt: initopt; out: initout; pag: ; par: initpar; res: ; sel: for x1 := 0 to maxpage do selection[x1] := true; ski: ; sor: ; sbt: titlelength[subtitle] := 0; ttl: titlelength[maintitle] := 0; und: ; weo: ; exc: ; ill: end end { reinitialize } ; { --------------------------------------------- } { } { primary initialization } { } { } { --------------------------------------------- } { initialize - initialize global variables. } procedure initialize; var exists: boolean; {dummy argument} { initclass - initialize the classification table. } procedure initclass; var ch: ascii; { index variable } empty: charclass; { all fields are false } begin { initclass } with empty do begin letter := false; digit := false; formchar := false; optionchar := false; outputchar := false; marginchar := false; paragraphchar := false; sortinxchar := false; plusorminus := false; quote := false; numform := false; end; for ch := nul to del do class[ch] := empty; for ch := a to z do class[ch].letter := true; for ch := smalla to smallz do class[ch].letter := true; for ch := zero to nine do class[ch].digit := true; class[c].formchar := true; class[d].formchar := true; class[e].formchar := true; class[l].formchar := true; class[p].formchar := true; class[s].formchar := true; class[t].formchar := true; class[w].formchar := true; class[hash].formchar := true; class[lbracket].formchar := true; class[rbracket].formchar := true; class[slash].formchar := true; class[dquote].formchar := true; class[squote].formchar := true; class[blank].formchar := true; class[b].inputchar := true; class[c].inputchar := true; class[d].inputchar := true; class[h].inputchar := true; class[k].inputchar := true; class[u].inputchar := true; class[w].inputchar := true; class[blank].inputchar := true; class[k].marginchar := true; class[l].marginchar := true; class[r].marginchar := true; class[blank].marginchar := true; class[e].optionchar := true; class[f].optionchar := true; class[j].optionchar := true; class[k].optionchar := true; class[l].optionchar := true; class[m].optionchar := true; class[p].optionchar := true; class[r].optionchar := true; class[s].optionchar := true; class[u].optionchar := true; class[w].optionchar := true; class[blank].optionchar := true; class[blank].optionchar := true; class[e].outputchar := true; class[p].outputchar := true; class[s].outputchar := true; class[u].outputchar := true; class[w].outputchar := true; class[blank].outputchar := true; class[c].paragraphchar := true; class[f].paragraphchar := true; class[i].paragraphchar := true; class[k].paragraphchar := true; class[n].paragraphchar := true; class[p].paragraphchar := true; class[s].paragraphchar := true; class[u].paragraphchar := true; class[blank].paragraphchar := true; class[l].sortinxchar := true; class[m].sortinxchar := true; class[p].sortinxchar := true; class[r].sortinxchar := true; class[s].sortinxchar := true; class[blank].sortinxchar := true; class[plus].plusorminus := true; class[minus].plusorminus := true; class[dquote].quote := true; class[squote].quote := true; class[n].numform := true; class[smalln].numform := true; class[l].numform := true; class[smalll].numform := true; class[r].numform := true; class[smallr].numform := true; class[blank].numform := true; end { initclass } ; { initclocks - initialize rawclock and wallclock. } procedure initclocks; var c1: ascii; { tens digit of wallclock } c2: ascii; { ones digit of wallclock } c3: ascii; { a or p for am or pm } systemclock: alfa; { system clock as 'hh:mm:ss' } x1: integer; { general loop index } procedure gettime(var t: alfa); begin timestamp(day, month, year, hrs, mins, secs); t[1] := chr(hrs div 10 + ord('0')); t[2] := chr(hrs mod 10 + ord('0')); t[3] := '.'; t[4] := chr(mins div 10 + ord('0')); t[5] := chr(mins mod 10 + ord('0')); t[6] := '.'; t[7] := chr(secs div 10 + ord('0')); t[8] := chr(secs mod 10 + ord('0')); end; {gettime} begin { initclocks } gettime(systemclock); for x1 := 1 to 8 do rawclock[x1] := ord(systemclock[x1]); rawclock[9] := blank; rawclock[10] := blank; c1 := rawclock[1]; c2 := rawclock[2]; c3 := a; case c1 of zero: if c2 = zero then begin c1 := one; c2 := two end else c1 := blank; one: if c2 = two then c3 := p else if c2 > two then begin c1 := blank; c2 := c2 - 2; c3 := p end; two: begin if c2 <= one then begin c1 := blank; c2 := c2 - 2 end else begin c1 := one; c2 := c2 + 2 end; c3 := p end end; wallclock[1] := c1; wallclock[2] := c2; wallclock[3] := colon; wallclock[4] := rawclock[4]; wallclock[5] := rawclock[5]; wallclock[6] := blank; wallclock[7] := c3; wallclock[8] := m; wallclock[9] := blank; wallclock[10] := blank; end { initclocks } ; { initdates - initialize rawdate and nicedate. } procedure initdates; var thismonth: ch3; { current month name } systemdate: alfa; { system date as 'yy/mm/dd' } x1: integer; { general loop index } procedure date(var dt: alfa); {*pdp11*} begin {Return date in format 'yy/mm/dd'} { assumes timestamp already called } dt[1] := chr(zero + (year div 10) mod 10); dt[2] := chr(zero + year mod 10); dt[3] := '/'; dt[4] := chr(zero + month div 10); dt[5] := chr(zero + month mod 10); dt[6] := '/'; dt[7] := chr(zero + day div 10); dt[8] := chr(zero + day mod 10); end; {date} begin { initdates } date(systemdate); for x1 := 1 to 8 do rawdate[x1] := ord(systemdate[x1]); rawdate[9] := blank; rawdate[10] := blank; thismonth := months[(rawdate[4] - zero) * 10 + rawdate[5] - zero]; nicedate[1] := rawdate[7]; nicedate[2] := rawdate[8]; nicedate[3] := blank; nicedate[4] := thismonth[1]; nicedate[5] := thismonth[2]; nicedate[6] := thismonth[3]; nicedate[7] := blank; nicedate[8] := rawdate[1]; nicedate[9] := rawdate[2]; nicedate[10] := blank end { initdates } ; { initdirects - initialize the directs table. } procedure initdirects; { onedirect - initialize one direct entry. * * param dir = directive. a,b,c = 3 characters of directive name. } procedure onedirect(dir: direct; a, b, c: ascii); begin { onedirect } directs[dir][1] := a; directs[dir][2] := b; directs[dir][3] := c end { onedirect } ; begin { initdirects } onedirect(bre, b, r, e); onedirect(com, c, o, m); onedirect(cou, c, o, u); onedirect(frm, f, o, r); onedirect(ind, i, n, d); onedirect(inp, i, n, p); onedirect(inx, i, n, x); onedirect(lit, l, i, t); onedirect(mar, m, a, r); onedirect(opt, o, p, t); onedirect(out, o, u, t); onedirect(pag, p, a, g); onedirect(par, p, a, r); onedirect(res, r, e, s); onedirect(sel, s, e, l); onedirect(ski, s, k, i); onedirect(sor, s, o, r); onedirect(sbt, s, u, b); onedirect(ttl, t, i, t); onedirect(und, u, n, d); onedirect(weo, w, e, o); onedirect(exc, e, x, c); onedirect(ast, a, s, c); onedirect(lpt, l, p, t); onedirect(vtr, v, t, r); onedirect(xer, x, e, r); end { initdirects } ; { initmonths - initialize the months table. } procedure initmonths; { onemonth - initialize one month name. * * param mon : month number. * a,b,c : three letters of month name. } procedure onemonth(mon: integer; a, b, c: ascii); begin { onemonth } months[mon][1] := a; months[mon][2] := b; months[mon][3] := c end { onemonth } ; begin { initmonths } onemonth(1, j, smalla, smalln); onemonth(2, f, smalle, smallb); onemonth(3, m, smalla, smallr); onemonth(4, a, smallp, smallr); onemonth(5, m, smalla, smally); onemonth(6, j, smallu, smalln); onemonth(7, j, smallu, smalll); onemonth(8, a, smallu, smallg); onemonth(9, s, smalle, smallp); onemonth(10, o, smallc, smallt); onemonth(11, n, smallo, smallv); onemonth(12, d, smalle, smallc) end { initmonths } ; begin { initialize } initmonths; { before initdates } initclass; initclocks; { before initdates } initdates; initdirects; csi; getnextinput(exists); directline := false; endofinput := false; filecount := 0; eol := true; errors := false; gaps[0] := 1; inchar := blank; incolumn := 150; inlength := 0; inxbase := nil; inxlast := nil; linenumber := 0; linenums := infile^ in ['0'..'9']; moreonleft := false; nblanks := 0; nchars := 0; newinline := true; newoutline := true; newparagraph := true; ngaps := 0; nwords := 0; outlength := 1; outline[1].c := blank; outline[1].nbl := 0; reinitialize([bre..ill]); end { initialize } ; { --------------------------------------------- } { } { prose } { } { } { --------------------------------------------- } begin { prose } initialize; nextword; while not endofinput do begin packword; nextword end; break; if linecount < infinity then begin newpage(infinity); selection[pagenumber] := true; advanceform end; if errors then writeln(outfile, ' Prose errors detected.'); end { prose } .