home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / PASCAL / PT03.ZIP / PRIMS.AR < prev    next >
Encoding:
Text File  |  1983-09-06  |  20.4 KB  |  871 lines
  1. -h- close.pr 490
  2. {$debug-}
  3. MODULE MCLOSE;
  4.  
  5. {$include:'globcons.inc'}
  6. {$include:'globtyps.inc'}
  7. {$include:'flush.dcl'}
  8.  
  9. { close (PC) -- release file descriptor slot for open file }
  10. procedure xclose (fd : filedesc);
  11. var
  12.  openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
  13. begin
  14.  if (fd > STDERR) and (fd <= MAXOPEN) then begin
  15.   flush(fd);
  16.   with openlist[fd] do begin
  17.    close(filevar^); { in case buffered }
  18.    dispose(filevar);
  19.    dispose(buf);
  20.    mode := IOAVAIL
  21.   end;
  22.  end
  23. end;
  24.  
  25. END.
  26. -h- create.pr 1102
  27. {$debug-}
  28. MODULE MCREATE;
  29.  
  30. {$include:'globcons.inc'}
  31. {$include:'globtyps.inc'}
  32.  
  33. { create (PC) -- create a file }
  34. function create (var name : sstring; xmode : integer) : filedesc;
  35. var
  36.  openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
  37.  i : integer;
  38.  intname : packed array[1..MAXFN] of char;
  39.  found : boolean;
  40. begin
  41.  i := 1;
  42.  while (name[i] <> ENDSTR) do begin
  43.   intname[i] := chr(name[i]);
  44.   i := i + 1
  45.  end;
  46.  for i := i to MAXFN do
  47.   intname[i] := ' '; { pad name with blanks }
  48.  { find a free slot in openlist }
  49.  create := IOERROR;
  50.  found := false;
  51.  i := 1;
  52.  while (i <= MAXOPEN) and (not found) do begin
  53.   if (openlist[i].mode = IOAVAIL) then with openlist[i] do begin
  54.    mode := xmode;
  55.    cpos := 0;
  56.    new(buf);
  57.    buf^ := NULL;
  58.    new(filevar);
  59.    filevar^.trap := TRUE;  {catch file open failure}
  60.    assign(filevar^, intname);
  61.    rewrite(filevar^);
  62.    if (mode = IOREAD) then reset(filevar^);
  63.    create := i;
  64.    found := true;
  65.    if filevar^.errs <> 0 then create := IOERROR;
  66.    filevar^.trap := FALSE; {reset so we will exit on i/o error}
  67.   end;
  68.   i := i + 1
  69.  end
  70. end;
  71.  
  72. END.
  73. -h- error.pr 518
  74. {$debug-}
  75. MODULE MERROR;
  76.  
  77. {$include:'globcons.inc'}
  78. {$include:'globtyps.inc'}
  79.  
  80. {$include:'putc.dcl' }
  81. {$include:'putcf.dcl'}
  82. {$include:'flush.dcl'}
  83. procedure ENDXQQ; extern;
  84.  
  85. { error (PC) -- write error message and exit }
  86. { note: string is not terminated by normal ENDSTR delimiter }
  87. procedure error (const s : lstring);
  88. var
  89.  i : integer;
  90. begin
  91.  for i := 1 to ord(s[0]) do putcf(ord(s[i]),STDERR);
  92.  putcf(NEWLINE,STDERR);
  93.  flush(0);  { force write of standard output }
  94.  ENDXQQ; { call system exit routine }
  95. end;
  96.  
  97. END.
  98. -h- flush.pr 805
  99. {$debug-}
  100. MODULE MFLUSH;
  101.  
  102. {$include:'globcons.inc'}
  103. {$include:'globtyps.inc'}
  104.  
  105. { flush (PC) -- forces writing of the given file buffer, or flushes }
  106. { all buffers if fd = 0 }
  107. procedure flush (fd: filedesc);
  108. var
  109.  openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
  110.  i : filedesc;
  111. begin
  112.  if fd = 0 then begin
  113.   for i := STDOUT to MAXOPEN do
  114.    if (openlist[i].mode = IOWRITE) and (ord(openlist[i].buf^[0]) > 0)
  115.    then with openlist[i] do begin
  116.     if i = STDOUT then
  117.      write(buf^)
  118.     else
  119.      write(filevar^,buf^);
  120.     buf^ := NULL;
  121.    end;
  122.  end
  123.  else with openlist[fd] do
  124.   if (fd >= STDOUT) and (fd <= MAXOPEN) and (mode = IOWRITE)
  125.      and (ord(buf^[0]) > 0)
  126.   then begin
  127.    if fd = STDOUT then
  128.     write(buf^)
  129.    else
  130.     write(filevar^,buf^);
  131.    buf^ := NULL;
  132.   end;
  133. end;
  134.  
  135. END.
  136. -h- gdate.pr 510
  137. {$debug-}
  138. MODULE MGDATE;
  139.  
  140. Type
  141.  character = 0..255;  { byte-sized. ascii + other stuff }
  142.  sstring = super packed array [1..*] of character;
  143.  
  144. Procedure DATE (var s: string); { NOTE: <-- this string is the IBM Pascal  }
  145.       external;        { idea of a string, and not the Tools idea }
  146.  
  147. { gdate (PC) -- get the current date as 8 characters like mm-dd-yy }
  148. Procedure gdate (var s : sstring);
  149. var
  150.  dt : string(8);
  151.  i  : integer;
  152. begin
  153.  date(dt);
  154.  for i := 1 to 8 do s[i] := ord(dt[i]);
  155.  s[9] := 0;  { ENDSTR }
  156. end;
  157.  
  158. END.
  159. -h- getarg.pr 1025
  160. {$debug-}
  161. MODULE MGETARG;
  162.  
  163. {$include:'globcons.inc'}
  164. {$include:'globtyps.inc'}
  165. {$include:'nargs.dcl'}
  166.  
  167. { getarg (PC) -- copy n-th command line argument into s }
  168. function getarg (n : integer; var s : sstring;
  169.   maxs : integer) : boolean;
  170.  
  171. var
  172.  lpos [static] : parmptr;   { position of last argument asked for }
  173.  lnum [static] : integer;   { number of last argument asked for   }
  174.  lstr : parmstr;        { pointer to parm string }
  175.  parmtop  [extern] : parmptr;
  176.  parmcnt  [extern] : integer;
  177.  count : integer;
  178.  i,j   : integer;
  179. value
  180.  lpos  := NIL; { we keep this so a sequential scan thru args is fast }
  181.  
  182. begin
  183.  if (n > 0) and (n <= nargs) then begin
  184.   if (lpos = NIL) or (n < lnum) then begin
  185.    lpos := parmtop;
  186.    lnum := 1;
  187.   end;
  188.   { get the argument }
  189.   while (lnum <> n) do begin
  190.    lpos := lpos^.next;
  191.    lnum := lnum + 1;
  192.   end;
  193.   i := 1;
  194.   lstr := lpos^.parm;
  195.   repeat
  196.    s[i] := lstr^[i];
  197.    i := i + 1;
  198.   until (s[i-1] = ENDSTR);
  199.   getarg := true
  200.  end
  201.  else begin
  202.   s[1] := ENDSTR;
  203.   getarg := false;
  204.  end;
  205. end;
  206.  
  207. END.
  208. -h- getc.pr 750
  209. {$debug-}
  210. MODULE MGETC;
  211.  
  212. {$include:'globcons.inc'}
  213. {$include:'globtyps.inc'}
  214.  
  215. { getc (PC) -- get one character from standard input }
  216. { This is a fast version which actually reads a line at a time and returns }
  217. { one character from a buffer }
  218.  
  219. function getc (var c : character) : character;
  220. Label
  221.  ReadBuf;
  222. var
  223.  openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
  224. begin
  225.  with openlist[STDIN] do begin
  226.   if (cpos = 0) then
  227.    if eof then begin
  228.     c := ENDFILE;
  229.     getc := c;
  230.     return
  231.    end
  232.    else
  233. ReadBuf:
  234.     read(buf^);
  235.   cpos := cpos + 1;
  236.   if (cpos > ord(buf^[0])) then begin
  237.    cpos := 0;
  238.    if not eoln(input) then goto ReadBuf;
  239.    readln;
  240.    c := NEWLINE
  241.   end
  242.   else
  243.    c := ord(buf^[cpos]);
  244.  end;
  245.  getc := c
  246. end;
  247.  
  248. END.
  249. -h- getcf.pr 746
  250. {$debug-}
  251. MODULE MGETCF;
  252.  
  253. {$include:'globcons.inc'}
  254. {$include:'globtyps.inc'}
  255. {$include:'getc.dcl'}
  256.  
  257. { getcf (PC) -- get one character from file }
  258. function getcf (var c: character; fd : filedesc) : character;
  259. Label
  260.  ReadBuf;
  261. var
  262.  openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
  263. begin
  264.  if (fd = STDIN) then
  265.   getcf := getc(c)
  266.  else with openlist[fd] do begin
  267.   if (cpos = 0) then
  268.    if eof(filevar^) then begin
  269.     c := ENDFILE;
  270.     getcf := c;
  271.     return
  272.    end
  273.    else
  274. ReadBuf:
  275.     read(filevar^,buf^);
  276.   cpos := cpos + 1;
  277.   if (cpos > ord(buf^[0])) then begin
  278.    cpos := 0;
  279.    if not eoln(filevar^) then goto ReadBuf;
  280.    readln(filevar^);
  281.    c := NEWLINE
  282.   end
  283.   else
  284.    c := ord(buf^[cpos]);
  285.  end;
  286.  getcf := c
  287. end;
  288.  
  289. END.
  290. -h- getline.pr 492
  291. {$debug-}
  292. MODULE MGETLINE;
  293.  
  294. {$include:'globcons.inc'}
  295. {$include:'globtyps.inc'}
  296. {$include:'getcf.dcl'}
  297.  
  298. { getline (PC) -- get a line from file }
  299. function getline (var s : sstring; fd : filedesc;
  300.   maxsize : integer) : boolean;
  301. var
  302.  i : integer;
  303.  c : character;
  304. begin
  305.  i := 1;
  306.  repeat
  307.   s[i] := getcf(c, fd);
  308.   i := i + 1;
  309.  until (c = ENDFILE) or (c = NEWLINE) or (i >= maxsize);
  310.  if (c = ENDFILE) then { went one too far }
  311.   i := i - 1;
  312.  s[i] := ENDSTR;
  313.  getline := (c <> ENDFILE)
  314. end;
  315.  
  316. END.
  317. -h- gtime.pr 510
  318. {$debug-}
  319. MODULE MGTIME;
  320.  
  321. Type
  322.  character = 0..255;  { byte-sized. ascii + other stuff }
  323.  sstring = super packed array [1..*] of character;
  324.  
  325. Procedure TIME (var s: string); { NOTE: <-- this string is the IBM Pascal  }
  326.       external;        { idea of a string, and not the Tools idea }
  327.  
  328. { gtime (PC) -- get the current time as 8 characters like hh:mm:ss }
  329. Procedure gtime (var s : sstring);
  330. var
  331.  tm : string(8);
  332.  i  : integer;
  333. begin
  334.  time(tm);
  335.  for i := 1 to 8 do s[i] := ord(tm[i]);
  336.  s[9] := 0;  { ENDSTR }
  337. end;
  338.  
  339. END.
  340. -h- initio.pr 8860
  341. {$debug-}
  342. {$include:'a:filkqq.inc'}
  343. MODULE MINITIO;
  344. uses filkqq;
  345.  
  346. {$include:'globcons.inc'}
  347.   MAXARGS = 300;       { maximum number of args to be put into linked }
  348.                { list, necessary because of strange behavior  }
  349.                { caused by extremely long list ... sigh.      }
  350.  
  351. {$include:'globtyps.inc'}
  352.  
  353. {$include:'error.dcl'}
  354. {$include:'putc.dcl'}
  355.  
  356. function  PPMUQQ (unused1: word; unused2: adrmem; var dst: lstring): word;
  357.       external;
  358. function getfcb(vars fin,fout: dosfcb;    mode: integer): boolean; external;
  359.  
  360. { initialize routine for software tools }
  361. procedure initio;
  362.  
  363. label normchar,err;
  364.  
  365. var
  366.  openlist [public] : array [STDIN..MAXOPEN] of ioblock; { open files }
  367.  outpflag [public] : outptype;
  368.  parmtop  [public] : parmptr;
  369.  parmcnt  [public] : integer;
  370.  parmcur : parmptr;
  371.  sortptr : parmptr;
  372.  f     : filedesc;
  373.  errx     : word;
  374.  i,j,l     : integer;
  375.  fname     : lstring(MAXFN);
  376.  parms     : lstring(255);
  377.  oneparm : string;
  378.  c     : character;
  379.  inarg     : boolean;
  380.  sparg     : boolean;
  381.  
  382. { pcompare -- compare two argument strings, return -1 if str1 < str2, }
  383. {          0 if equal, and 1 if str1 > str2.               }
  384. function pcompare (const str1: superst; const str2: string) : integer;
  385. var
  386.  i : integer;
  387. begin
  388.  i := 1;
  389.  while (str1[i] = str2[i]) and (str1[i] <> ENDSTR) do
  390.   i := i + 1;
  391.  if     str1[i] < str2[i] then pcompare := -1
  392.  else if str1[i] = str2[i] then pcompare := 0
  393.  else pcompare := 1;
  394. end;
  395.  
  396. { routine to add an argument to the parameter linked list }
  397. { note: if sortflg is TRUE, then argument is put into list in sorted   }
  398. { order, starting somewhere after sortptr.                   }
  399. procedure addarg(const arg: string; len: integer; var sortptr: parmptr;
  400.          sortflg : boolean);
  401. Label
  402.     Add_at_end, All_done;
  403. var
  404.  parmnew : parmptr;
  405.  parmp     : parmstr;
  406.  mm     : integer;
  407.  pp,pl     : parmptr;
  408. begin
  409.  new(parmnew);
  410.  new(parmp,len);
  411.  for mm := 1 to len do parmp^[mm] := arg[mm];
  412.  parmnew^.parm := parmp;
  413.  if parmcur = NIL then begin
  414.   parmtop := parmnew;
  415.   goto Add_at_end;
  416.   end;
  417.  if (not sortflg) then goto Add_at_end;
  418.  { insert arg in sorted order somewhere }
  419.  pl := sortptr;
  420.  if pl = NIL then pp := parmtop else pp := pl^.next;
  421.  while pp <> NIL do begin
  422.    if pcompare(pp^.parm^, arg) < 0 then begin
  423.      pl := pp;
  424.      pp := pl^.next;
  425.      cycle;
  426.      end;
  427.    if pl = NIL then begin { insert at top }
  428.      parmtop := parmnew;
  429.      parmnew^.next := pp;
  430.      goto All_done;
  431.      end
  432.    else begin         { insert in middle }
  433.      pl^.next := parmnew;
  434.      parmnew^.next := pp;
  435.      goto All_done;
  436.      end;
  437.    end;
  438. Add_at_End:
  439.  parmcur^.next := parmnew;
  440.  parmcur := parmnew;
  441.  parmcur^.next := NIL;
  442. All_done:
  443.  parmcnt := parmcnt + 1;
  444.  if parmcnt > MAXARGS then error('Too many arguments');
  445. end;
  446.  
  447. { routine to expand a special character type argument into a set of }
  448. { filenames that match.  We will use the DOS search ability, rather }
  449. { than general pattern matching routines, in the interest of speed  }
  450. { and memory and complexity.                        }
  451. procedure expparm(var farg : string);
  452. const
  453.  upcaseA = LETA - 32;
  454.  upcaseZ = LETZ - 32;
  455. var
  456.  fin,fout : dosfcb;
  457.  ii,jj      : integer;
  458.  func      : integer;
  459.  filenm   : string;
  460. begin
  461.  sortptr := parmcur;
  462.  { build pattern for getfcb routine }
  463.  fin.fn := '        ';
  464.  fin.ft := '   ';
  465.  ii := 1;
  466.  { start with disk letter }
  467.  fin.dr := 0;
  468.  if farg[2] = COLON then begin
  469.   if farg[1] in [upcaseA..upcaseZ] then farg[1] := farg[1] + 32;
  470.   if (not (farg[1] in [LETA..LETZ])) then
  471.    error('Invalid command line filename disk letter')
  472.   else
  473.    fin.dr := wrd(farg[1] - 96);
  474.   ii :=  3;
  475.  end;
  476.  { now do filename }
  477.  if farg[ii] = PERIOD then
  478.   fin.fn := '????????'
  479.  else begin
  480.   jj := 1;
  481.   while (not (farg[ii] in [PERIOD,ENDSTR])) do begin
  482.    if jj > 8 then error('Invalid command line filename');
  483.    if farg[ii] = STAR then
  484.     while (jj <= 8) do begin fin.fn[jj] := '?'; jj := jj + 1; end
  485.    else begin
  486.     fin.fn[jj] := chr(farg[ii]);
  487.     jj := jj + 1;
  488.    end;
  489.    ii := ii + 1;
  490.   end;
  491.  end;
  492.  { and finally do filetype }
  493.  if (farg[ii] = PERIOD) then ii := ii + 1;
  494.  if (farg[ii] = ENDSTR) then
  495.   fin.ft := '???'
  496.  else begin
  497.   jj := 1;
  498.   while (farg[ii] <> ENDSTR) do begin
  499.    if jj > 3 then error('Invalid command line filetype');
  500.    if farg[ii] = STAR then
  501.     while (jj <= 3) do begin fin.ft[jj] := '?'; jj := jj + 1; end
  502.    else begin
  503.     fin.ft[jj] := chr(farg[ii]);
  504.     jj := jj + 1;
  505.    end;
  506.    ii := ii + 1;
  507.   end;
  508.  end;
  509.  { ok, we got a pattern into 'fin', now call getfcb as long as we can }
  510.  func := 1;
  511.  while (getfcb(fin, fout, func)) do begin
  512.   func := 2;
  513.   ii := 0;
  514.   if fin.dr <> 0 then begin
  515.    filenm[ii+1] := ord(fout.dr) + 96;  {lower case}
  516.    filenm[ii+2] := COLON;
  517.    ii := 2;
  518.   end;
  519.   jj := 1;
  520.   while (jj <= 8) and (fout.fn[jj] <> ' ') do begin
  521.    ii := ii + 1;
  522.    filenm[ii] := ord(fout.fn[jj]);
  523.    if (filenm[ii] in [ord('A')..ord('Z')]) then filenm[ii] := filenm[ii]+32;
  524.    jj := jj + 1;
  525.   end;
  526.   if fout.ft[1] <> ' ' then begin
  527.    ii := ii + 1;
  528.    filenm[ii] := PERIOD;
  529.   end;
  530.   jj := 1;
  531.   while (jj <= 3) and (fout.ft[jj] <> ' ') do begin
  532.    ii := ii + 1;
  533.    filenm[ii] := ord(fout.ft[jj]);
  534.    if (filenm[ii] in [ord('A')..ord('Z')]) then filenm[ii] := filenm[ii]+32;
  535.    jj := jj + 1;
  536.   end;
  537.   { now add the argument to the list }
  538.   ii := ii + 1;
  539.   filenm[ii] := ENDSTR;
  540.   addarg(filenm,ii,sortptr,TRUE);
  541.  end;
  542. end;
  543.  
  544. begin
  545.  outpflag := STDCONS;
  546.  
  547.  new(openlist[STDIN].buf);
  548.  new(openlist[STDOUT].buf);
  549.  new(openlist[STDERR].buf);
  550.  openlist[STDIN].buf^ := NULL;
  551.  openlist[STDOUT].buf^ := NULL;
  552.  openlist[STDERR].buf^ := NULL;
  553.  openlist[STDIN].mode := IOREAD;
  554.  openlist[STDOUT].mode := IOWRITE;
  555.  openlist[STDERR].mode := IOWRITE;
  556.  openlist[STDIN].cpos := 0;
  557.  openlist[STDERR].cpos := 0;
  558.  openlist[STDERR].cpos := 0;
  559.  
  560.  new(openlist[STDERR].filevar);
  561.  assign(openlist[STDERR].filevar^,'USER');
  562.  rewrite(openlist[STDERR].filevar^);
  563.  
  564.  for f := STDERR+1 to MAXOPEN do
  565.   openlist[f].mode := IOAVAIL;
  566.  
  567. { initialize parmstrg, and perform any redirection of i/o }
  568. { also, if we find a parm with an * or ? in it, and not in quotes or }
  569. { preceded by a \, we will expand it to all filenames that match.    }
  570. { SPECIAL DOS 2.0 NOTE:
  571. { Redirection will be done by DOS, and not this routine, since we will }
  572. { never see a > or < character.  Also, we will not see a \ character,  }
  573. { so escaped characters must be surrounded by quotes.               }
  574.  errx := PPMUQQ(0, adr NULL, parms);
  575.  parms[0] := chr(ord(parms[0])+1);     {stick ENDSTR on end to ease scan}
  576.  parms[ord(parms[0])] := chr(ENDSTR);
  577.  parmtop := NIL;
  578.  parmcur := NIL;
  579.  parmcnt := 0;
  580.  i := 1;            {current pos in parms}
  581.  while (parms[i] in [' ']) do   {skip any leading blanks}
  582.   i := i + 1;
  583.  j := 0;            {current pos in oneparm}
  584.  inarg := FALSE;  {flag says if we are in middle of arg or not}
  585.  sparg := FALSE;  {flag says if we found a special char in current arg}
  586.  c := ord(parms[i]);
  587.  while (c <> ENDSTR) do begin
  588.   if (j >= MAXSTR) then error('Command line argument too large');
  589.   c := ord(parms[i]);
  590.   case c of
  591.   BLANK,TAB,ENDSTR: begin
  592.    if inarg then begin
  593.     j := j + 1;
  594.     oneparm[j] := ENDSTR;
  595.     if sparg then
  596.      expparm(oneparm)
  597.     else
  598.      addarg(oneparm,j,sortptr,FALSE)
  599.    end;
  600.    j := 0;
  601.    inarg := FALSE;
  602.    sparg := FALSE;
  603.    end;
  604.   BACKSLASH: begin  {just pass following char without interpreting it}
  605.    i := i + 1;
  606.    if (parms[i] = chr(ENDSTR)) then goto err;
  607.    j := j + 1;
  608.    oneparm[j] := ord(parms[i]);
  609.    inarg := TRUE;
  610.    end;
  611.   SQUOTE,DQUOTE: begin {whole string of stuff is escaped}
  612.    i := i + 1;
  613.    if (parms[i] = chr(c)) then begin
  614.     j := j + 1;
  615.     oneparm[j] := c;
  616.     end
  617.    else
  618.     while (parms[i] <> chr(c)) do begin
  619.      if (parms[i] = chr(ENDSTR)) then goto err;
  620.      j := j + 1;
  621.      oneparm[j] := ord(parms[i]);
  622.      i := i + 1;
  623.     end;
  624.    inarg := TRUE;
  625.    end;
  626.   LBRACE,RBRACE: begin
  627.    if inarg then goto normchar;  {forget it if not leading character}
  628.    i := i + 1;
  629.    if (ord(parms[i]) in [BLANK,TAB,ENDSTR]) then
  630.     error('Re-direction syntax error');
  631.    l := 0;
  632.    while (not (ord(parms[i]) in [BLANK,TAB,ENDSTR])) do begin
  633.     l := l + 1;
  634.     fname[l] := parms[i];
  635.     i := i + 1;
  636.    end;
  637.    fname[0] := chr(l);
  638.    if c = LBRACE then begin
  639.     close (input);
  640.     assign(input, fname);
  641.     reset (input);
  642.     end
  643.    else begin
  644.     close (output);
  645.     assign(output, fname);
  646.     rewrite(output);
  647.     for l := 1 to ord(fname[0]) do {convert to lower case for compares}
  648.      if (fname[l] in ['A'..'Z'])
  649.       then fname[l] := chr(ord(fname[l]) + 32);
  650.     fname[0] := chr(3);
  651.     if (fname = 'lpt') or (fname = 'prn') then
  652.      outpflag := STDPRT
  653.     else if (fname <> 'con') then
  654.      outpflag := STDFILE;
  655.     end;
  656.    end;
  657.   STAR,QUESTION: begin {special expand characters found}
  658.    sparg := TRUE;
  659.    goto normchar;
  660.    end;
  661.   OTHERWISE
  662. normchar:
  663.    inarg := TRUE;
  664.    j := j + 1;
  665.    oneparm[j] := c;
  666.   end; {of case, that is}
  667.   i := i + 1;
  668.  end; {of while}
  669.  return;
  670.  
  671.  err: error('Command line syntax error');
  672. end;
  673.  
  674. END.
  675. -h- message.pr 373
  676. {$debug-}
  677. MODULE MMESSAGE;
  678.  
  679. {$include:'globcons.inc'}
  680. {$include:'globtyps.inc'}
  681. {$include:'putcf.dcl'}
  682.  
  683. { message (PC) - write message to terminal and return }
  684. { note: string is not terminated by normal ENDSTR delimiter }
  685. procedure message (const s : lstring);
  686. var
  687.  i : integer;
  688. begin
  689.  for i := 1 to ord(s[0]) do putcf(ord(s[i]),STDERR);
  690.  putcf(NEWLINE,STDERR);
  691. end;
  692.  
  693. END.
  694. -h- nargs.pr 243
  695. {$debug-}
  696. MODULE MNARGS;
  697.  
  698. {$include:'globcons.inc'}
  699. {$include:'globtyps.inc'}
  700.  
  701. { nargs (PC) -- return number of arguments }
  702. function nargs : integer;
  703. var
  704.  parmcnt [extern] : integer;
  705. begin
  706.  { this is a hard one }
  707.  nargs := parmcnt;
  708. end;
  709.  
  710. END.
  711. -h- open.pr 1122
  712. {$debug-}
  713. MODULE MOPEN;
  714.  
  715. {$include:'globcons.inc'}
  716. {$include:'globtyps.inc'}
  717.  
  718. { open (PC) -- open a file for reading or writing }
  719. function open (var name : sstring; xmode : integer) : filedesc;
  720. var
  721.  openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
  722.  i : integer;
  723.  intname :packed array[1..MAXFN] of char;
  724.  found : boolean;
  725. begin
  726.  i := 1;
  727.  while (name[i] <> ENDSTR) do begin
  728.   intname[i] := chr(name[i]);
  729.   i := i + 1
  730.  end;
  731.  for i := i to MAXFN do
  732.   intname[i] := ' '; { pad name with blanks }
  733.  { find a free slot in openlist }
  734.  open := IOERROR;
  735.  found := false;
  736.  i := 1;
  737.  while (i <= MAXOPEN) and (not found) do begin
  738.   if (openlist[i].mode = IOAVAIL) then with openlist[i] do begin
  739.    mode := xmode;
  740.    cpos := 0;
  741.    new(buf);
  742.    buf^ := NULL;
  743.    new(filevar);
  744.    filevar^.trap := TRUE;  {catch file open failure}
  745.    assign(filevar^, intname);
  746.    if (mode = IOREAD) then
  747.     reset(filevar^)
  748.    else
  749.     rewrite(filevar^);
  750.    open := i;
  751.    found := true;
  752.    if filevar^.errs <> 0 then open := IOERROR;
  753.    filevar^.trap := FALSE; {reset so we will exit on i/o error}
  754.   end;
  755.   i := i + 1
  756.  end
  757. end;
  758.  
  759. END.
  760. -h- putc.pr 649
  761. {$debug-}
  762. MODULE MPUTC;
  763.  
  764. {$include:'globcons.inc'}
  765.   MAXLLEN = 100;
  766. {$include:'globtyps.inc'}
  767. {$include:'flush.dcl'}
  768.  
  769. { putc (PC) -- put one character on standard output }
  770. { This is a fast version which actually buffers the character until a }
  771. { newline character is received }
  772.  
  773. procedure putc (c : character);
  774. var
  775.  openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
  776. begin
  777.  with openlist[STDOUT] do begin
  778.   if c = NEWLINE then begin
  779.    writeln(buf^);
  780.    buf^ := NULL;
  781.   end
  782.   else begin
  783.    buf^[0] := chr(ord(buf^[0]) + 1);
  784.    buf^[ord(buf^[0])] := chr(c);
  785.    if ord(buf^[0]) > MAXLLEN then flush(STDOUT);
  786.   end;
  787.  end;
  788. end;
  789.  
  790. END.
  791. -h- putcf.pr 618
  792. {$debug-}
  793. MODULE MPUTCF;
  794.  
  795. {$include:'globcons.inc'}
  796.   MAXLLEN = 100;
  797. {$include:'globtyps.inc'}
  798. {$include:'putc.dcl'}
  799. {$include:'flush.dcl'}
  800.  
  801. { putcf (PC) -- put a single character on file fd }
  802. procedure putcf (c : character; fd : filedesc);
  803. var
  804.  openlist [extern] : array [STDIN..MAXOPEN] of ioblock; { open files }
  805. begin
  806.  if (fd = STDOUT) then
  807.   putc(c)
  808.  else with openlist[fd] do begin
  809.   if c = NEWLINE then begin
  810.    writeln(filevar^,buf^);
  811.    buf^ := NULL;
  812.   end
  813.   else begin
  814.    buf^[0] := chr(ord(buf^[0]) + 1);
  815.    buf^[ord(buf^[0])] := chr(c);
  816.    if ord(buf^[0]) > MAXLLEN then flush(fd);
  817.   end;
  818.  end;
  819. end;
  820.  
  821. END.
  822. -h- putstr.pr 308
  823. {$debug-}
  824. MODULE MPUTSTR;
  825.  
  826. {$include:'globcons.inc'}
  827. {$include:'globtyps.inc'}
  828. {$include:'putcf.dcl'}
  829.  
  830. { putstr (PC) -- put out string on file }
  831. procedure putstr (var s : sstring; f : filedesc);
  832. var
  833.  i : integer;
  834. begin
  835.  i := 1;
  836.  while (s[i] <> ENDSTR) do begin
  837.   putcf(s[i], f);
  838.   i := i + 1
  839.  end
  840. end;
  841.  
  842. END.
  843. -h- remove.pr 532
  844. {$debug-}
  845. MODULE MREMOVE;
  846.  
  847. {$include:'globcons.inc'}
  848. {$include:'globtyps.inc'}
  849.  
  850. { remove (PC) -- remove file s from file system }
  851. procedure remove (var name : sstring);
  852. var
  853.  discfil : text;
  854.  i : integer;
  855.  intname : packed array [1..MAXFN] of char;
  856. begin
  857.  i := 1;
  858.  while (name[i] <> ENDSTR) do begin
  859.   intname[i] := chr(name[i]);
  860.   i := i + 1;
  861.  end;
  862.  for i := i to MAXFN do
  863.   intname[i] := ' ';  { pad name with blanks }
  864.  { open file, so we can discard it }
  865.  assign(discfil, intname);
  866.  reset (discfil);
  867.  discard(discfil);
  868. end;
  869.  
  870. END.
  871.