home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / PASCAL / PT03.ZIP / FMT.AR < prev    next >
Encoding:
Text File  |  1983-09-02  |  35.4 KB  |  1,390 lines
  1. -h- break.fmt 321
  2. { break -- end current filled line }
  3. procedure lbreak;
  4. var
  5.    i : integer;
  6. begin
  7.  if (outp > 0) then begin
  8.   if outbuf[outp] <> BLANK then outp := outp + 1;
  9.   outbuf[outp] := NEWLINE;
  10.   outbuf[outp+1] := ENDSTR;
  11.   put(outbuf);
  12.   for i := 1 to BIGSTR do outbuf[i] := BLANK;
  13.  end;
  14.  outp := 0;
  15.  outw := 0;
  16.  outwds := 0
  17. end;
  18. -h- center.fmt 144
  19. { center -- center a line by setting tival }
  20. procedure center (var buf : sstring);
  21. begin
  22.  tival := imax((rmval+tival-width(buf)) div 2, 0)
  23. end;
  24. -h- command.fmt 2686
  25. { command -- perform formatting command }
  26. procedure command (var buf : sstring);
  27. var
  28.  cmd : cmdtype;
  29.  lin : string;
  30.  fd  : filedesc;
  31.  mptr: ndptr;
  32.  fvar: fonttype;
  33.  i, j, argtype, spval, val, sfval, hdlvl: integer;
  34. begin
  35.  cmd := getcmd(buf);
  36.  if (cmd <> UNKNOWN) then
  37.   val := getval(buf, argtype);
  38.  case cmd of
  39.  FI: begin
  40.   lbreak;
  41.   fill := true
  42.   end;
  43.  NF: begin
  44.   lbreak;
  45.   fill := false
  46.   end;
  47.  JU: begin
  48.   lbreak;
  49.   just := true
  50.   end;
  51.  NJ: begin
  52.   lbreak;
  53.   just := false
  54.   end;
  55.  BR:
  56.   lbreak;
  57.  LS:
  58.   setparam(lsval, val, argtype, 1, 1, HUGE);
  59.  CE: begin
  60.   lbreak;
  61.   setparam(ceval, val, argtype, 1, 0, HUGE)
  62.   end;
  63.  UL:
  64.   setparam(ulval, val, argtype, 1, 0, HUGE);
  65.  HE: begin
  66.   gettl(buf, header);
  67.   hefont := font;
  68.   end;
  69.  FO: begin
  70.   gettl(buf, footer);
  71.   fofont := font;
  72.   end;
  73.  BP: begin
  74.   page;
  75.   setparam(curpage,val,argtype,curpage+1,-HUGE,HUGE);
  76.   newpage := curpage
  77.   end;
  78.  SP: begin
  79.   setparam(spval, val, argtype, 1, 0, HUGE);
  80.   space(spval)
  81.   end;
  82.  IND:
  83.   setparam(inval, val, argtype, 0, 0, rmval-1);
  84.  RM:
  85.   setparam(rmval, val, argtype, PAGEWIDTH,
  86.     inval+tival+1, HUGE);
  87.  TI: begin
  88.   lbreak;
  89.   setparam(tival, val, argtype, 0, -HUGE, rmval)
  90.   end;
  91.  PL: begin
  92.   setparam(plval, val, argtype, PAGELEN,
  93.     m1val+m2val+m3val+m4val+1, HUGE);
  94.   bottom := plval - m3val - m4val
  95.   end;
  96.  SF: begin
  97.   setparam(sfval, val, argtype, SFNORM, SFNORM, SFUND);
  98.   if sfval = SFNORM then
  99.    font := [SFNORM]  {reset current font flag}
  100.   else begin
  101.    fvar := font;
  102.    font := [sfval];
  103.    font := fvar + font;  {add new value to set}
  104.   end;
  105.   setfont(font,1);
  106.   end;
  107.  SX: begin
  108.   lbreak;
  109.   gettl(buf,lin);
  110.   put(lin);
  111.   end;
  112.  DM: begin
  113.   defmac(buf);
  114.   end;
  115.  HD: begin
  116.   lbreak;
  117.   setparam(hdlvl, val, argtype, -1, 0, 4);
  118.   if (hdlvl = -1) then
  119.    errmsg('Invalid .hd level ignored')
  120.   else
  121.    puthd(buf,hdlvl);
  122.   end;
  123.  CP: begin
  124.   lbreak;
  125.   spval := 0;
  126.   setparam(spval, val, argtype, 0, 0, HUGE);
  127.   if ((bottom+1-lineno) < spval) then begin;
  128.    page;
  129.    curpage := curpage + 1;
  130.    newpage := curpage;
  131.    end;
  132.   end;
  133.  IM: begin
  134.   if inmac then
  135.    errmsg('Sorry, cannot use .im in a macro')
  136.   else begin
  137.    i := 1;
  138.    while (not (buf[i] in [BLANK,TAB])) do i := i + 1;    {skip over .command}
  139.    while (    (buf[i] in [BLANK,TAB])) do i := i + 1;
  140.    j := 1;
  141.    while (not (buf[i] in [BLANK,TAB,NEWLINE,ENDSTR])) do begin
  142.     lin[j] := buf[i];
  143.     i := i + 1;
  144.     j := j + 1;
  145.    end;
  146.    lin[j] := ENDSTR;
  147.    fd := mustopen(lin, IOREAD);
  148.    imbed(fd,lin);
  149.    xclose(fd);
  150.   end;
  151.   end;
  152.  COMMENT: ;
  153.  UNKNOWN: begin
  154.   scopy(buf,2,buf,1); {shift off the leading '.'}
  155.   mptr := macloc(buf);
  156.   if mptr <> NIL then
  157.    maccall(mptr,buf)
  158.   else
  159.    errmsg('Unknown command.');
  160.   end;
  161.  end
  162. end;
  163. -h- defmac.fmt 1462
  164. { defmac -- put macro definition into ndblock linked list }
  165. procedure defmac (var buf : sstring);
  166. var
  167.  i,j : integer;
  168.  mnam : smlstring; {macro name}
  169.  mdel : character; {delimiter character}
  170.  mptr,cptr : ndptr;
  171. begin
  172.   i := 1;
  173.   while (not (buf[i] in [BLANK,TAB])) do i := i + 1;   {skip over .command}
  174.   while (    (buf[i] in [BLANK,TAB])) do i := i + 1;
  175.   if not (isletter(buf[i])) then begin
  176.    errmsg('Invalid macro name');
  177.    return;
  178.   end;
  179.   j := 1;
  180.   while (isalphanum(buf[i])) do begin
  181.    if isupper(buf[i]) then
  182.     mnam[j] := buf[i] + 32
  183.    else
  184.     mnam[j] := buf[i];
  185.    i := i + 1;
  186.    j := j + 1;
  187.   end;
  188.   mnam[j] := ENDSTR;
  189.   while (buf[i] in [BLANK,TAB]) do i := i + 1;
  190.   if (buf[i] in [NEWLINE,ENDSTR]) then begin
  191.    errmsg('Invalid macro definition');
  192.    return;
  193.   end;
  194.   mdel := buf[i];
  195.   mptr := macloc(mnam);
  196.   { if name already exists, just replace it, otherwise create new defn }
  197.   if mptr = NIL then begin
  198.    mptr := mactop;
  199.    while (mptr <> NIL) do begin
  200.     cptr := mptr;
  201.     mptr := cptr^.next;
  202.    end;
  203.    new(mptr);
  204.    if mactop = NIL then
  205.     mactop := mptr
  206.    else
  207.     cptr^.next := mptr;
  208.    mptr^.next := NIL;
  209.   end;
  210.   scopy(mnam,1,mptr^.name,1);
  211.   j := 1;
  212.   while (not (buf[i] in [NEWLINE,ENDSTR])) do begin
  213.    mptr^.defn[j] := buf[i];
  214.    i := i + 1;
  215.    j := j + 1;
  216.   end;
  217.   if mptr^.defn[j-1] <> mdel then begin {add delimiter to end if they forgot}
  218.    mptr^.defn[j] := mdel;
  219.    j := j + 1;
  220.   end;
  221.   mptr^.defn[j] := ENDSTR;
  222. end;
  223. -h- errmsg.fmt 650
  224. { errmsg  -- write error message and return }
  225. { note: string is not terminated by normal ENDSTR delimiter }
  226. procedure errmsg (const msg : lstring);
  227. var
  228.  i, nd : integer;
  229.  s : string;
  230. begin
  231.  putcf(LETF,STDERR);
  232.  putcf(LETI,STDERR);
  233.  putcf(LETL,STDERR);
  234.  putcf(LETE,STDERR);
  235.  putcf(BLANK,STDERR);
  236.  putstr(curname,STDERR);
  237.  putcf(BLANK,STDERR);
  238.  putcf(LETL,STDERR);
  239.  putcf(LETI,STDERR);
  240.  putcf(LETN,STDERR);
  241.  putcf(LETE,STDERR);
  242.  putcf(BLANK,STDERR);
  243.  nd := itoc(inline, s, 1);
  244.  for i := 1 to nd-1 do
  245.   putcf(s[i],STDERR);
  246.  putcf(COLON,STDERR);
  247.  putcf(BLANK,STDERR);
  248.  for i := 1 to ord(msg[0]) do putcf(ord(msg[i]),STDERR);
  249.  putcf(NEWLINE,STDERR);
  250. end;
  251. -h- fmtcons.fmt 607
  252. { fmtcons -- constants for format }
  253. const
  254.  CMD = PERIOD;
  255.  PAGENUM = SHARP;
  256.  PAGEWIDTH = 60;
  257.  PAGELEN = 66;
  258.  HUGE = 10000;
  259.  SFNORM = 0;  { Valid arguments to the 'setfont' command }
  260.  SFDBLS = 1;
  261.  SFEMP    = 2;
  262.  SFITAL = 3;
  263.  SFDBLW = 4;
  264.  SFCOMP = 5;
  265.  SFUND    = 6;
  266.  L0SBF    = 3;  { Spaces before and after a level 0 header }
  267.  L0SAF    = 1;
  268.  L1SBF    = 3;  { Spaces before and after a level 1 header }
  269.  L1SAF    = 1;
  270.  L2SBF    = 3;  { Spaces before and after a level 2 header }
  271.  L2SAF    = 1;
  272.  L3SBF    = 3;  { Spaces before and after a level 3 header }
  273.  L3SAF    = 1;
  274.  L4SBF    = 3;  { Spaces before and after a level 4 header }
  275.  L4SAF    = 1;
  276. -h- fmtproc.fmt 912
  277. { fmtproc -- procedures needed for format }
  278. {$include:'errmsg.fmt'  }
  279. {$include:'skipbl.fmt'  }
  280. {$include:'skip.fmt'    }
  281. {$include:'getcmd.fmt'  }
  282. {$include:'setparam.fmt'}
  283. {$include:'getval.fmt'  }
  284. {$include:'gettl.fmt'   }
  285. {$include:'puttl.fmt'   }
  286. {$include:'setfont.fmt' }
  287. {$include:'puthead.fmt' }
  288. {$include:'putfoot.fmt' }
  289. {$include:'width.fmt'   }
  290. {$include:'put.fmt'     }
  291. {$include:'break.fmt'   }
  292. {$include:'space.fmt'   }
  293. {$include:'page.fmt'    }
  294. {$include:'puthd.fmt'   }
  295. {$include:'leadbl.fmt'  }
  296. {$include:'spread.fmt'  }
  297. {$include:'putword.fmt' }
  298. {$include:'getword.fmt' }
  299. {$include:'center.fmt'  }
  300. {$include:'underln.fmt' }
  301. {$include:'initfmt.fmt' }
  302. {$include:'macloc.fmt'  }
  303. {$include:'defmac.fmt'  }
  304. {$include:'maccall.fmt' }
  305. {$include:'getfmtl.fmt' }
  306. procedure imbed (fd : filedesc; var name : sstring); forward;
  307. {$include:'command.fmt' }
  308. {$include:'text.fmt'    }
  309. {$include:'imbed.fmt'   }
  310. -h- fmttype.fmt 363
  311. type
  312.  cmdtype = (BP, BR, CE, FI, FO, HE, IND, LS, NF, PL,
  313.     RM, SP, TI, UL, SF, HD, SX, IM, DM, CP, NJ, JU, UNKNOWN, COMMENT);
  314.  fonttype = set of SFNORM..SFUND;
  315.  fontrang = SFNORM..SFUND;
  316.  ndptr = ^ndblock;
  317.  ndblock =
  318.     record    { macro definition block }
  319.     name : smlstring;   { name of macro }
  320.     defn : bigstring;   { body of macro }
  321.     next : ndptr;
  322.     end;
  323. -h- fmtvars.fmt 2404
  324. var
  325.  { page parameters }
  326.  curpage : integer; { current output page number; init = 0 }
  327.  newpage : integer; { next output page number; init = 1 }
  328.  lineno : integer; { next line to be printed; init = 0 }
  329.  plval : integer; { page length in lines; init = PAGELEN = 66 }
  330.  m1val : integer; { margin before and including header }
  331.  m2val : integer; { margin after header }
  332.  m3val : integer; { margin after last text line }
  333.  m4val : integer; { bottom margin, including footer }
  334.  bottom : integer; { last live line on page, = plval-m3val-m4val }
  335.  header : string; { top of page title; init = NEWLINE }
  336.  footer : string; { bottom of page title; init = NEWLINE }
  337.  font : fonttype; { current font settings }
  338.  hefont : fonttype;   { current header font settings }
  339.  fofont : fonttype;   { current footer font settings }
  340.  
  341.  { global parameters }
  342.  fill : boolean;  { fill if true; init = true }
  343.  just : boolean;  { right justify if true; init = true }
  344.  lsval : integer; { current line spacing; init = 1 }
  345.  spval : integer; { next space }
  346.  inval : integer; { current indent; >= 0; init = 0 }
  347.  rmval : integer; { current right margin; init = PAGEWIDTH = 60 }
  348.  tival : integer; { current temporary indent; init = 0 }
  349.  ceval : integer; { number of lines to center; init = 0 }
  350.  ulval : integer; { number of lines to underline; init = 0 }
  351.  hdlvl1: integer; { value of current level 1 numbered heading }
  352.  hdlvl2: integer; { value of current level 2 numbered heading }
  353.  hdlvl3: integer; { value of current level 3 numbered heading }
  354.  hdlvl4: integer; { value of current level 4 numbered heading }
  355.  hidblank: character; { special character to hide blank from spreading }
  356.  
  357.  { output area }
  358.  outp : integer;  { last char position in outbuf; init = 0 }
  359.  outw : integer;  { width of text currently in outbuf; init = 0 }
  360.  outwds : integer; { number of words in outbuf; init = 0 }
  361.  outbuf : bigstring; { lines to be filled collect here }
  362.  
  363.  inline : integer; { current input file line number }
  364.  curname: string;  { current input file name }
  365.  inmac    : boolean; { flag tells if we are within a macro or not }
  366.  mactop : ndptr;   { pointer to top of macro definition linked list }
  367.  curmac : bigstring;  { current macro definition, if any }
  368.  curmacp: integer; { points to current position in current macro }
  369.  curmacd: character; { delimiter character in current macro }
  370.  macarg: array[0..9] of string; {buffer for macro arguments }
  371.  dir : 0..1;
  372. -h- format.fmt 715
  373. { format -- text formatter main program }
  374. procedure format;
  375. {$include:'fmtcons.fmt'}
  376. {$include:'fmttype.fmt'}
  377. {$include:'fmtvars.fmt'}
  378.  iarg : integer;
  379.  argv : string;
  380.  infil: filedesc;
  381.  outpflag [extern] : outptype;
  382. {$include:'fmtproc.fmt'}
  383. begin
  384.  initfmt;
  385.  iarg := 0;
  386.  infil := STDIN;
  387.  while (iarg = 0) or (iarg < nargs) do begin
  388.   iarg := iarg + 1;
  389.   if (getarg(iarg,argv,MAXSTR)) then begin
  390.    if argv[1]=DASH then begin
  391.       case argv[2] of
  392.        LETP: outpflag := STDPRT;
  393.        otherwise
  394.      message ('Unknown control argument ignored.');
  395.        end;
  396.       cycle;
  397.       end;
  398.    infil := mustopen(argv,IOREAD)
  399.    end
  400.   else
  401.    scopy(curname,1,argv,1);
  402.   imbed(infil,argv);
  403.   xclose(infil);
  404.   page;
  405.  end;
  406. end;
  407. -h- getcmd.fmt 1436
  408. { getcmd -- decode command type }
  409. function getcmd (var buf : sstring) : cmdtype;
  410. var
  411.  cmd : packed array [1..2] of char;
  412. begin
  413.  if (isupper(buf[2]))
  414.   then cmd[1] := chr(buf[2] + 32)
  415.   else cmd[1] := chr(buf[2]);
  416.  if (isupper(buf[3]))
  417.   then cmd[2] := chr(buf[3] + 32)
  418.   else cmd[2] := chr(buf[3]);
  419.  if (cmd[1] = '*') then
  420.   getcmd := COMMENT
  421.  else if isalphanum(buf[4]) then { character after 2 letters is alphanum }
  422.                  { then probably a macro invokation     }
  423.   getcmd := UNKNOWN
  424.  else if (cmd = 'fi') then
  425.   getcmd := FI
  426.  else if (cmd = 'nf') then
  427.   getcmd := NF
  428.  else if (cmd = 'br') then
  429.   getcmd := BR
  430.  else if (cmd = 'ls') then
  431.   getcmd := LS
  432.  else if (cmd = 'bp') then
  433.   getcmd := BP
  434.  else if (cmd = 'sp') then
  435.   getcmd := SP
  436.  else if (cmd = 'in') then
  437.   getcmd := IND
  438.  else if (cmd = 'rm') then
  439.   getcmd := RM
  440.  else if (cmd = 'ti') then
  441.   getcmd := TI
  442.  else if (cmd = 'ce') then
  443.   getcmd := CE
  444.  else if (cmd = 'ul') then
  445.   getcmd := UL
  446.  else if (cmd = 'he') then
  447.   getcmd := HE
  448.  else if (cmd = 'fo') then
  449.   getcmd := FO
  450.  else if (cmd = 'pl') then
  451.   getcmd := PL
  452.  else if (cmd = 'hd') then
  453.   getcmd := HD
  454.  else if (cmd = 'sf') then
  455.   getcmd := SF
  456.  else if (cmd = 'sx') then
  457.   getcmd := SX
  458.  else if (cmd = 'im') then
  459.   getcmd := IM
  460.  else if (cmd = 'cp') then
  461.   getcmd := CP
  462.  else if (cmd = 'dm') then
  463.   getcmd := DM
  464.  else if (cmd = 'ju') then
  465.   getcmd := JU
  466. else if (cmd = 'nj') then
  467.   getcmd := NJ
  468.  else
  469.   getcmd := UNKNOWN
  470. end;
  471. -h- getfmtl.fmt 1232
  472. { getfmtl -- get next format line, either from macro or current file }
  473. function getfmtl(var s : sstring; fd : filedesc; maxsize : integer): boolean;
  474. var
  475.  i,j : integer;
  476.  n : integer;
  477. begin
  478.  if (inmac) and (curmac[curmacp] <> ENDSTR) then begin
  479.   i := 1;
  480.   { curmacp points to beginning of next command string }
  481.   while (curmac[curmacp] <> curmacd) do begin
  482.    if (curmac[curmacp] = PERCENT) then begin  {expand argument}
  483.     curmacp := curmacp + 1;
  484.     if (curmac[curmacp] = PERCENT) then s[i] := curmac[curmacp]
  485.     else
  486.      if not (isdigit(curmac[curmacp])) then
  487.       errmsg('Invalid argument digit')
  488.      else begin
  489.       n := ord(curmac[curmacp]) - 48; {very ASCII dependent}
  490.       j := 1;
  491.       while (macarg[n,j] <> ENDSTR) do begin
  492.        s[i] := macarg[n,j];
  493.        i := i + 1;
  494.        j := j + 1;
  495.       end;
  496.       i := i - 1; {went one too far}
  497.      end;
  498.    end
  499.    else {normal character}
  500.     s[i] := curmac[curmacp];
  501.    i := i + 1;
  502.    curmacp := curmacp + 1;
  503.   end;
  504.   curmacp := curmacp + 1; {advance past delimiter}
  505.   s[i] := NEWLINE;
  506.   s[i+1] := ENDSTR;
  507.   if (i >= maxsize) then error('macro expand overflow');
  508.  end
  509.  else begin
  510.   inmac := FALSE;
  511.   getfmtl := getline(s, fd, maxsize);
  512.   inline := inline + 1;
  513.  end;
  514. end;
  515. -h- gettl.fmt 1514
  516. { gettl -- create line with text adjusted /left/middle/right/ }
  517. procedure gettl (var buf,lin : sstring);
  518. label err;
  519. var
  520.  i,j,k : integer;
  521.  delim : character;  {delimiter, normally /}
  522. begin
  523.   i := 1;
  524.   while (not (buf[i] in [BLANK,TAB])) do i := i + 1;   {skip over .command}
  525.   while (    (buf[i] in [BLANK,TAB])) do i := i + 1;
  526.   delim := buf[i];
  527.   for j := 1 to rmval do lin[j] := BLANK;  {init lin to blanks}
  528.   lin[rmval+1] := NEWLINE;
  529.   lin[rmval+2] := ENDSTR;
  530.   i := i + 1;
  531.   j := 1;
  532.   while (buf[i] <> delim) do begin       {move left portion}
  533.    if (buf[i] = NEWLINE) or (j > rmval) then goto err;
  534.    lin[j] := buf[i];
  535.    i := i + 1;
  536.    j := j + 1;
  537.   end;
  538.   i := i + 1;
  539.   j := i;
  540.   while (buf[j] <> delim) do begin       {get length of middle}
  541.    if (buf[j] = NEWLINE) then goto err;
  542.    j := j + 1;
  543.   end;
  544.   k := j - i;
  545.   j := imax((rmval-k) div 2, 0);
  546.   while (buf[i] <> delim) do begin       {move middle portion}
  547.    if (buf[i] = NEWLINE) or (j > rmval) then goto err;
  548.    lin[j] := buf[i];
  549.    i := i + 1;
  550.    j := j + 1;
  551.   end;
  552.   i := i + 1;
  553.   while (buf[i] <> delim) do begin       {find end of buf}
  554.    if (buf[i] = NEWLINE) then goto err;
  555.    i := i + 1;
  556.   end;
  557.   i := i - 1;
  558.   j := rmval;
  559.   while (buf[i] <> delim) do begin       {move right portion}
  560.    lin[j] := buf[i];
  561.    i := i - 1;
  562.    j := j - 1;
  563.   end;
  564.   i := 1; { remove any hidden blank characters }
  565.   while (buf[i] <> ENDSTR) do begin
  566.    if (buf[i] = hidblank) then buf[i] := BLANK;
  567.    i := i + 1;
  568.   end;
  569.  return;
  570.  
  571.  err: errmsg('Invalid /l/m/r/ syntax.');
  572. end;
  573. -h- getval.fmt 390
  574. { getval -- evaluate optional numeric argument }
  575. function getval (var buf : sstring;
  576.   var argtype : integer) : integer;
  577. var
  578.  i : integer;
  579. begin
  580.  i := 1; { skip over command name }
  581.  while (not (buf[i] in [BLANK, TAB, NEWLINE])) do
  582.   i := i + 1;
  583.  skipbl(buf, i); { find argument }
  584.  argtype := buf[i];
  585.  if (argtype = PLUS) or (argtype = MINUS) then
  586.   i := i + 1;
  587.  getval := ctoi(buf, i)
  588. end;
  589. -h- getword.fmt 408
  590. { getword -- get word from s[i] into out }
  591. function getword (var s : sstring; i : integer;
  592.    var out : sstring) : integer;
  593. var
  594.  j : integer;
  595. begin
  596.  while (s[i] in [BLANK, TAB, NEWLINE]) do
  597.   i := i + 1;
  598.  j := 1;
  599.  while (not (s[i] in [ENDSTR,BLANK,TAB,NEWLINE])) do begin
  600.   out[j] := s[i];
  601.   i := i + 1;
  602.   j := j + 1
  603.  end;
  604.  out[j] := ENDSTR;
  605.  if (s[i] = ENDSTR) then
  606.   getword := 0
  607.  else
  608.   getword := i
  609. end;
  610. -h- imbed.fmt 722
  611. { imbed -- format given file }
  612. { had to comment out arguments since it is forward declared }
  613. { because it is called recursively }
  614. procedure imbed { (fd : filedesc; var name : sstring) };
  615. var
  616.  inbuf : bigstring;  { input line }
  617.  oname : smlstring;  { previous filename, saved and restored on return }
  618.  oline : integer;    { previous line number }
  619. begin
  620.   scopy (curname,1,oname,1); {save current name}
  621.   scopy (name,1,curname,1);  {put into global for error messages}
  622.   oline := inline;
  623.   inline := 0;
  624.   while (getfmtl(inbuf, fd, BIGSTR)) do begin
  625.    if (inbuf[1] = CMD) then
  626.     command(inbuf)
  627.    else
  628.     text(inbuf);
  629.   end;
  630.   scopy (oname,1,curname,1); {restore old name}
  631.   inline := oline;         {and line number }
  632. end;
  633. -h- initfmt.fmt 883
  634. { initfmt -- set format parameters to default values }
  635. procedure initfmt;
  636. begin
  637.  inline := 0;
  638.  curname[1] := ord('S');
  639.  curname[2] := ord('T');
  640.  curname[3] := ord('D');
  641.  curname[4] := ord('I');
  642.  curname[5] := ord('N');
  643.  curname[6] := ENDSTR;
  644.  inmac    := FALSE;
  645.  mactop := NIL;
  646.  curmacp := 1;
  647.  font := [SFNORM]; setfont(font,0);
  648.  hidblank := ATSIGN;
  649.  fill := true;
  650.  just := true;
  651.  dir := 0;
  652.  inval := 0;
  653.  rmval := PAGEWIDTH;
  654.  tival := 0;
  655.  lsval := 1;
  656.  spval := 0;
  657.  ceval := 0;
  658.  ulval := 0;
  659.  lineno := 0;
  660.  curpage := 0;
  661.  newpage := 1;
  662.  plval := PAGELEN;
  663.  m1val := 3; m2val := 2; m3val := 2; m4val := 3;
  664.  bottom := plval - m3val - m4val;
  665.  header[1] := NEWLINE; { initial titles }
  666.  header[2] := ENDSTR;
  667.  hefont := [SFNORM];
  668.  footer[1] := NEWLINE;
  669.  footer[2] := ENDSTR;
  670.  fofont := [SFNORM];
  671.  outp := 0;
  672.  outw := 0;
  673.  outwds := 0;
  674.  hdlvl1 := 0;
  675.  hdlvl2 := 0;
  676.  hdlvl3 := 0;
  677.  hdlvl4 := 0;
  678. end;
  679. -h- leadbl.fmt 331
  680. { leadbl -- delete leading blanks, set tival }
  681. procedure leadbl (var buf : sstring);
  682. var
  683.  i, j : integer;
  684. begin
  685.  lbreak;
  686.  i := 1;
  687.  while (buf[i] = BLANK) do { find 1st non-blank }
  688.   i := i + 1;
  689.  if (buf[i] <> NEWLINE) then
  690.   tival := tival + i - 1;
  691.  for j := i to length(buf)+1 do { move line to left }
  692.   buf[j-i+1] := buf[j]
  693. end;
  694. -h- maccall.fmt 1498
  695. { maccall -- call the given macro }
  696. procedure maccall (mptr: ndptr; var cbuf : sstring);
  697. var
  698.  i,j,k : integer;
  699.  inarg : boolean;
  700.  c : character;
  701. begin
  702.   if inmac then begin
  703.    errmsg('Sorry, cannot nest macro calls');
  704.    return;
  705.   end;
  706.   inmac := TRUE;
  707.   scopy(mptr^.defn,1,curmac,1);
  708.   curmacd := curmac[1];
  709.   curmacp := 2;
  710.   for i := 1 to 9 do macarg[i,1] := ENDSTR;  {init arguments}
  711.   k := 1; {current pos in cbuf}
  712.   j := 0; {current pos in current argument}
  713.   i := 0; {current arg number}
  714.   inarg := FALSE;
  715.   while (cbuf[k] <> ENDSTR) do begin
  716.    c := cbuf[k];
  717.    case c of
  718.    BLANK,TAB,ENDSTR,NEWLINE: begin
  719.     if inarg then begin
  720.      j := j + 1;
  721.      macarg[i,j] := ENDSTR;
  722.      i := i + 1;
  723.      if i > 9 then return;
  724.     end;
  725.     j := 0;
  726.     inarg := FALSE;
  727.     if cbuf[k] in [ENDSTR,NEWLINE] then return;
  728.    end;
  729.   BACKSLASH: begin  {just pass following char without interpreting it}
  730.    k := k + 1;
  731.    if not (cbuf[k] in [ENDSTR,NEWLINE]) then begin
  732.     j := j + 1;
  733.     macarg[i,j] := cbuf[k];
  734.    end
  735.    else k := k - 1;
  736.    inarg := TRUE;
  737.    end;
  738.   SQUOTE,DQUOTE: begin {whole string of stuff is escaped}
  739.    k := k + 1;
  740.    while (cbuf[k] <> c) do begin
  741.     if (cbuf[k] in [ENDSTR,NEWLINE]) then break;
  742.     j := j + 1;
  743.     macarg[i,j] := cbuf[k];
  744.     k := k + 1;
  745.    end;
  746.    if cbuf[k] <> c then k := k - 1; { oops, went one too far }
  747.    inarg := TRUE;
  748.    end;
  749.   OTHERWISE
  750.    inarg := TRUE;
  751.    j := j + 1;
  752.    macarg[i,j] := c;
  753.   end; {of case, that is}
  754.   k := k + 1;
  755.  end; {of while}
  756. end;
  757. -h- macloc.fmt 554
  758. { macloc -- locate macro name in ndblock linked list }
  759. function macloc (var buf : sstring): ndptr;
  760. var
  761.  i,j : integer;
  762.  mnam : smlstring; {macro name}
  763.  mptr : ndptr;
  764. begin
  765.   i := 1;
  766.   j := 1;
  767.   while (isalphanum(buf[i])) do begin
  768.    if isupper(buf[i]) then
  769.     mnam[j] := buf[i] + 32
  770.    else
  771.     mnam[j] := buf[i];
  772.    i := i + 1;
  773.    j := j + 1;
  774.   end;
  775.   mnam[j] := ENDSTR;
  776.   mptr := mactop;
  777.   macloc := NIL;
  778.   while (mptr <> NIL) do begin
  779.    if equal(mptr^.name, mnam) then begin
  780.     macloc := mptr;
  781.     break;
  782.    end;
  783.    mptr := mptr^.next;
  784.   end;
  785. end;
  786. -h- page.fmt 176
  787. { page -- get to top of new page }
  788. procedure page;
  789. begin
  790.  lbreak;
  791.  if (lineno > 0) and (lineno <= bottom) then begin
  792.   skip(bottom+1-lineno);
  793.   putfoot
  794.  end;
  795.  lineno := 0
  796. end;
  797. -h- put.fmt 725
  798. { put -- put out line with proper spacing and indenting }
  799. procedure put (var buf : sstring);
  800. var
  801.  i : integer;
  802. begin
  803.  if (lineno <= 0) or (lineno > bottom) then
  804.   puthead;
  805.  for i := 1 to inval + tival do  { indenting }
  806.   putc(BLANK);
  807.  tival := 0;
  808.  { put out line. special cases 1) 255 is translated to 0 so we can write }
  809.  { NULL to the printer.  2) backslash is ignored. 3) ATSIGN = BLANK     }
  810.  i := 1;
  811.  while (buf[i] <> ENDSTR) do begin
  812.   case buf[i] of
  813.    BACKSLASH: begin
  814.     i := i + 1;
  815.     putc(buf[i]);
  816.     end;
  817.    ATSIGN: putc(BLANK);
  818.    255:    putc(0);
  819.    OTHERWISE
  820.     putc(buf[i]);
  821.   end;
  822.   i := i + 1;
  823.  end;
  824.  skip(imin(lsval-1, bottom-lineno));
  825.  lineno := lineno + lsval;
  826.  if (lineno > bottom) then
  827.   putfoot
  828. end;
  829. -h- putfoot.fmt 211
  830. { putfoot -- put out page footer }
  831. procedure putfoot;
  832. var
  833.  i : integer;
  834. begin
  835.  skip(m3val);
  836.  if (m4val > 0) then begin
  837.   setfont(fofont,0);
  838.   puttl(footer, curpage);
  839.   setfont(font,0);
  840.   skip(m4val-1)
  841.  end
  842. end;
  843. -h- puthd.fmt 2248
  844. { puthd -- output a level n numbered heading }
  845. procedure puthd (var buf : sstring; hdlvl : integer);
  846. var
  847.  hed : string;
  848.  fsave : fonttype;
  849.  i   : integer;
  850. begin
  851.   fsave := font;  { save font, then reset to header value, just in case }
  852.           { the space or put routines decide to reset the font. }
  853.   i := 1;
  854.   while (not (buf[i] in [BLANK,TAB])) do i := i + 1;        {skip over .hd n}
  855.   while (    (buf[i] in [BLANK,TAB])) do i := i + 1;
  856.   while (not (buf[i] in [BLANK,TAB])) do i := i + 1;
  857.   while (    (buf[i] in [BLANK,TAB])) do i := i + 1;
  858.   scopy(buf,i,buf,1);
  859.   case hdlvl of
  860.    0: begin  {unnumbered heading}
  861.     font := [SFNORM,SFEMP,SFUND];
  862.     setfont(font,0);
  863.     space(L0SBF);
  864.     put(buf);
  865.     space(L0SAF);
  866.     end;
  867.    1: begin
  868.     font := [SFNORM,SFEMP,SFUND];
  869.     setfont(font,0);
  870.     hdlvl1 := hdlvl1 + 1;
  871.     hdlvl2 := 0;
  872.     hdlvl3 := 0;
  873.     hdlvl4 := 0;
  874.     space(L1SBF);
  875.     i := 1;
  876.     i := itoc(hdlvl1,hed,i  ); hed[i] := PERIOD;
  877.     i := itoc(hdlvl2,hed,i+1); hed[i] := BLANK;
  878.     i := i + 1;
  879.     scopy(buf,1,hed,i);
  880.     put(hed);
  881.     space(L1SAF);
  882.     end;
  883.    2: begin
  884.     font := [SFNORM,SFDBLS,SFUND];
  885.     setfont(font,0);
  886.     hdlvl2 := hdlvl2 + 1;
  887.     hdlvl3 := 0;
  888.     hdlvl4 := 0;
  889.     space(L2SBF);
  890.     i := 1;
  891.     i := itoc(hdlvl1,hed,i  ); hed[i] := PERIOD;
  892.     i := itoc(hdlvl2,hed,i+1); hed[i] := BLANK;
  893.     i := i + 1;
  894.     scopy(buf,1,hed,i);
  895.     put(hed);
  896.     space(L2SAF);
  897.     end;
  898.    3: begin
  899.     font := [SFNORM,SFEMP];
  900.     setfont(font,0);
  901.     hdlvl3 := hdlvl3 + 1;
  902.     hdlvl4 := 0;
  903.     space(L3SBF);
  904.     i := 1;
  905.     i := itoc(hdlvl1,hed,i  ); hed[i] := PERIOD;
  906.     i := itoc(hdlvl2,hed,i+1); hed[i] := PERIOD;
  907.     i := itoc(hdlvl3,hed,i+1); hed[i] := BLANK;
  908.     i := i + 1;
  909.     scopy(buf,1,hed,i);
  910.     put(hed);
  911.     space(L3SAF);
  912.     end;
  913.    4: begin
  914.     font := [SFNORM,SFDBLS];
  915.     setfont(font,0);
  916.     hdlvl4 := hdlvl4 + 1;
  917.     space(L4SBF);
  918.     i := 1;
  919.     i := itoc(hdlvl1,hed,i  ); hed[i] := PERIOD;
  920.     i := itoc(hdlvl2,hed,i+1); hed[i] := PERIOD;
  921.     i := itoc(hdlvl3,hed,i+1); hed[i] := PERIOD;
  922.     i := itoc(hdlvl4,hed,i+1); hed[i] := BLANK;
  923.     i := i + 1;
  924.     scopy(buf,1,hed,i);
  925.     put(hed);
  926.     space(L4SAF);
  927.     end;
  928.    end;
  929.   font := fsave;
  930.   setfont(font,0);  { reset font to what it was }
  931. end;
  932. -h- puthead.fmt 288
  933. { puthead -- put out page header }
  934. procedure puthead;
  935. var
  936.  i : integer;
  937. begin
  938.  curpage := newpage;
  939.  newpage := newpage + 1;
  940.  if (m1val > 0) then begin
  941.   skip(m1val-1);
  942.   setfont(hefont,0);
  943.   puttl(header, curpage);
  944.   setfont(font,0);
  945.  end;
  946.  skip(m2val);
  947.  lineno := m1val + m2val + 1
  948. end;
  949. -h- puttl.fmt 399
  950. { puttl -- put out title line with optional page number }
  951. procedure puttl (var buf : sstring; pageno : integer);
  952. var
  953.  i : integer;
  954. begin
  955.  i := 1;
  956.  while (buf[i] <> ENDSTR) do begin
  957.   case buf[i] of
  958.    BACKSLASH: begin
  959.     i := i + 1;
  960.     putc(buf[i]);
  961.     end;
  962.    ATSIGN: putc(BLANK);
  963.    255:    putc(0);
  964.    PAGENUM: putdec(pageno, 1);
  965.    OTHERWISE
  966.     putc(buf[i]);
  967.   end;
  968.   i := i + 1;
  969.  end;
  970. end;
  971. -h- putword.fmt 771
  972. { putword -- put word in outbuf; does margin justification }
  973. procedure putword (var wordbuf : sstring);
  974. var
  975.  last, llval, nextra, w : integer;
  976.  i : integer;
  977. begin
  978.  w := width(wordbuf);
  979.  last := length(wordbuf) + outp + 1; { new end of outbuf }
  980.  llval := rmval - tival - inval;
  981.  if (outp > 0)
  982.    and ((outw+w > llval) or (last >= upper(outbuf))) then begin
  983.   last := last - outp; { remember end of wordbuf }
  984.   nextra := llval - outw + 1;
  985.   if (just) and (nextra > 0) and (outwds > 1) then begin
  986.    spread(outbuf, outp, nextra, outwds);
  987.    outp := outp + nextra
  988.   end;
  989.   lbreak { flush previous line }
  990.  end;
  991.  scopy(wordbuf, 1, outbuf, outp+1);
  992.  outp := last;
  993.  outbuf[outp] := BLANK; { blank between words }
  994.  outw := outw + w + 1; { 1 for blank }
  995.  outwds := outwds + 1
  996. end;
  997. -h- putwordx.fmt 562
  998. { putword -- put word in outbuf }
  999. procedure putword (var wordbuf : string);
  1000. var
  1001.  last, llval, nextra, w : integer;
  1002. begin
  1003.  w := width(wordbuf);
  1004.  last := length(wordbuf) + outp + 1; { new end of outbuf }
  1005.  llval := rmval - tival - inval;
  1006.  if (outp > 0)
  1007.    and ((outw+w > llval) or (last >= MAXSTR)) then begin
  1008.   last := last - outp; { remember end of wordbuf }
  1009.   lbreak { flush previous line }
  1010.  end;
  1011.  scopy(wordbuf, 1, outbuf, outp+1);
  1012.  outp := last;
  1013.  outbuf[outp] := BLANK; { blank between words }
  1014.  outw := outw + w + 1; { 1 for blank }
  1015.  outwds := outwds + 1
  1016. end;
  1017. -h- setfont.fmt 3803
  1018. Type
  1019.  prtrs_type = array[1..100] of character;  { to set a special font }
  1020.  
  1021. { initfont -- initialize the prtrs array with codes to make printer }
  1022. {          do it's wonderous font changes.                       }
  1023. {          See file for description of file format.            }
  1024. procedure initfont (var prtrs: prtrs_type; var resloc : integer);
  1025. var
  1026.    line : string;
  1027.    fd    : filedesc;
  1028.    bool : boolean;
  1029.    i,lcnt,cnt,sp : integer;
  1030. Begin
  1031.    line[1] := LETF;  line[2] := LETM;  line[3] := LETT;
  1032.    line[4] := PERIOD;
  1033.    line[5] := LETF;  line[6] := LETN;  line[7] := LETT;
  1034.    line[8] := ENDSTR;
  1035.    fd := mustopen(line, IOREAD);
  1036.    for i := 1 to 7 do bool := getline(line, fd, MAXSTR); { skip header lines }
  1037.    sp := 0;
  1038.    for i := 1 to 12 do prtrs[i] := 0;
  1039.    resloc   := 1;
  1040.    lcnt := 0;
  1041.    cnt    := 0;
  1042.    while (getline(line, fd, MAXSTR)) do begin
  1043.       lcnt := lcnt + 1;
  1044.       cnt  := 0;
  1045.       sp := sp + 1;   { make room for count we will know later }
  1046.       i := 1;
  1047.       while (line[i] <> ENDSTR) and (line[i] <> NEWLINE) do
  1048.      case line[i] of
  1049.         BLANK,TAB,COMMA : i := i + 1;
  1050.         NUM0..NUM9 : begin
  1051.            cnt := cnt + 1;
  1052.            sp := sp + 1;
  1053.            prtrs[sp] := ctoi(line, i);
  1054.            end;
  1055.         LBRACE : begin  { skip past comment }
  1056.            repeat
  1057.           i := i + 1
  1058.            until (line[i]=ENDSTR) or (line[i]=RBRACE);
  1059.            if line[i]=ENDSTR then error('fmt.fnt: reached EOL in comment');
  1060.            i := i + 1;
  1061.            end;
  1062.         OTHERWISE
  1063.            error('fmt.fnt: invalid character found');
  1064.         end;
  1065.       prtrs[sp-cnt] := cnt;
  1066.       if lcnt=7 then resloc := sp-cnt;
  1067.       end;
  1068.    if lcnt <> 12 then error('fmt.fnt: invalid line count');
  1069.    xclose(fd);
  1070. End;
  1071.  
  1072. { outfont -- writes out font for given font type }
  1073. procedure outfont (fnum: fontrang; fun: integer; const OnOff: boolean);
  1074. var
  1075.  prtrs    [static] : prtrs_type;
  1076.  resloc [static] : integer;
  1077.  fcall    [static] : boolean;
  1078.  i,j : integer;
  1079. value
  1080.  fcall := TRUE;
  1081. begin
  1082.  if fcall then begin
  1083.    fcall := FALSE;
  1084.    initfont(prtrs, resloc);
  1085.  end;
  1086.  { Scan 'set' or 'reset' table, based on OnOff flag }
  1087.  { The scan is slow of course, but we assume table is small, plus }
  1088.  { fonts aren't defined that often.                               }
  1089.  if OnOff then j := 1 else j := resloc;
  1090.   i := 1;
  1091.   while (i <> fnum) do begin
  1092.    i := i + 1;
  1093.    j := prtrs[j] + j + 1;
  1094.   end;
  1095.   if fun = 0 then
  1096.    for i := 1 to prtrs[j] do putc(prtrs[i+j])
  1097.   else
  1098.    for i := 1 to prtrs[j] do begin
  1099.     outp := outp + 1;
  1100.     outbuf[outp] := prtrs[i+j];
  1101.     { talk about kludges! the following statement sets a 0 value to 255 }
  1102.     { and the 'put' routine resets it to 0 on output, so we don't think }
  1103.     { the zero is the ENDSTR character }
  1104.     if outbuf[outp] = 0 then outbuf[outp] := 255;
  1105.    end;
  1106. end;
  1107.  
  1108. { setfont -- setup current output font, using features of printer hardware }
  1109. { fun=0 to do immediate putc of font characters }
  1110. { fun=1 to put characters into outbuf array    }
  1111. { seems pretty kludgy, but haven't got time to do it right }
  1112. procedure setfont (const cfont : fonttype; fun: integer);
  1113. var
  1114.  outpflag [extern] : outptype;
  1115.  lfont [static] : fonttype; { save this so we know current state }
  1116.  fnum: integer;
  1117. value
  1118.  lfont := [SFDBLS,SFEMP,SFITAL,SFDBLW,SFCOMP,SFUND];  {init to all so we reset}
  1119.                               {all on first call      }
  1120. begin
  1121.  if (outpflag = STDCONS) or (lfont = cfont) then return;
  1122.  if cfont = [SFNORM] then begin { reset printer back to normal state }
  1123.     for fnum := SFDBLS to SFUND do
  1124.        if (fnum in lfont) then
  1125.       outfont(fnum, fun, FALSE);
  1126.     end
  1127.  else begin
  1128.     for fnum := SFDBLS to SFUND do { add/delete fonts as given }
  1129.        if (fnum in cfont) and (not (fnum in lfont)) then       {font added}
  1130.       outfont(fnum, fun, TRUE)
  1131.        else if (fnum in lfont) and (not (fnum in cfont)) then  {font deleted}
  1132.       outfont(fnum, fun, FALSE);
  1133.     end;
  1134.  lfont := cfont;
  1135. end;
  1136. -h- setparam.fmt 447
  1137. { setparam -- set parameter and check range }
  1138. procedure setparam (var param : integer;
  1139.   val, argtype, defval, minval, maxval : integer);
  1140. begin
  1141.  if (argtype = NEWLINE) then  { defaulted }
  1142.   param := defval
  1143.  else if (argtype = PLUS) then    { relative + }
  1144.   param := param + val
  1145.  else if (argtype = MINUS) then  { relative - }
  1146.   param := param - val
  1147.  else { absolute }
  1148.   param := val;
  1149.  param := imin(param, maxval);
  1150.  param := imax(param, minval)
  1151. end;
  1152. -h- settext.fmt 1361
  1153. { settext -- create line with text adjusted /left/middle/right/ }
  1154. procedure settext (var buf,lin : sstring);
  1155. label err;
  1156. var
  1157.  i   : integer;
  1158.  delim : character;  {delimiter, normally /}
  1159. begin
  1160.   i := 1;
  1161.   while (not (buf[i] in [BLANK,TAB])) do i := i + 1;   {skip over .command}
  1162.   while (    (buf[i] in [BLANK,TAB])) do i := i + 1;
  1163.   delim := buf[i];
  1164.   for j := 1 to rmval do lin[j] := BLANK;  {init lin to blanks}
  1165.   lin[rmval+1] := NEWLINE;
  1166.   lin[rmval+2] := ENDSTR;
  1167.   i := i + 1;
  1168.   j := 1;
  1169.   while (buf[i] <> delim) do begin       {move left portion}
  1170.    if (buf[i] = NEWLINE) or (j > rmval) then goto err;
  1171.    lin[j] := buf[i];
  1172.    i := i + 1;
  1173.    j := j + 1;
  1174.   end;
  1175.   i := i + 1;
  1176.   j := i;
  1177.   while (buf[j] <> delim) do begin       {get length of middle}
  1178.    if (buf[j] = NEWLINE) then goto err;
  1179.    j := j + 1;
  1180.   end;
  1181.   k := j - i;
  1182.   j := imax((rmval-k) div 2, 0)
  1183.   while (buf[i] <> delim) do begin       {move middle portion}
  1184.    if (buf[i] = NEWLINE) or (j > rmval) then goto err;
  1185.    lin[j] := buf[i];
  1186.    i := i + 1;
  1187.    j := j + 1;
  1188.   end;
  1189.   i := i + 1;
  1190.   while (buf[i] <> delim) do begin       {find end of buf}
  1191.    if (buf[i] = NEWLINE) then goto err;
  1192.    i := i + 1;
  1193.   end;
  1194.   i := i - 1;
  1195.   j := rmval;
  1196.   while (buf[i] <> delim) do begin       {move right portion}
  1197.    lin[j] := buf[i];
  1198.    i := i - 1;
  1199.    j := j - 1;
  1200.   end;
  1201.  return;
  1202.  
  1203.  err: error('***Invalid settext syntax');
  1204. end;
  1205. -h- skip.fmt 130
  1206. { skip -- output  n  blank lines }
  1207. procedure skip (n : integer);
  1208. var
  1209.  i : integer;
  1210. begin
  1211.  for i := 1 to n do
  1212.   putc(NEWLINE)
  1213. end;
  1214. -h- skipbl.fmt 164
  1215. { skipbl -- skip blanks and tabs at s[i]... }
  1216. procedure skipbl (var s : sstring; var i : integer);
  1217. begin
  1218.  while (s[i] = BLANK) or (s[i] = TAB) do
  1219.   i := i + 1
  1220. end;
  1221. -h- space.fmt 271
  1222. { space -- space n lines or to bottom of page }
  1223. procedure space (n : integer);
  1224. begin
  1225.  lbreak;
  1226.  if (lineno <= bottom) then begin
  1227.   if (lineno <= 0) then
  1228.    puthead;
  1229.   skip(imin(n, bottom+1-lineno));
  1230.   lineno := lineno + n;
  1231.   if (lineno > bottom) then
  1232.    putfoot
  1233.  end
  1234. end;
  1235. -h- spread.fmt 745
  1236. { spread -- spread words to justify right margin }
  1237. procedure spread (var buf : sstring;
  1238.    outp, nextra, outwds : integer);
  1239. var
  1240.  i, j, nb, nholes : integer;
  1241. begin
  1242.  if (nextra > 0) and (outwds > 1) then begin
  1243.   dir := 1 - dir; { reverse previous direction }
  1244.   nholes := outwds - 1;
  1245.   i := outp - 1;
  1246.   j := imin(BIGSTR-2, i+nextra); { room for NEWLINE }
  1247.   while (i < j) do begin  { and ENDSTR }
  1248.    buf[j] := buf[i];
  1249.    if (buf[i] = BLANK) then begin
  1250.     if (dir = 0) then
  1251.      nb := (nextra-1) div nholes + 1
  1252.     else
  1253.      nb := nextra div nholes;
  1254.     nextra := nextra - nb;
  1255.     nholes := nholes - 1;
  1256.     while (nb > 0) do begin
  1257.      j := j - 1;
  1258.      buf[j] := BLANK;
  1259.      nb := nb - 1
  1260.     end
  1261.    end;
  1262.    i := i - 1;
  1263.    j := j - 1
  1264.   end
  1265.  end
  1266. end;
  1267. -h- text.fmt 690
  1268. { text -- process text lines (final version) }
  1269. procedure text (var inbuf : sstring);
  1270. var
  1271.  wordbuf : string;
  1272.  i : integer;
  1273. begin
  1274.  if (inbuf[1] = BLANK) or (inbuf[1] = NEWLINE) then
  1275.   leadbl(inbuf); { move left, set tival }
  1276.  if (ulval > 0) then begin { underlining }
  1277.   underln(inbuf, BIGSTR);
  1278.   ulval := ulval - 1
  1279.  end;
  1280.  if (ceval > 0) then begin { centering }
  1281.   center(inbuf);
  1282.   put(inbuf);
  1283.   ceval := ceval - 1
  1284.  end
  1285.  else if (inbuf[1] = NEWLINE) then  { all-blank line }
  1286.   put(inbuf)
  1287.  else if (not fill) then  { unfilled text }
  1288.   put(inbuf)
  1289.  else begin { filled text }
  1290.   i := 1;
  1291.   repeat
  1292.    i := getword(inbuf, i, wordbuf);
  1293.    if (i > 0) then
  1294.     putword(wordbuf)
  1295.   until (i = 0)
  1296.  end
  1297. end;
  1298. -h- underln.fmt 485
  1299. { underln -- underline a line }
  1300. procedure underln (var buf : sstring; size : integer);
  1301. var
  1302.  i, j : integer;
  1303.  tbuf : bigstring;
  1304. begin
  1305.  j := 1; { expand into tbuf }
  1306.  i := 1;
  1307.  while (buf[i] <> NEWLINE) and (j < size-1) do begin
  1308.   if (isalphanum(buf[i])) then begin
  1309.    tbuf[j] := UNDERLINE;
  1310.    tbuf[j+1] := BACKSPACE;
  1311.    j := j + 2
  1312.   end;
  1313.   tbuf[j] := buf[i];
  1314.   j := j + 1;
  1315.   i := i + 1
  1316.  end;
  1317.  tbuf[j] := NEWLINE;
  1318.  tbuf[j+1] := ENDSTR;
  1319.  scopy(tbuf, 1, buf, 1) { copy it back to buf }
  1320. end;
  1321. -h- width.fmt 365
  1322. { width -- compute width of character string }
  1323. function width (var buf : sstring) : integer;
  1324. var
  1325.  i, w : integer;
  1326. begin
  1327.  w := 0;
  1328.  i := 1;
  1329.  while (buf[i] <> ENDSTR) do begin
  1330.   case buf[i] of
  1331.    BACKSPACE: w := w - 1;
  1332.    NEWLINE:   ;
  1333.    BACKSLASH: begin
  1334.     i := i + 1;
  1335.     w := w + 1;
  1336.     end;
  1337.    OTHERWISE
  1338.     w := w + 1;
  1339.   end;
  1340.   i := i + 1
  1341.  end;
  1342.  width := w
  1343. end;
  1344. -h- fmt.pas 846
  1345. {$debug-}
  1346. program outer (input,output);
  1347.  
  1348. {$include:'globcons.inc'}
  1349. {$include:'globtyps.inc'}
  1350.  
  1351. {$include:'initio.dcl'}
  1352. {$include:'flush.dcl' }
  1353.  
  1354. {$include:'isalphan.dcl'}
  1355. {$include:'isupper.dcl' }
  1356. {$include:'isdigit.dcl' }
  1357. {$include:'isletter.dcl'}
  1358. {$include:'message.dcl' }
  1359. {$include:'error.dcl'   }
  1360. {$include:'getline.dcl' }
  1361. {$include:'getcf.dcl'   }
  1362. {$include:'getc.dcl'    }
  1363. {$include:'putstr.dcl'  }
  1364. {$include:'putdec.dcl'  }
  1365. {$include:'putcf.dcl'   }
  1366. {$include:'putc.dcl'    }
  1367. {$include:'ctoi.dcl'    }
  1368. {$include:'itoc.dcl'    }
  1369. {$include:'length.dcl'  }
  1370. {$include:'imin.dcl'    }
  1371. {$include:'imax.dcl'    }
  1372. {$include:'getarg.dcl'  }
  1373. {$include:'nargs.dcl'   }
  1374. {$include:'scopy.dcl'   }
  1375. {$include:'equal.dcl'   }
  1376. {$include:'mustopen.dcl'}
  1377. {$include:'close.dcl'   }
  1378.  
  1379. {$include:'format.fmt'  }
  1380. BEGIN
  1381.   minitio; initio;
  1382.   format;
  1383.   flush(0);
  1384. END.
  1385. -h- fmt.mak 191
  1386. fmt+initio+getfcb+error+getarg+nargs+length+isalphan+
  1387. message+getline+getcf+getc+putstr+putdec+putc+imin+imax+
  1388. ctoi+itoc+putcf+scopy+flush+isupper+isdigit+isletter+
  1389. open+close+mustopen+equal
  1390.