head     56.3;
access   paws bayes jws quist brad dew jwh;
symbols  ;
locks    ; strict;
comment  @# @;


56.3
date     93.01.27.13.33.44;  author jwh;  state Exp;
branches ;
next     56.2;

56.2
date     93.01.27.12.10.11;  author jwh;  state Exp;
branches ;
next     56.1;

56.1
date     91.11.05.09.31.37;  author jwh;  state Exp;
branches ;
next     55.1;

55.1
date     91.08.25.10.09.43;  author jwh;  state Exp;
branches ;
next     54.1;

54.1
date     91.03.18.15.17.23;  author jwh;  state Exp;
branches ;
next     53.1;

53.1
date     91.03.11.19.17.55;  author jwh;  state Exp;
branches ;
next     52.1;

52.1
date     91.02.19.09.03.07;  author jwh;  state Exp;
branches ;
next     51.1;

51.1
date     91.01.30.16.02.16;  author jwh;  state Exp;
branches ;
next     50.1;

50.1
date     90.10.29.16.15.50;  author jwh;  state Exp;
branches ;
next     49.1;

49.1
date     90.08.14.14.04.10;  author jwh;  state Exp;
branches ;
next     48.1;

48.1
date     90.07.26.11.09.55;  author jwh;  state Exp;
branches ;
next     47.1;

47.1
date     90.05.14.10.48.02;  author dew;  state Exp;
branches ;
next     46.1;

46.1
date     90.05.07.08.35.53;  author jwh;  state Exp;
branches ;
next     45.1;

45.1
date     90.04.19.15.42.46;  author jwh;  state Exp;
branches ;
next     44.1;

44.1
date     90.04.01.22.00.43;  author jwh;  state Exp;
branches ;
next     43.1;

43.1
date     90.03.20.13.50.36;  author jwh;  state Exp;
branches ;
next     42.1;

42.1
date     90.01.23.17.36.07;  author jwh;  state Exp;
branches ;
next     41.1;

41.1
date     89.12.22.11.18.16;  author jwh;  state Exp;
branches ;
next     40.2;

40.2
date     89.12.11.08.38.49;  author jwh;  state Exp;
branches ;
next     40.1;

40.1
date     89.09.29.11.41.12;  author jwh;  state Exp;
branches ;
next     39.1;

39.1
date     89.09.26.16.26.38;  author dew;  state Exp;
branches ;
next     38.1;

38.1
date     89.08.29.11.17.04;  author jwh;  state Exp;
branches ;
next     37.3;

37.3
date     89.08.12.18.00.50;  author jwh;  state Exp;
branches ;
next     37.2;

37.2
date     89.08.12.17.13.33;  author jwh;  state Exp;
branches ;
next     37.1;

37.1
date     89.05.12.11.30.30;  author dew;  state Exp;
branches ;
next     36.1;

36.1
date     89.02.06.10.09.25;  author dew;  state Exp;
branches ;
next     35.1;

35.1
date     89.02.02.13.21.00;  author dew;  state Exp;
branches ;
next     34.1;

34.1
date     89.01.23.15.56.16;  author jwh;  state Exp;
branches ;
next     33.1;

33.1
date     89.01.16.11.31.25;  author dew;  state Exp;
branches ;
next     32.1;

32.1
date     89.01.10.11.37.32;  author bayes;  state Exp;
branches ;
next     31.1;

31.1
date     88.12.14.17.58.29;  author bayes;  state Exp;
branches ;
next     30.1;

30.1
date     88.12.09.13.36.46;  author dew;  state Exp;
branches ;
next     29.1;

29.1
date     88.10.31.15.20.48;  author bayes;  state Exp;
branches ;
next     28.1;

28.1
date     88.10.06.10.50.11;  author dew;  state Exp;
branches ;
next     27.1;

27.1
date     88.09.29.11.16.05;  author bayes;  state Exp;
branches ;
next     26.1;

26.1
date     88.09.28.12.34.02;  author bayes;  state Exp;
branches ;
next     25.1;

25.1
date     88.03.02.09.10.38;  author bayes;  state Exp;
branches ;
next     24.3;

24.3
date     88.02.08.14.55.45;  author brad;  state Exp;
branches ;
next     24.2;

24.2
date     88.02.08.10.01.14;  author brad;  state Exp;
branches ;
next     24.1;

24.1
date     87.08.31.09.21.32;  author jws;  state Exp;
branches ;
next     23.1;

23.1
date     87.08.26.09.57.57;  author bayes;  state Exp;
branches ;
next     22.1;

22.1
date     87.08.17.10.38.47;  author bayes;  state Exp;
branches ;
next     21.1;

21.1
date     87.08.12.13.26.10;  author bayes;  state Exp;
branches ;
next     20.1;

20.1
date     87.07.30.10.36.44;  author bayes;  state Exp;
branches ;
next     19.1;

19.1
date     87.06.01.07.55.01;  author jws;  state Exp;
branches ;
next     18.1;

18.1
date     87.05.20.14.49.31;  author bayes;  state Exp;
branches ;
next     17.1;

17.1
date     87.04.30.10.07.09;  author jws;  state Exp;
branches ;
next     16.1;

16.1
date     87.04.26.15.21.24;  author jws;  state Exp;
branches ;
next     15.1;

15.1
date     87.04.13.08.47.51;  author jws;  state Exp;
branches ;
next     14.2;

14.2
date     87.04.07.09.53.30;  author jws;  state Exp;
branches ;
next     14.1;

14.1
date     87.04.01.14.45.36;  author jws;  state Exp;
branches ;
next     13.1;

13.1
date     87.02.28.18.09.22;  author jws;  state Exp;
branches ;
next     12.1;

12.1
date     87.02.02.12.56.20;  author jws;  state Exp;
branches ;
next     11.1;

11.1
date     87.01.19.09.22.46;  author jws;  state Exp;
branches ;
next     10.1;

10.1
date     86.12.24.10.28.58;  author jws;  state Exp;
branches ;
next     9.1;

9.1
date     86.12.12.13.52.13;  author bayes;  state Exp;
branches ;
next     8.1;

8.1
date     86.11.27.11.26.31;  author jws;  state Exp;
branches ;
next     7.1;

7.1
date     86.11.20.13.13.47;  author hal;  state Exp;
branches ;
next     6.2;

6.2
date     86.11.19.15.55.16;  author bayes;  state Exp;
branches ;
next     6.1;

6.1
date     86.11.04.17.15.18;  author paws;  state Exp;
branches ;
next     5.1;

5.1
date     86.10.28.16.03.34;  author hal;  state Exp;
branches ;
next     4.3;

4.3
date     86.10.28.11.29.27;  author hal;  state Exp;
branches ;
next     4.2;

4.2
date     86.10.08.12.14.38;  author hal;  state Exp;
branches ;
next     4.1;

4.1
date     86.09.30.19.16.28;  author hal;  state Exp;
branches ;
next     3.1;

3.1
date     86.09.01.11.28.08;  author hal;  state Exp;
branches ;
next     2.1;

2.1
date     86.07.30.14.19.37;  author hal;  state Exp;
branches ;
next     1.1;

1.1
date     86.06.30.13.48.56;  author danm;  state tmp;
branches ;
next     ;


desc
@Base file for PWS 3.2 release.

@


56.3
log
@
pws2rcs automatic delta on Wed Jan 27 13:14:25 MST 1993
@
text
@			{file SCANNER}

implement

var
  inoption,skipping,ccinif: boolean;
  effectivelinestart,sentinel: shortint;
  chsave: char;
  linecount,linespp: integer;
  pagecount: shortint;
  ch: char; ok: boolean;
  curerr: shortint;
  errarray: array[1..maxerrors] of record
				    errnum: shortint;
				    errloc: cursrange
				   end;
  esckey: string[6];

const
  bufsize = 110;

  eol = chr(13);

procedure IDSEARCH(var id: alpha; var symbuf: symbufarray); external;

procedure bcd_real $ALIAS 'ASM_BCD_REAL'$
		      (var bcd_str: bcd_strtype;
		       var rval: real); external;

function uniquenumber: shortint;
  begin
  uniquenum := uniquenum + 1;
  uniquenumber := uniquenum;
  end;

PROCEDURE ERROR (ERRORNUM: SHORTINT);
  VAR
    CH: CHAR;
    i,ERRSTART,line2: INTEGER;
    A: PACKED ARRAY [0..bufsize*2] OF CHAR;

    message_index: file of shortint;
    message_file: file of char;
    file_index: shortint;
    message: string[100];
  const
    messages = '*MESSAGES';
  BEGIN
  totalerrors:=totalerrors+1;
  syntxerr := true;
  WRITELN(OUTPUT);
  IF LINESTART < 2 THEN
    errstart := linestart
  ELSE
    ERRSTART := SCAN(-(LINESTART-1),=EOL,SYMBUF[LINESTART-2])+LINESTART-1;
  if (symcursor-errstart) > (bufsize*2) then
    errstart := symcursor - bufsize*2;
$ALLOW_PACKED ON$
  MOVELEFT(SYMBUF[ERRSTART],A,SYMCURSOR-ERRSTART);
$ALLOW_PACKED OFF$
  if a[0] = chr(16{DLE}) then
    begin a[0] := ' '; a[1] := ' '; end;
  line2 := linestart-errstart;
  if a[line2] = chr(16{DLE}) then
    begin
    a[line2] := ' ';
    a[line2+1] := ' ';
    end;
  for i := 0 to SYMCURSOR-ERRSTART-1 do
    if a[i] = chr(13) then writeln(output)
    else
      WRITE(OUTPUT,A[i]);
  WRITELN(OUTPUT,' <<<<');
  WRITELN(OUTPUT,'Line ',linenumber+1:1,', error ',ERRORNUM:1);

  reset(message_index,messages);
  if ioresult = ord(inoerror) then
    begin
    open(message_index);
    seek(message_index,errornum);
    read(message_index,file_index);
    close(message_index);
    if file_index <> 0 then { bad error number }
      begin
      open(message_file,messages);
      seek(message_file,file_index);
      read(message_file,ch);
      setstrlen(message,ord(ch));
      for i := 1 to ord(ch) do
	read(message_file,message[i]);
      writeln(output,message);
      end;
    end;

  if initlistmode=listnone then
    begin
    if streaming then escape(-1);
    if ftype = norml then
      begin
      if kbdtype=itfkbd then
	esckey:='esc'
      else
	esckey:='sh-exc';
      write(output,'<sp>=continue, <'+esckey+'>=terminate, E=edit ',chr(7));
      read(keyboard,ch); writeln(output);
      if (ch = 'E') or (ch = 'e') then
	with userinfo^ do
	  begin
	  errnum := errornum;
	  errblk := symblk;
	  if errornum = 99 then
	    errsym := gsymcursor-1
	  else errsym := symcursor;
	  errfid := sourceinfoptr^[srcindex].filename;
	  end;
      if ch in ['e','E',chr(27)] then escape(0);
      end
    else { ftype = specil }
      begin
      write(output,'Error in interface text: <sp>=continue',chr(7));
      read(keyboard,ch); writeln(output);
      if ch = chr(27) then escape(0);
      end;
    end;
  if listopen and (curerr < maxerrors) then
    begin
    curerr:=curerr+1;
    errarray[curerr].errnum:=errornum;
    errarray[curerr].errloc:=symcursor-linestart;
    end;
  END (*ERROR*) ;

procedure errorwithinfo(*errornum: shortint; infostring: string80*);
  {emit error with a line of additional information}
  begin writeln(output); write(output,infostring);
    if list <> listnone then
      begin incrlinecount; writeln(lp,infostring) end;
    error(errornum);
  end;

procedure warning(linenum: integer; infostring: string80);
  begin
  totalwarnings := totalwarnings + 1;
  if warn then
    begin
    writeln(output);
    write(output,'***WARNING (line',linenum:5,'): ',infostring);
      if list <> listnone then
	begin
	incrlinecount;
	writeln(lp,'***WARNING: (line',linenum:5,'): ',infostring);
	end;
    end;
  end;

function opensource (fname: fid; srclevel: shortint; must: boolean)
		     : boolean;
  {Open file "SOURCE" to access given name; returns TRUE if successful}
  {Puts fname into sourceinfoptr^[srclevel].filename}
  {If MUST = true, wait for file to be inserted}
  var
    ok,done: boolean;
    ch: char;
  begin
  sourceinfoptr^[srclevel].filename := fname;
  done := true;   {no prompt first time thru}
  repeat
    if not done then            {Prompt for file if not first try}
      if streaming then
	begin
	error(401);
	escape(-1);
	end
      else
	begin writeln(output);
	write(output,'Mount ',fname,' and press <space> ',chr(7));
	read(keyboard,ch); writeln(output);
	if ch = chr(27) then escape(0);
	end;
      close(source);                              {Ensure source is closed}
      reset(source, fname,'SHARED');
      if IORESULT = ord(inofile) then                  {Try appending .TEXT}
      if strlen(fname) + 5 <= strmax(fname) then
	begin
	reset(source,fname + '.TEXT','SHARED');
	sourceinfoptr^[srclevel].filename :=
				 fname + '.TEXT';
	end;
    ok := (IORESULT = ord(inoerror));
    if ok then done := true
    else if must then done := false     {Always retry if MUST}
    else done := not (IORESULT in
      [ord(ibadunit),ord(ilostunit),ord(inounit)]);     {else, only retry NO-VOL errs}
  until done;
  opensource := ok;
  if ok then
    with fibp(addr(source))^ do
      if (fkind = textfile) or (fkind = codefile)  then
	begin
	am := amtable^[untypedfile];
	fleof := fleof + (-fleof) mod pagesize;
	end;
  end; {opensource}

procedure setlinewidth;
  { insert end-of-line sentinel based on width option }
  begin
  effectivelinestart := linestart;
  while symbuf[symcursor] = CHR(16(*DLE*)) do
    begin   { strip off blank compression }
    effectivelinestart :=
      effectivelinestart + 2 - (ord(symbuf[symcursor+1])-ord(' '));
    symcursor := symcursor+2;
    end;
  { set marker at effective end-of-line }
  sentinel := effectivelinestart+width;
  if sentinel > maxcursor then sentinel := maxcursor;
  chsave := symbuf[sentinel];
  symbuf[sentinel] := eol;
  { remove leading blanks }
  symcursor := symcursor+scan(80,<>' ',symbuf[symcursor])
  end;

procedure fixupend;
  { erase effect of SETLINEWIDTH before printing line.
    Advance cursor to actual end of line }
  begin symbuf[sentinel] := chsave;
  while symbuf[symcursor] <> eol do symcursor := symcursor+1;
  end;

PROCEDURE GETNEXTPAGE;
  label 1;
  BEGIN
  gsymcursor := symcursor;
  SYMCURSOR := 0; LINESTART := 0;
  repeat
    with fibp(addr(source))^ do
      begin
      filepos := fpos;
      if fkind in [textfile,codefile] then
	begin
	if fpos < fleof then
	  begin
	  freadbytes(source,symbuf,
		       min(pagesize,fleof-fpos));
	  if ioresult = ord(inoerror) then goto 1
	  else escape(-10);
	  end;
	end
      else
	if not eof(source) then
	  begin
	  any_to_UCSD(source,symbuf);
	  if ioresult = ord(inoerror) then goto 1
	  else escape(-10);
	  end;
      end;
    {End of file reached}
    if srcindex <= 1 then             {end of original source file}
      begin
      symbuf[0] := eol;
      if not endofprog then
	begin
	printlastline := true;
	ERROR(99);
	end
      else printlastline := false;
      escape(0);
      end;
    srcindex := srcindex-1;           {end of include file}
    with sourceinfoptr^[srcindex] do      {restore state of previous file}
      begin
      if not opensource(filename,srcindex,true) then
	escape(0);
      filepos := oldfilepos;
      with fibp(addr(source))^ do
	begin
	fpos := filepos;
	end;
      symblk := oldsymblk-2;
      relinum := oldrelinum;
      SYMCURSOR := OLDSYMCURSOR; LINESTART := OLDLINESTART;
      ftype := oldftype;
      end;
    until false;
1:setlinewidth;
  symblk := symblk + 2;
  symbolstart := symcursor;
  END (*GETNEXTPAGE*) ;

procedure incrlinecount;
  begin
  linecount:=linecount+1;
  if (linecount>linespp) or (linecount=maxint) then
    begin
    if pagecount>0 then page(lp);
    pagecount:=pagecount+1;
    writeln(lp,compilername,' [Rev ',crevno,' ',
      crevid.month:2,'/',crevid.day:2,'/',
      crevid.year:2,'] ',fibp(addr(source))^.ftid,
      ' ':24-strlen(fibp(addr(source))^.ftid),
      todaysdate,' ',timestring,' Page ',pagecount:1);
    writeln(lp);
    linecount:=1
    end;
  end;

PROCEDURE PRINTLINE;
  { Print just-completed source line on listing }
  const
    prefixwidth = 19; { width of line prefix + 1}
  VAR
    DORC,STARORC: CHAR;
    LENG,offset,i,posonpage,curleng: INTEGER;
    A: PACKED ARRAY [0..bufsize] OF CHAR;

  procedure printexcessA;
    {print string A[0..pagewidth-1] on listing
     while length(A) exceeds pagewidth}
    begin
    posonpage := prefixwidth+offset;
    if posonpage>pagewidth then
      begin writeln; error(601);
      incrlinecount; posonpage := 1;
      end;
    while posonpage+leng-1 > pagewidth do
      begin curleng := pagewidth-posonpage+1;
      writeln(lp,a:curleng);
      leng := leng-curleng;
$ALLOW_PACKED ON$
      moveleft(a[curleng],a,leng);
$ALLOW_PACKED OFF$
      posonpage := 1;
      incrlinecount;
      end;
    end;

  function blankline : boolean;
    var
      leng: shortint;
    begin
    leng := symcursor - linestart - 1;
    if symbuf[linestart] = chr(16(*DLE*)) then
      leng := leng - 2;
    blankline := leng = 0;
    end;

  BEGIN { printline }
  IF BPTONLINE THEN STARORC := '*' else STARORC := ':';
  incrlinecount;
  WRITE(lp,linenumber:6,STARORC);
  if skipping or blankline then
    WRITE(lp,'S','':10)
  else IF oldDP THEN
    if lc <> 0 then
      WRITE(lp,'D',lc:6,levelatstart+linlevatstart:3,' ')
    else
      WRITE(lp,'D','':6,levelatstart+linlevatstart:3,' ')
  else
    WRITE(lp,'C','':6,levelatstart+linlevatstart:3,' ')
      ;
  LENG := SYMCURSOR-LINESTART;
  { NB: LENG includes the trailing EOL char, therefore LENG>=1 }
  IF LENG > bufsize THEN LENG := bufsize;
$ALLOW_PACKED ON$
  MOVELEFT(SYMBUF[LINESTART],A,LENG);
$ALLOW_PACKED OFF$
  IF A[0] = CHR(16(*DLE*)) THEN
    BEGIN
    offset := ORD(A[1])-ORD(' ');
    IF offset>0 THEN
      WRITE(lp,' ':offset);
    LENG := LENG-2;
$ALLOW_PACKED ON$
    MOVELEFT(A[2],A,LENG)
$ALLOW_PACKED OFF$
    END
  else offset:=2;       {adjusts for linestart not pointing at DLE}
  printexcessA;
  WRITELN(lp,A:LENG-1);         {-1 to remove EOL}
  IF curerr>0 then
    begin
    fillchar(a,bufsize+1,' ');
    leng := 0;
    for i:=1 to curerr do
      with errarray[i] do
	begin
	a[errloc]:='^';
	if errloc >= leng then leng := errloc+1;
	end;
    leng := leng-3;
$ALLOW_PACKED ON$
    moveleft(A[3],A,leng);
$ALLOW_PACKED OFF$
    incrlinecount; write(lp,' ':prefixwidth+offset-1);
    printexcessA; writeln(lp,a:leng);
    incrlinecount;
    WRITE(lp,'>>>>>> Error at ',fibp(addr(source))^.ftid,'/',relinum:1,
	     ':  ',errarray[1].errnum:1);
    for i:=2 to curerr do
      write(lp,', ',errarray[i].errnum:1);
    if lasterrln <> 0 then write(lp,'   (see also ',lasterrln:1,')');
    writeln(lp);
    if list = listerronly then
      begin incrlinecount; writeln(lp) end;
    curerr:=0; lasterrln := linenumber;
    end;
  if ioresult <> ord(inoerror) then
    begin
    listabort := true;
    list := listnone;
    listopen := false;
    warning(linenumber,'Listing aborted');
    end;
  END (*PRINTLINE*);

procedure buildreal(*inputstr: string80; var realval: real*);
  var
    bcd_str: bcd_strtype;
    i,mantissa_digit,extraexponent,exponentsign: shortint;
    inexponent,decpnt: boolean;
  begin
    with bcd_str do
      begin
      decpnt := false;
      exponent := 0;
      extraexponent := 0;
      inexponent := false;
      exponentsign := 1;
      mantissa_digit := 1;
      for i := 1 to 16 do mantissa[i] := 0;
      for i := 1 to strlen(inputstr) do
	begin
	if (inputstr[i] >= '0') and (inputstr[i] <= '9') then
	  if inexponent then exponent := exponent*10 +
					 (ord(inputstr[i]) - ord('0'))
	  else
	    begin
	    if decpnt then
	      begin
	      if (mantissa_digit = 1) and
		 (inputstr[i] = '0') then
		extraexponent := extraexponent-1;
	      end;
	    if (mantissa_digit > 1) or
	       (inputstr[i] <> '0') then
	      begin
	      if (mantissa_digit <= 16) then
		mantissa[mantissa_digit] := ord(inputstr[i]) - ord('0');
	      mantissa_digit := mantissa_digit + 1;
	      end;
	    end
	else if inputstr[i] = '+' then
	  if inexponent then exponentsign := 1
	  else signbit := pls
	else if inputstr[i] = '-' then
	  if inexponent then exponentsign := -1
	  else signbit := mnus
	else if inputstr[i] = '.' then
	  begin
	  extraexponent := mantissa_digit-1;
	  decpnt := true;
	  end
	else if inputstr[i] = 'E' then
	  begin
	  if not decpnt then
	    extraexponent := mantissa_digit-1;
	  inexponent := true;
	  end;
	end;
      exponent := exponent * exponentsign + extraexponent;
      try
	bcd_real(bcd_str,realval);
      recover
	if escapecode = -19 then error(50)
	else escape(escapecode);
      end;
  end; { buildreal }

procedure newident(*var namep: alphaptr; newid: alpha*);
  {Put identifier string in heap, return ptr to it}
  begin
  newwords(namep, (strlen(newid)+2) div 2);
  namep^ := newid;
  end;

procedure upc(var s: string);
  var
    i: shortint;
  begin
  for i := 1 to strlen(s) do
    if (s[i] >= 'a') and (s[i] <= 'z') then
      s[i] := chr(ord(s[i])-32);
  end;

PROCEDURE INSYMBOL;
  { Fetch next source token. Also produces listing when an EOL is crossed. }
  { Handles all 'control comments'. }
  LABEL 1;
  const tab = 9;
  var btemp: boolean;

  PROCEDURE CHECKEND;
  var
    blocks_read : integer;

  BEGIN (* CHECKS FOR THE END OF THE PAGE *)
  fixupend;
  try
    $ovflcheck on$
    SCREENDOTS := SCREENDOTS+1
    $if not ovflchecking$
      $ovflcheck off$
    $end$
  recover
    if escapecode = -4 then screendots := 1
    else escape(escapecode);
  linenumber := linenumber+1;
  if linenumber > 65534 then
    linenumber := 0;
  relinum := relinum+1;
  SYMCURSOR := SYMCURSOR + 1;
  IF ((SCREENDOTS-STARTDOTS) MOD 5 = 0)
     and not beforefirsttoken THEN
    WRITE(OUTPUT,'.');
  IF (LIST=listfull) or listopen and (curerr>0) THEN PRINTLINE;
  BPTONLINE := FALSE;
  levelatstart := level;
  linlevatstart := linelevel;
  IF (symcursor > maxcursor) or
     (SYMBUF[SYMCURSOR]=CHR(0)) THEN GETNEXTPAGE
  ELSE if (symbuf[symcursor] = chr(3)) and
	  (ftype = specil) then
    begin
    srcindex := srcindex - 1;
    with sourceinfoptr^[srcindex] do
      begin
      if not opensource(filename,srcindex,true) then
	 escape(0);
      filepos := oldfilepos;
      symblk := oldsymblk;
      relinum := oldrelinum;
      ftype := oldftype;
      with fibp(addr(source))^ do
	begin
	fpos := filepos;
	if fkind in [textfile,codefile] then
	  if fpos < fleof then
	    freadbytes(source,symbuf,pagesize)
	  else escape(-8)
	else
	  if eof(source) then escape(-8)
	  else any_to_UCSD(source,symbuf);
	end;
      if ioresult <> ord(inoerror) then escape(-10);
      symcursor := oldsymcursor;
      symbolstart := symcursor;
      linestart := oldlinestart;
      if ftype = norml then
	begin
	list := gtemplist;
	linenumber := gtemplinenumber;
	width := gtempwidth;
	if putcode = false then putcode := temp_put;
	end;
      setlinewidth;
      end;
    end
  else
    begin LINESTART := SYMCURSOR; setlinewidth end;
  oldDP := DP;
  END; (*CHECKEND*)

  procedure option;
    var
      optionname: optionlist;
      ltitle: fid;
      lid: alpha;
      btemp,done: boolean;
      lvid: vid;
      ltid: fid;
      i,lsegs,ior: integer;
      lkind: filekind;
      s: string[10];

    procedure eatspaces;
      begin
      while symbuf[symcursor]=' ' do symcursor:=symcursor+1;
      end;

    function sw: boolean;
      { look for identifier in input,
	determine if it is 'ON' or OFF' }

      begin {sw}
      sw := true;
      if sy = ident then
	begin
	upc(id);
	if id = 'OFF' then sw := false
	else if id <> 'ON' then error(6);
	insymbol; { advance past the symbol }
	end;
      end;

    function getinteger: integer;
      var lsp: stp; lvalu: valu; oldexp: exptr;
      begin
      oldexp := curexp;
      constant([dollarsy,comma,semicolon],lsp,lvalu);
      curexp := oldexp;
      if lsp <> intptr then begin error(50); getinteger := 0 end
      else getinteger := lvalu.ival;
      end;

    procedure gettitle(var s: string);
      { convert pa of char constant val.valp^ to string }
      begin s[0] := chr(0);
      if sy <> stringconst then error(648)
      else
	if val.intval then
	  begin
	  s[0] := chr(1);
	  s[1] := chr(val.ival);
	  end
	else with val.valp^ do
	  begin
	  if slgth > strmax(s) then error(648)
	  else
	    begin s[0] := chr(slgth);
	    moveleft(sval,s[1],slgth);
	    end;
	  end;
      insymbol;
      end;

    procedure getoptionname;
      var loptionname: optionlist;
	  svskip,found: boolean;

      begin svskip := skipping; skipping := false;
      insymbol;
      if sy = ifsy then (*** kLuGe ***)
	begin sy := ident; id := 'IF' end
      else if sy = endsy then
	begin sy := ident; id := 'END' end;
      if sy <> ident then
	begin loptionname := emptyop;
	if not(sy in [semicolon,comma]) then
	  begin error(6);
	  skip([dollarsy,semicolon,comma]);
	  end;
	end
      else
	begin {search in option array}
	loptionname := aliasop; found:=false;
	while (loptionname < illegal) and (not found) do
	  if id = optionarray[loptionname] then found:=true
	  else loptionname:=succ(loptionname);
	insymbol;
	end;
      skipping := svskip;
      optionname := loptionname;
      end; {getoptionname}

    procedure doinclude;
      {Process a $INCLUDE command}
      var
	tfpos : integer;
      begin
      tfpos := fibp(addr(source))^.fpos;
      gettitle(ltitle);
      if sy <> dollarsy then
	begin error(24); skip([dollarsy]) end;
      IF srcindex >= maxinfiles THEN ERROR(608);
      fixname(ltitle,textfile);
      if opensource(LTITLE,srcindex+1,false) then
	begin
	with sourceinfoptr^[srcindex] do          {save current file info}
	  begin
	  OLDSYMCURSOR := SYMCURSOR;
	  OLDLINESTART := LINESTART;
	  oldfilepos := filepos;
	  oldsymblk := symblk;
	  oldrelinum := relinum;
	  oldftype := ftype;
	  end;
	with fibp(addr(source))^ do
	  if fkind = textfile  then
	    begin
	    filepos := pagesize;
	    fpos := filepos;
	    end
	  else
	    filepos := 0;
	symblk := 0;
	IF (LIST=listfull) or listopen and (curerr>0) then
	  begin        {First listing of include line}
	  fixupend;
	  symcursor := symcursor+1;
	  printline;
	  end;
	srcindex := srcindex+1;
	relinum := 0;
	ftype := norml;
	GETNEXTPAGE;
	end
      ELSE
	begin         {Couldn't open include file}
	ERROR(609);
	if not opensource(sourceinfoptr^[srcindex].filename,srcindex,true) then
	  escape(0)
	else      {restore SOURCE to old file}
	  fibp(addr(source))^.fpos := tfpos;
	end;
      end; {doinclude}

    procedure doccif;
      {Process $IF boolean expression - changed 5/80 to call CONSTANT}
      var
	lsp: stp; lvalu: valu;
	oldexp: exptr; oldinbody: boolean;
      begin
      if ccinif then error(605); {nested $IF}
      ccinif := true;
      oldexp := curexp;
      oldinbody := inbody;
      inbody := true; {allow all op's to be folded}
      $IF fulldump$
	new(lastexp);  {scratch place for exp list}
      $END$
      constant([dollarsy,comma,semicolon],lsp,lvalu);
      inbody := oldinbody;
      curexp := oldexp;
      if lsp <> boolptr then error(135) else skipping := not odd(lvalu.ival);
      end; {doccif}

    procedure refdefop(var fsize: integer;
	defaultsize: integer; var fvolname: string);
      var
	tvolname: string255;
      begin
      if not beforefirsttoken then
	error(600);
      if sy=intconst then
	begin fsize := getinteger;
	if (fsize<0) or (fsize>32767) then
	  begin error(648);
	  fsize := defaultsize;
	  end;
	end
      else
	begin
	gettitle(tvolname);
	if tvolname[strlen(tvolname)] <> ':' then
	  tvolname := tvolname + ':';
	if strlen(tvolname) > strmax(fvolname) then
	  error(648)
	else
	  fvolname := tvolname;
	end;
      end; {refdefop}


    begin {option}
    if stdpasc then error(606);
    inoption := true;
    REPEAT                            {Process a control item}
      getoptionname;
      if skipping then
	begin {Ignore all options except $END}
	if optionname = ccendop then
	  begin skipping := false; ccinif := false end
	else
	  begin
	  if optionname = ccifop then error(605);
	  skipping := false;
	  if optionname in [searchop,overlayop] then
	    skip([dollarsy])
	  else
	    skip([dollarsy,comma,semicolon]);
	  skipping := true;
	  end;
	end
      else
	case optionname of
	  emptyop: ;
	  aliasop:
	    begin
	    if not aliasok then error(621);
	    if indefinesection then
	      error(646);
	    aliasok := false;
	    gettitle(lid);
	    upc(lid);
	    newident(aliasptr,lid);
	    end;
	  allowpacked:
	    allow_packed := sw;
	  ansiop:
	    begin
	    if not beforefirsttoken then error(600);
	    stdpasc := sw;
	    end;
	  callabsop:
	    if sw then gcallmode := abscall
	    else gcallmode := relcall;
	  ccifop:
	    doccif;
	  ccendop:
	    if ccinif then ccinif := false  {end of successful $IF}
	    else error(605);                {not in $IF}
	  codeop:
	    begin
	    if inbody then error(602);
	    putcode := sw;
	    end;
	  copyrightop:
	    gettitle(gcopyright);
	  debugop:
	    begin
	    if inbody then error(602);
	    DEBUGGING := SW;
	    end;
	  defop:
	    refdefop(defilesize,
		     defiledefault,defvolname);
	  floatop:
	    begin
	    if inbody then error(602);
	    float := flt_on;
	    if sy = ident then
	      begin
	      upc(id);
	      if id = 'OFF' then float := flt_off
	      $IF not MC68020$
	      else if id = 'TEST' then float := flt_test
	      $END$
	      else if id <> 'ON' then error(6);
	      insymbol;
	      end;
	    end;
	  heapdisposeop:
	    begin if not beforefirsttoken then error(600);
	    heapdispose := sw;
	    end;
	  inclop:
	    doinclude;
	  iochkop:
	    giocheck := sw;
	  linesop:
	    begin linespp := getinteger;
	    if linespp < 20 then
	      begin error(648); linespp := 20 end;
	    end;
	  listop :
	    if sy = stringconst then
	      begin    { LIST 'filename' }
	      gettitle(ltitle);
	      if (initlistmode <> listnone) and
		 not list_option_L then
		begin
		fixname(ltitle,textfile);
		close(lp,'lock');
		if ioresult <> ord(inoerror) then
		  begin
		  setstrlen(s,0);
		  ior := ioresult;
		  strwrite(s,1,i,ior:1);
		  warning(linenumber,'Error closing listing file, ioresult('+s+')');
		  end;
		rewrite(lp,LTITLE);
		listopen := (IORESULT = ord(inoerror));
		if listopen then
		  begin
		  if initlistmode = listfull then
		    LIST := LISTFULL;
		  end
		else error(400);
		end;
	      end
	    else  {LIST ON/OFF}
	      begin
	      btemp := sw;
	      if initlistmode = listfull then
		if btemp then LIST := listfull
		else LIST := listnone;
	      end;
	  modcalop:
	    $IF allowmodcal$
	      begin modcal := sw;
	      if not beforefirsttoken then error(600);
	      end;
	    $END$
	    $IF not allowmodcal$
	      begin error(649);
	      btemp := sw;
	      end;
	    $END$
	  numop:
	    begin
	    linenumber := getinteger-1;
	    if (linenumber < -1) or
	       (linenumber > 65534) then
	      begin
	      error(614);
	      linenumber := 0;
	      end;
	    end;
	  overlayop:
	    begin
	    if maxoverlays = 0 then
	      begin
	      maxoverlays := overlaydefault;
	      newbytes(overlaylistptr,16*maxoverlays);
	      end;
	    overlaytop := 0;
	    done := false;
	    repeat
	      if sy = stringconst then
		begin
		gettitle(ltitle);
		if strlen(ltitle) > 15 then
		  error(648)
		else
		  begin
		  if overlaytop>=maxoverlays
		    then error(604)
		  else
		    begin
		    upc(ltitle);
		    overlaytop := overlaytop+1;
		    overlaylistptr^[overlaytop] := ltitle;
		    end;
		  end;
		end
	      else error(648);
	      if (sy=comma) or (sy=semicolon) then
		insymbol
	      else if sy = dollarsy then
		done := true
	      else
		begin
		error(6);
		skip([dollarsy,stringconst]);
		end;
	    until done;
	    end;
	  overlaysizeop:
	    begin
	    if not beforefirsttoken then
	      error(600);
	    i := getinteger;
	    if (i < 0) or (i > 32767) then
	      error(648)
	    else
	      if maxoverlays = 0 then
		maxoverlays := i
	      else
		error(649);
	    if maxoverlays <> 0 then
	      newbytes(overlaylistptr,16*maxoverlays);
	    end;
	  ovlfchkop:
	    govflcheck := sw;
	  pageop:
	    if list = listfull then
	      begin  {force a new page}
	      linecount:=linespp; incrlinecount;
	      linecount:=linecount-1     {not really printing a line}
	      end;
	  pagewidthop:
	    begin
	    i:= getinteger;
	    if i < 80 then
	      begin pagewidth := 80; error(648) end
	    else if i > 132 then
	      begin pagewidth := 132; error(648) end
	    else pagewidth := i;
	    end;
	  partevalop:
	    gshortcircuit := sw;
	  PCop:
	    begin
	    if inbody then error(602);
	    listPC := sw;
	    end;
	  rangeop:
	    grangecheck := sw;
	  refop:
	    refdefop(refilesize,
		     refiledefault,refvolname);
	  saveop:
	    saveconst := sw;
	  searchsizeop:
	    begin
	    if not beforefirsttoken then
	      error(600);
	    i := getinteger;
	    if (i < 0) or (i > 32766) then
	      error(648)
	    else
	      if maxsearchfiles = 0 then
		 maxsearchfiles:= i+1
	      else
		error(649);
	    if maxsearchfiles <> 0 then
	      newbytes(searchlistptr,122*maxsearchfiles);
	    searchfilestop := 1;
	    searchlistptr^[searchfilestop]:=syslibrary;
	    end;
	  searchop:
	    begin
	    if maxsearchfiles = 0 then
	      begin
	      maxsearchfiles := searchdefault;
	      newbytes(searchlistptr,122*maxsearchfiles);
	      end;
	    searchfilestop := 0;
	    done := false;
	    repeat
	      if sy = stringconst then
		begin
		gettitle(ltitle);
		fixname(ltitle,codefile);
		if searchfilestop>=maxsearchfiles-1
		  then error(604)
		else
		  begin
		  searchfilestop := searchfilestop+1;
		  searchlistptr^[searchfilestop] := ltitle;
		  end;
		end
	      else error(647);
	      if (sy=comma) or (sy=semicolon) then
		insymbol
	      else if sy = dollarsy then
		done := true
	      else
		begin
		error(6);
		skip([dollarsy,stringconst]);
		end;
	    until done;
	    searchfilestop := searchfilestop+1;
	    searchlistptr^[searchfilestop]:=syslibrary;
	    end;
	  stackchkop:
	    begin
	    if inbody then error(602);
	    gstackcheck := sw;
	    end;
	  strposop:
	    begin
	    switch_strpos := sw;
	    if not beforefirsttoken then
	      error(600);
	    strpos_warn := false;
	    end;
	  sysprogop:
	    begin
	    sysprog := sw;
	    if not beforefirsttoken then
	      error(600);
	    end;
	  tablesop:
	    begin
	    if inbody then error(602);
	    tables := sw;
	    end;
	  ucsdop:
	    begin ucsd := sw;
	    if not beforefirsttoken then error(600);
	    end;
	  warnop:
	    warn := sw;
	  otherwise error(649)
	  END; (*CASES*)
      UNTIL (sy <> semicolon) and (sy <> comma);
    if sy <> dollarsy then begin error(24); skip([dollarsy]) end;
    inoption := false;
    end; {option}


  PROCEDURE COMMENTER;
    var svskip,done: boolean;
    BEGIN
    SYMCURSOR := SYMCURSOR+1; (* POINT TO THE FIRST CHAR PAST "(*" OR "{" *)
    svskip := skipping; skipping := true;    {Mark commented lines as ignored}
    SYMCURSOR := SYMCURSOR-1; (* ADJUST FOR FIRST +1 IN LOOP *)
    done := false;
    REPEAT
      SYMCURSOR := SYMCURSOR+1;
      WHILE SYMBUF[SYMCURSOR] = EOL DO
	begin
	if importexportext then
	  begin
	  symbolstart := symcursor;
	  symcursor := symcursor + 1;
	  outputsymbol;
	  symcursor := symcursor - 1;
	  end;
	CHECKEND;
	end;
      if symbuf[symcursor] = '}' then
	begin done := true; symcursor := symcursor+1 end
      else if symbuf[symcursor] = '*' then
	if symbuf[symcursor+1] = ')' then
	  begin done := true; symcursor := symcursor+2 end;
    UNTIL done;
    skipping := svskip;
    END; (*COMMENTER*)

  PROCEDURE ASTRING;
    LABEL 1;
    VAR TP,cval: INTEGER;
	lvp: csp;
	T: PACKED ARRAY [1..110] OF CHAR;
    BEGIN
    TP := 0;            (* # of characters accumulated *)
    while (symbuf[symcursor]='#') or (symbuf[symcursor]='''') do
      begin
      if symbuf[symcursor]='#' then
	begin
	symcursor := symcursor+1;
	if stdpasc then error(606);
	if symbuf[symcursor] in ['0'..'9'] then
	  begin         {#number}
	  cval := ord(symbuf[symcursor]) - ord('0');
	  symcursor := symcursor+1;
	  while symbuf[symcursor] in ['0'..'9'] do
	    begin
	    $OVFLCHECK on$
	    try
	      cval := cval*10 + ord(symbuf[symcursor]) - ord('0');
	    recover
	      if escapecode = -4 {overflow} then
		cval := 256 { insure syntax error }
	      else
		escape(escapecode);
	    $IF not ovflchecking$
	      $OVFLCHECK off$
	    $END$
	    symcursor := symcursor+1;
	    end;
	  TP := TP+1;
	  if cval > 255 then error(708);
	  T[TP] := chr(cval mod 256);
	  end
	else if (symbuf[symcursor] in ['@@'..'z'])
	  and (symbuf[symcursor] <> '`'{grave}) then
	  begin         {#control char}
	  TP := TP+1;
	  T[TP] := chr(ord(symbuf[symcursor]) mod 32);
	  symcursor := symcursor+1;
	  end
	else   {# followed by something weird}
	  begin symcursor := symcursor+1;
	  error(709);
	  end;
	if inoption then error(6);
	end {#}
      else
	begin {char is '}
	REPEAT
	  REPEAT
	    SYMCURSOR := SYMCURSOR+1;
	    TP := TP+1;
	    T[TP] := SYMBUF[SYMCURSOR];
	    IF SYMBUF[SYMCURSOR] = EOL THEN BEGIN ERROR(660); GOTO 1 END;
	  UNTIL SYMBUF[SYMCURSOR]='''';
	  SYMCURSOR := SYMCURSOR+1;
	UNTIL SYMBUF[SYMCURSOR]<>'''';
      1:TP := TP-1;         (* Take out ending ' *)
	end
      end; {while # or '}
    SYMCURSOR := SYMCURSOR-1;   (* adjust for INSYMBOL's incrementing *)
    SY := STRINGCONST;
    LGTH := TP;
    IF TP=1 THEN        (* SINGLE CHARACTER CONSTANT *)
      with val do begin intval := true; IVAL := ORD(T[1]) end
    ELSE
      begin
      newwords(lvp,(sizeof(constrec,true,paofch)-(strglgth-lgth)+1) div 2);
      WITH lvp^ DO
	BEGIN CCLASS := paofch; SLGTH := TP;
$ALLOW_PACKED ON$
	MOVELEFT(T[1],SVAL[1],TP);
$ALLOW_PACKED OFF$
	END;
      with val do begin intval := false; VALP := lvp end
      end;
    END; (*ASTRING*)

  PROCEDURE NUMBER;
    label 1;
    VAR numstart,expoffset,ISUM,J: INTEGER;
	TIPE: (inttipe,realtipe);
	dummybool: boolean;
	LVP: CSP;
	realtemp: string80;
    BEGIN
    TIPE := inttipe;
    numstart := SYMCURSOR;
    expoffset := 0;
    REPEAT                      {scan over integer part}
      SYMCURSOR := SYMCURSOR+1
    UNTIL (SYMBUF[SYMCURSOR]<'0') OR (SYMBUF[SYMCURSOR]>'9');
    IF SYMBUF[SYMCURSOR]='.' THEN
      { Following line modified 8/12/89 JWH }
      { IF SYMBUF[SYMCURSOR+1]<>'.' THEN }     (* WATCH OUT FOR '..' *)
      IF ((SYMBUF[SYMCURSOR+1]<>'.') AND (SYMBUF[SYMCURSOR+1] <> ')')) THEN
	BEGIN
	TIPE := REALTIPE;
	SYMCURSOR := SYMCURSOR+1;
	WHILE (SYMBUF[SYMCURSOR]>='0') AND (SYMBUF[SYMCURSOR]<='9') DO
	  SYMCURSOR := SYMCURSOR+1;     {scan fractional part}
	END;
    IF SYMBUF[SYMCURSOR] IN ['e','E','l','L'] THEN
      BEGIN
      tipe := realtipe;
      expoffset := symcursor-numstart+1;
      SYMCURSOR := SYMCURSOR+1;
      if stdpasc and
	 (symbuf[symcursor-1] in ['l','L']) then
	error(606);
      IF SYMBUF[SYMCURSOR] IN ['+','-'] THEN SYMCURSOR := SYMCURSOR+1;
      if (symbuf[symcursor] < '0') OR (symbuf[symcursor] > '9') then
	warning(linenumber,
'chars other than 0-9,+,-,E,L in exponent are ambiguous / do not conform to ANSI');
      WHILE (SYMBUF[SYMCURSOR]>='0') AND (SYMBUF[SYMCURSOR]<='9') DO
	SYMCURSOR := SYMCURSOR+1;
      END;
    (* NOW CONVERT TO INTERNAL FORM *)
    IF TIPE=INTTIPE THEN
      BEGIN
     {*********************************************************************

		CONVERT TO RETURN A NEGATIVE REPRESENTATION
		IF UMINUS IS TRUE.  IF UMINUS IS FALSE AND
		THE NUMBER DOESN'T HAVE A POSITIVE REPRESENTATION
		ON THE HARDWARE, GIVE AN ERROR (e.g, 32768 in 16 bits);
		OTHERWISE, RETURN THE POSITIVE NUMBER.

      *********************************************************************}
      SY := INTCONST;
      ISUM := 0;
      try
	$ovflcheck on$
	FOR J := numstart TO symcursor-1 DO
	  ISUM := ISUM*10-(ORD(SYMBUF[J])-ORD('0'));
	$if not ovflchecking$
	  $ovflcheck off$
	$end$
      recover
	if escapecode = -4 then { integer ovfl }
	  error(661)
	else escape(escapecode);
   1: with val do
	begin intval := true;
	if uminus then ival := isum
	else
	  if isum > MININT then ival := -isum
	  else begin ival := 0; error(661) end;
	end;
      END
    ELSE
      BEGIN (* REAL NUMBER HERE *)
      SY := REALCONST;
      NEW(LVP,true,REEL);
      with LVP^ do
	begin CCLASS := REEL;
	j := symcursor-numstart;      {length of number}
	if j > strmax(realtemp) then
	  begin
	  error(680);
	  j := strmax(realtemp);
	  end;
	realtemp[0] := chr(j+1);
	if uminus then realtemp[1] := '-'
	else realtemp[1] := '+';
$ALLOW_PACKED ON$
	moveleft(symbuf[numstart], realtemp[2], j);
$ALLOW_PACKED OFF$
	if expoffset>0 then realtemp[expoffset+1] := 'E';
	if realtemp[strlen(realtemp)] = '.' then
	  error(18);
	buildreal(realtemp,RVAL);
	end;
      with VAL do begin intval := false; VALP := LVP end;
      END; {type real}
    SYMCURSOR := SYMCURSOR-1;   (* adjust for INSYMBOL's incrementing *)
    END; (*NUMBER*)

  BEGIN (* INSYMBOL *)
1:symbolstart := symcursor;
  SY := OTHERSY;        (* IF NO CASES EXERCISED BLOW UP *)
  OP := NOOP;
  CASE SYMBUF[SYMCURSOR] OF
    '''','#':   ASTRING;
    '0'..'9':   NUMBER;
    'A'..'Z','a'..'z':
      begin
      idsearch(id,symbuf);
      if not modcal then
	if sy >= forwardsy then
	  case sy of
	    forwardsy:
	      begin
	      sy := ident; id := 'FORWARD';
	      end;
	    externlsy:
	      begin
	      sy := ident; id := 'EXTERNAL';
	      end;
	    trysy:
	      if not sysprog then
		begin
		sy := ident; id := 'TRY';
		end;
	    recoversy:
	      if not sysprog then
		begin
		sy := ident; id := 'RECOVER';
		end;
	    anyvarsy:
	      if not sysprog then
		begin
		sy := ident; id := 'ANYVAR';
		end;
	    end;
      end;

    '$': begin sy := dollarsy;
	 if not inoption then
	   begin
	   symcursor := symcursor+1;
	   btemp := importexportext;
	   importexportext := false;
	   option;
	   importexportext := btemp;
	   goto 1;
	   end;
	 end;
    '{': BEGIN COMMENTER; GOTO 1 END;
    '(': IF SYMBUF[SYMCURSOR+1]='*' THEN
	   BEGIN SYMCURSOR := SYMCURSOR+1;
	   COMMENTER; GOTO 1;
	   END
	 else if symbuf[symcursor+1] = '.' then
	   begin symcursor := symcursor+1; sy := lbrack end
	 ELSE SY := LPARENT;
    ')': SY := RPARENT;
    ',': SY := COMMA;
    ' ',chr(tab):
	    BEGIN
	    SYMCURSOR := SYMCURSOR+1;
	    if importexportext then outputsymbol;
	    GOTO 1;
	    END;
    '.': IF SYMBUF[SYMCURSOR+1]='.' THEN
	   BEGIN SYMCURSOR := SYMCURSOR+1;
	   SY := rangesy;
	   END
	 else if symbuf[symcursor+1] = ')' then
	   begin symcursor := symcursor+1; sy := rbrack end
	 ELSE SY := PERIOD;
    ':': IF SYMBUF[SYMCURSOR+1]='=' THEN
	   BEGIN SYMCURSOR := SYMCURSOR+1;
	   SY := BECOMES;
	   END
	 ELSE
	   SY := COLON;
    ';': SY := SEMICOLON;
    '^','@@': SY := ARROW;
    '[': SY := LBRACK;
    ']': SY := RBRACK;
    '*': BEGIN SY := MULOP; OP := MUL END;
    '+': BEGIN SY := ADDOP; OP := PLUS END;
    '-': BEGIN SY := ADDOP; OP := MINUS END;
    '/': BEGIN SY := MULOP; OP := RDIV END;
    '<': BEGIN SY := RELOP;
	 CASE SYMBUF[SYMCURSOR+1] OF
	   '>': BEGIN OP := NEOP; SYMCURSOR := SYMCURSOR+1 END;
	   '=': BEGIN OP := LEOP; SYMCURSOR := SYMCURSOR+1 END;
	   otherwise op := ltop
	   END; { case }
	 END;
    '=': BEGIN SY := RELOP; OP := EQOP END;
    '>': BEGIN SY := RELOP;
	 IF SYMBUF[SYMCURSOR+1]='=' THEN
	   BEGIN OP := GEOP;
	   SYMCURSOR := SYMCURSOR+1;
	   END
	 ELSE OP := GTOP;
	 END;
    otherwise
	 begin
	 IF SYMBUF[SYMCURSOR] = EOL THEN
	   begin
	   if importexportext then
	     begin
	     symcursor := symcursor + 1;
	     outputsymbol;
	     symcursor := symcursor - 1;
	     end;
	   CHECKEND;
	   symbolstart := symcursor;
	   end
	 ELSE
	   begin
	   symcursor:=symcursor+1;
	   if not skipping then ERROR(98);
	   end;
	 GOTO 1 {try again}
	 end
    END; (* CASE SYMBUF[SYMCURSOR] OF *)
  SYMCURSOR := SYMCURSOR+1;     (* NEXT CALL TALKS ABOUT NEXT TOKEN *)
  if skipping then goto 1;      (* Ignore token found if skipping=true *)
  if importexportext and not (sy = implmtsy) then
    outputsymbol;
  END; (*INSYMBOL*)

PROCEDURE SKIP (*FSYS: SETOFSYS*);
  BEGIN
  WHILE NOT (SY IN FSYS) DO INSYMBOL
  END;

procedure iowrapup(*term: termtype*);
  begin
  close(source,'normal');
  try
    $ovflcheck on$
    SCREENDOTS := SCREENDOTS+1
    $if not ovflchecking$
      $ovflcheck off$
    $end$
  recover
    if escapecode = -4 then screendots := 1
    else escape(escapecode);
  linenumber := linenumber+1;
  if linenumber > 65534 then
    linenumber := 0;
  relinum := relinum + 1;
  IF (LIST=listfull) or listopen and (curerr>0) THEN
    BEGIN       {print last line}
    fixupend;
    symcursor := symcursor+1;
    if printlastline then PRINTLINE;
    END;
  IF listopen THEN
    begin       {Report error count}
    if (totalerrors>0) or (pagecount > 0) or
       (totalwarnings>0) then
      begin
      if term = abort then
	begin
	incrlinecount; writeln(lp);
	incrlinecount; writeln(lp,'COMPILATION ABORTED');
	end;
      incrlinecount; writeln(lp);
      incrlinecount;
      if totalerrors > 0 then
	begin write(lp,totalerrors:1);
	if totalerrors = 1 then
	  write(lp,' error. ')
	else
	  write(lp,' errors. ');
	if lasterrln <> 0 then
	   write(lp,'See line ',lasterrln:1,'. ');
	end
      else write(lp,'No',' errors. ');
      if totalwarnings > 0 then
	begin
	write(lp,totalwarnings:1);
	if totalerrors = 1 then
	  write(lp,' warning.')
	else
	  write(lp,' warnings.');
	end
      else write(lp,'No',' warnings.');
      writeln(lp);
      if modcal or ucsd or sysprog then
	writeln(lp,'':15,'***** Nonstandard language features enabled *****');
      page(lp);
      end;
    end;
  WRITELN(OUTPUT);
  if term = abort then
    begin
    writeln(output,'COMPILATION ABORTED');
    writeln(output,'in ':8,
			fibp(addr(source))^.ftid,
			' at offset ',relinum:1);
    end;
  writeln(output);
  if not printlastline then
    screendots := screendots - 1;
  WRITE(OUTPUT,SCREENDOTS:1,' lines,  ');

  if totalerrors=0 then write(output,'No')
  else write(output,totalerrors:1);
  if totalerrors=1 then write(output,' error. ')
  else write(output,' errors. ');

  if totalwarnings=0 then write(output,'No')
  else write(output,totalwarnings:1);
  if totalwarnings=1 then writeln(output,' warning.')
  else writeln(output,' warnings.');

  if modcal or ucsd or sysprog then
    writeln(output,'***** Nonstandard language features enabled *****');
  if listabort then
    writeln(output,'Listing aborted');
  end; (*iowrapup*)

function getfid(anyvar s: fid) : fid;
  var
    i: shortint;
  begin
  if suffix(s) <> datafile then
    begin
    i := strlen(s);
    while (s[i] <> '.') do
      i := i - 1;
    getfid := str(s,1,i-1);
    end
  else { no suffix }
    getfid := s;
  end;

procedure compioinit;
  var
    listfile: fid;
  begin {compio initialization body}
  new(sourceinfoptr);
  if userinfo^.gotsym then
    sourcefilename := userinfo^.symfid
  else
    begin
    write(output,'Compile what text? ');
    readln(input,sourcefilename);
    fixname(sourcefilename,textfile);
    if sourcefilename='' then
      if streaming then escape(-1)
		   else escape(0);
    end;
  repeat
    ok := opensource(sourcefilename,1,false);
    if not ok then
      if streaming then
	begin
	error(401);
	escape(-1);
	end
      else
	begin
	if userinfo^.gotsym then
	  write(output,sourcefilename,' ');
	write(output,'not found. file ? ');
	readln(input,sourcefilename);
	fixname(sourcefilename,textfile);
	if sourcefilename='' then escape(-1);
	end;
  until ok;
  writeln(output);
  srcindex := 1;
  ftype := norml;
  skipping := false; ccinif := false; inoption := false;
  endofprog := false; width := 110;
  with fibp(addr(source))^ do
    if fkind = textfile  then
      begin
      filepos := pagesize;
      fpos := filepos;
      end
    else
      filepos := 0;
  symblk := 0;
  getnextpage;            {fill source buffer}
  listPC := false;
  write(output,'Printer listing (l/y/n/e)? ');
  repeat
    read(keyboard,ch);
    if not (ch in ['y','Y','n','N','e','E','l','L']) and
       streaming then escape(-1);
  until ch in ['y','Y','n','N','e','E','l','L'];
  writeln(output,ch);
  if ch >= 'a' then ch := chr(ord(ch)-32);    {uppercase it}
  list_option_L := false;
  if ch = 'N' then
    begin
    list := listnone; listopen := false;
    end
  else if ch = 'L' then
    begin
    list_option_L := true;
    list := listfull;
    listopen := false;
    writeln(output);
    repeat
      write(output,'What listing file? ');
      readln(listfile);
      fixname(listfile,textfile);
      rewrite(lp,listfile);
      if ioresult = ord(inoerror) then
	listopen := true
      else
	if streaming then escape(-10)
	else writeln('Error opening file');
    until listopen;
    end
  else
    begin
    if ch = 'Y' then list := listfull
    else list := listerronly;
$ALLOW_PACKED ON$
    rewrite(lp,'PRINTER:'
	       + getfid(fibp(addr(source))^.ftid)
	       + '.ASC');
$ALLOW_PACKED OFF$
    listopen := ioresult = ord(inoerror);
    end;
  linespp := linesperpage;
  linecount := maxint-1;
  initlistmode := LIST; pagewidth := 120;
  pagecount := 0; curerr := 0; relinum := 0; lasterrln := 0;
  end; {compioinit}


@


56.2
log
@
pws2rcs automatic delta on Wed Jan 27 11:57:27 MST 1993
@
text
@d1 1630
@


56.1
log
@Automatic bump of revision number for PWS version 3.25
@
text
@a0 1630
			{file SCANNER}

implement

var
  inoption,skipping,ccinif: boolean;
  effectivelinestart,sentinel: shortint;
  chsave: char;
  linecount,linespp: integer;
  pagecount: shortint;
  ch: char; ok: boolean;
  curerr: shortint;
  errarray: array[1..maxerrors] of record
				    errnum: shortint;
				    errloc: cursrange
				   end;
  esckey: string[6];

const
  bufsize = 110;

  eol = chr(13);

procedure IDSEARCH(var id: alpha; var symbuf: symbufarray); external;

procedure bcd_real $ALIAS 'ASM_BCD_REAL'$
		      (var bcd_str: bcd_strtype;
		       var rval: real); external;

function uniquenumber: shortint;
  begin
  uniquenum := uniquenum + 1;
  uniquenumber := uniquenum;
  end;

PROCEDURE ERROR (ERRORNUM: SHORTINT);
  VAR
    CH: CHAR;
    i,ERRSTART,line2: INTEGER;
    A: PACKED ARRAY [0..bufsize*2] OF CHAR;

    message_index: file of shortint;
    message_file: file of char;
    file_index: shortint;
    message: string[100];
  const
    messages = '*MESSAGES';
  BEGIN
  totalerrors:=totalerrors+1;
  syntxerr := true;
  WRITELN(OUTPUT);
  IF LINESTART < 2 THEN
    errstart := linestart
  ELSE
    ERRSTART := SCAN(-(LINESTART-1),=EOL,SYMBUF[LINESTART-2])+LINESTART-1;
  if (symcursor-errstart) > (bufsize*2) then
    errstart := symcursor - bufsize*2;
$ALLOW_PACKED ON$
  MOVELEFT(SYMBUF[ERRSTART],A,SYMCURSOR-ERRSTART);
$ALLOW_PACKED OFF$
  if a[0] = chr(16{DLE}) then
    begin a[0] := ' '; a[1] := ' '; end;
  line2 := linestart-errstart;
  if a[line2] = chr(16{DLE}) then
    begin
    a[line2] := ' ';
    a[line2+1] := ' ';
    end;
  for i := 0 to SYMCURSOR-ERRSTART-1 do
    if a[i] = chr(13) then writeln(output)
    else
      WRITE(OUTPUT,A[i]);
  WRITELN(OUTPUT,' <<<<');
  WRITELN(OUTPUT,'Line ',linenumber+1:1,', error ',ERRORNUM:1);

  reset(message_index,messages);
  if ioresult = ord(inoerror) then
    begin
    open(message_index);
    seek(message_index,errornum);
    read(message_index,file_index);
    close(message_index);
    if file_index <> 0 then { bad error number }
      begin
      open(message_file,messages);
      seek(message_file,file_index);
      read(message_file,ch);
      setstrlen(message,ord(ch));
      for i := 1 to ord(ch) do
	read(message_file,message[i]);
      writeln(output,message);
      end;
    end;

  if initlistmode=listnone then
    begin
    if streaming then escape(-1);
    if ftype = norml then
      begin
      if kbdtype=itfkbd then
	esckey:='esc'
      else
	esckey:='sh-exc';
      write(output,'<sp>=continue, <'+esckey+'>=terminate, E=edit ',chr(7));
      read(keyboard,ch); writeln(output);
      if (ch = 'E') or (ch = 'e') then
	with userinfo^ do
	  begin
	  errnum := errornum;
	  errblk := symblk;
	  if errornum = 99 then
	    errsym := gsymcursor-1
	  else errsym := symcursor;
	  errfid := sourceinfoptr^[srcindex].filename;
	  end;
      if ch in ['e','E',chr(27)] then escape(0);
      end
    else { ftype = specil }
      begin
      write(output,'Error in interface text: <sp>=continue',chr(7));
      read(keyboard,ch); writeln(output);
      if ch = chr(27) then escape(0);
      end;
    end;
  if listopen and (curerr < maxerrors) then
    begin
    curerr:=curerr+1;
    errarray[curerr].errnum:=errornum;
    errarray[curerr].errloc:=symcursor-linestart;
    end;
  END (*ERROR*) ;

procedure errorwithinfo(*errornum: shortint; infostring: string80*);
  {emit error with a line of additional information}
  begin writeln(output); write(output,infostring);
    if list <> listnone then
      begin incrlinecount; writeln(lp,infostring) end;
    error(errornum);
  end;

procedure warning(linenum: integer; infostring: string80);
  begin
  totalwarnings := totalwarnings + 1;
  if warn then
    begin
    writeln(output);
    write(output,'***WARNING (line',linenum:5,'): ',infostring);
      if list <> listnone then
	begin
	incrlinecount;
	writeln(lp,'***WARNING: (line',linenum:5,'): ',infostring);
	end;
    end;
  end;

function opensource (fname: fid; srclevel: shortint; must: boolean)
		     : boolean;
  {Open file "SOURCE" to access given name; returns TRUE if successful}
  {Puts fname into sourceinfoptr^[srclevel].filename}
  {If MUST = true, wait for file to be inserted}
  var
    ok,done: boolean;
    ch: char;
  begin
  sourceinfoptr^[srclevel].filename := fname;
  done := true;   {no prompt first time thru}
  repeat
    if not done then            {Prompt for file if not first try}
      if streaming then
	begin
	error(401);
	escape(-1);
	end
      else
	begin writeln(output);
	write(output,'Mount ',fname,' and press <space> ',chr(7));
	read(keyboard,ch); writeln(output);
	if ch = chr(27) then escape(0);
	end;
      close(source);                              {Ensure source is closed}
      reset(source, fname,'SHARED');
      if IORESULT = ord(inofile) then                  {Try appending .TEXT}
      if strlen(fname) + 5 <= strmax(fname) then
	begin
	reset(source,fname + '.TEXT','SHARED');
	sourceinfoptr^[srclevel].filename :=
				 fname + '.TEXT';
	end;
    ok := (IORESULT = ord(inoerror));
    if ok then done := true
    else if must then done := false     {Always retry if MUST}
    else done := not (IORESULT in
      [ord(ibadunit),ord(ilostunit),ord(inounit)]);     {else, only retry NO-VOL errs}
  until done;
  opensource := ok;
  if ok then
    with fibp(addr(source))^ do
      if (fkind = textfile) or (fkind = codefile)  then
	begin
	am := amtable^[untypedfile];
	fleof := fleof + (-fleof) mod pagesize;
	end;
  end; {opensource}

procedure setlinewidth;
  { insert end-of-line sentinel based on width option }
  begin
  effectivelinestart := linestart;
  while symbuf[symcursor] = CHR(16(*DLE*)) do
    begin   { strip off blank compression }
    effectivelinestart :=
      effectivelinestart + 2 - (ord(symbuf[symcursor+1])-ord(' '));
    symcursor := symcursor+2;
    end;
  { set marker at effective end-of-line }
  sentinel := effectivelinestart+width;
  if sentinel > maxcursor then sentinel := maxcursor;
  chsave := symbuf[sentinel];
  symbuf[sentinel] := eol;
  { remove leading blanks }
  symcursor := symcursor+scan(80,<>' ',symbuf[symcursor])
  end;

procedure fixupend;
  { erase effect of SETLINEWIDTH before printing line.
    Advance cursor to actual end of line }
  begin symbuf[sentinel] := chsave;
  while symbuf[symcursor] <> eol do symcursor := symcursor+1;
  end;

PROCEDURE GETNEXTPAGE;
  label 1;
  BEGIN
  gsymcursor := symcursor;
  SYMCURSOR := 0; LINESTART := 0;
  repeat
    with fibp(addr(source))^ do
      begin
      filepos := fpos;
      if fkind in [textfile,codefile] then
	begin
	if fpos < fleof then
	  begin
	  freadbytes(source,symbuf,
		       min(pagesize,fleof-fpos));
	  if ioresult = ord(inoerror) then goto 1
	  else escape(-10);
	  end;
	end
      else
	if not eof(source) then
	  begin
	  any_to_UCSD(source,symbuf);
	  if ioresult = ord(inoerror) then goto 1
	  else escape(-10);
	  end;
      end;
    {End of file reached}
    if srcindex <= 1 then             {end of original source file}
      begin
      symbuf[0] := eol;
      if not endofprog then
	begin
	printlastline := true;
	ERROR(99);
	end
      else printlastline := false;
      escape(0);
      end;
    srcindex := srcindex-1;           {end of include file}
    with sourceinfoptr^[srcindex] do      {restore state of previous file}
      begin
      if not opensource(filename,srcindex,true) then
	escape(0);
      filepos := oldfilepos;
      with fibp(addr(source))^ do
	begin
	fpos := filepos;
	end;
      symblk := oldsymblk-2;
      relinum := oldrelinum;
      SYMCURSOR := OLDSYMCURSOR; LINESTART := OLDLINESTART;
      ftype := oldftype;
      end;
    until false;
1:setlinewidth;
  symblk := symblk + 2;
  symbolstart := symcursor;
  END (*GETNEXTPAGE*) ;

procedure incrlinecount;
  begin
  linecount:=linecount+1;
  if (linecount>linespp) or (linecount=maxint) then
    begin
    if pagecount>0 then page(lp);
    pagecount:=pagecount+1;
    writeln(lp,compilername,' [Rev ',crevno,' ',
      crevid.month:2,'/',crevid.day:2,'/',
      crevid.year:2,'] ',fibp(addr(source))^.ftid,
      ' ':24-strlen(fibp(addr(source))^.ftid),
      todaysdate,' ',timestring,' Page ',pagecount:1);
    writeln(lp);
    linecount:=1
    end;
  end;

PROCEDURE PRINTLINE;
  { Print just-completed source line on listing }
  const
    prefixwidth = 19; { width of line prefix + 1}
  VAR
    DORC,STARORC: CHAR;
    LENG,offset,i,posonpage,curleng: INTEGER;
    A: PACKED ARRAY [0..bufsize] OF CHAR;

  procedure printexcessA;
    {print string A[0..pagewidth-1] on listing
     while length(A) exceeds pagewidth}
    begin
    posonpage := prefixwidth+offset;
    if posonpage>pagewidth then
      begin writeln; error(601);
      incrlinecount; posonpage := 1;
      end;
    while posonpage+leng-1 > pagewidth do
      begin curleng := pagewidth-posonpage+1;
      writeln(lp,a:curleng);
      leng := leng-curleng;
$ALLOW_PACKED ON$
      moveleft(a[curleng],a,leng);
$ALLOW_PACKED OFF$
      posonpage := 1;
      incrlinecount;
      end;
    end;

  function blankline : boolean;
    var
      leng: shortint;
    begin
    leng := symcursor - linestart - 1;
    if symbuf[linestart] = chr(16(*DLE*)) then
      leng := leng - 2;
    blankline := leng = 0;
    end;

  BEGIN { printline }
  IF BPTONLINE THEN STARORC := '*' else STARORC := ':';
  incrlinecount;
  WRITE(lp,linenumber:6,STARORC);
  if skipping or blankline then
    WRITE(lp,'S','':10)
  else IF oldDP THEN
    if lc <> 0 then
      WRITE(lp,'D',lc:6,levelatstart+linlevatstart:3,' ')
    else
      WRITE(lp,'D','':6,levelatstart+linlevatstart:3,' ')
  else
    WRITE(lp,'C','':6,levelatstart+linlevatstart:3,' ')
      ;
  LENG := SYMCURSOR-LINESTART;
  { NB: LENG includes the trailing EOL char, therefore LENG>=1 }
  IF LENG > bufsize THEN LENG := bufsize;
$ALLOW_PACKED ON$
  MOVELEFT(SYMBUF[LINESTART],A,LENG);
$ALLOW_PACKED OFF$
  IF A[0] = CHR(16(*DLE*)) THEN
    BEGIN
    offset := ORD(A[1])-ORD(' ');
    IF offset>0 THEN
      WRITE(lp,' ':offset);
    LENG := LENG-2;
$ALLOW_PACKED ON$
    MOVELEFT(A[2],A,LENG)
$ALLOW_PACKED OFF$
    END
  else offset:=2;       {adjusts for linestart not pointing at DLE}
  printexcessA;
  WRITELN(lp,A:LENG-1);         {-1 to remove EOL}
  IF curerr>0 then
    begin
    fillchar(a,bufsize+1,' ');
    leng := 0;
    for i:=1 to curerr do
      with errarray[i] do
	begin
	a[errloc]:='^';
	if errloc >= leng then leng := errloc+1;
	end;
    leng := leng-3;
$ALLOW_PACKED ON$
    moveleft(A[3],A,leng);
$ALLOW_PACKED OFF$
    incrlinecount; write(lp,' ':prefixwidth+offset-1);
    printexcessA; writeln(lp,a:leng);
    incrlinecount;
    WRITE(lp,'>>>>>> Error at ',fibp(addr(source))^.ftid,'/',relinum:1,
	     ':  ',errarray[1].errnum:1);
    for i:=2 to curerr do
      write(lp,', ',errarray[i].errnum:1);
    if lasterrln <> 0 then write(lp,'   (see also ',lasterrln:1,')');
    writeln(lp);
    if list = listerronly then
      begin incrlinecount; writeln(lp) end;
    curerr:=0; lasterrln := linenumber;
    end;
  if ioresult <> ord(inoerror) then
    begin
    listabort := true;
    list := listnone;
    listopen := false;
    warning(linenumber,'Listing aborted');
    end;
  END (*PRINTLINE*);

procedure buildreal(*inputstr: string80; var realval: real*);
  var
    bcd_str: bcd_strtype;
    i,mantissa_digit,extraexponent,exponentsign: shortint;
    inexponent,decpnt: boolean;
  begin
    with bcd_str do
      begin
      decpnt := false;
      exponent := 0;
      extraexponent := 0;
      inexponent := false;
      exponentsign := 1;
      mantissa_digit := 1;
      for i := 1 to 16 do mantissa[i] := 0;
      for i := 1 to strlen(inputstr) do
	begin
	if (inputstr[i] >= '0') and (inputstr[i] <= '9') then
	  if inexponent then exponent := exponent*10 +
					 (ord(inputstr[i]) - ord('0'))
	  else
	    begin
	    if decpnt then
	      begin
	      if (mantissa_digit = 1) and
		 (inputstr[i] = '0') then
		extraexponent := extraexponent-1;
	      end;
	    if (mantissa_digit > 1) or
	       (inputstr[i] <> '0') then
	      begin
	      if (mantissa_digit <= 16) then
		mantissa[mantissa_digit] := ord(inputstr[i]) - ord('0');
	      mantissa_digit := mantissa_digit + 1;
	      end;
	    end
	else if inputstr[i] = '+' then
	  if inexponent then exponentsign := 1
	  else signbit := pls
	else if inputstr[i] = '-' then
	  if inexponent then exponentsign := -1
	  else signbit := mnus
	else if inputstr[i] = '.' then
	  begin
	  extraexponent := mantissa_digit-1;
	  decpnt := true;
	  end
	else if inputstr[i] = 'E' then
	  begin
	  if not decpnt then
	    extraexponent := mantissa_digit-1;
	  inexponent := true;
	  end;
	end;
      exponent := exponent * exponentsign + extraexponent;
      try
	bcd_real(bcd_str,realval);
      recover
	if escapecode = -19 then error(50)
	else escape(escapecode);
      end;
  end; { buildreal }

procedure newident(*var namep: alphaptr; newid: alpha*);
  {Put identifier string in heap, return ptr to it}
  begin
  newwords(namep, (strlen(newid)+2) div 2);
  namep^ := newid;
  end;

procedure upc(var s: string);
  var
    i: shortint;
  begin
  for i := 1 to strlen(s) do
    if (s[i] >= 'a') and (s[i] <= 'z') then
      s[i] := chr(ord(s[i])-32);
  end;

PROCEDURE INSYMBOL;
  { Fetch next source token. Also produces listing when an EOL is crossed. }
  { Handles all 'control comments'. }
  LABEL 1;
  const tab = 9;
  var btemp: boolean;

  PROCEDURE CHECKEND;
  var
    blocks_read : integer;

  BEGIN (* CHECKS FOR THE END OF THE PAGE *)
  fixupend;
  try
    $ovflcheck on$
    SCREENDOTS := SCREENDOTS+1
    $if not ovflchecking$
      $ovflcheck off$
    $end$
  recover
    if escapecode = -4 then screendots := 1
    else escape(escapecode);
  linenumber := linenumber+1;
  if linenumber > 65534 then
    linenumber := 0;
  relinum := relinum+1;
  SYMCURSOR := SYMCURSOR + 1;
  IF ((SCREENDOTS-STARTDOTS) MOD 5 = 0)
     and not beforefirsttoken THEN
    WRITE(OUTPUT,'.');
  IF (LIST=listfull) or listopen and (curerr>0) THEN PRINTLINE;
  BPTONLINE := FALSE;
  levelatstart := level;
  linlevatstart := linelevel;
  IF (symcursor > maxcursor) or
     (SYMBUF[SYMCURSOR]=CHR(0)) THEN GETNEXTPAGE
  ELSE if (symbuf[symcursor] = chr(3)) and
	  (ftype = specil) then
    begin
    srcindex := srcindex - 1;
    with sourceinfoptr^[srcindex] do
      begin
      if not opensource(filename,srcindex,true) then
	 escape(0);
      filepos := oldfilepos;
      symblk := oldsymblk;
      relinum := oldrelinum;
      ftype := oldftype;
      with fibp(addr(source))^ do
	begin
	fpos := filepos;
	if fkind in [textfile,codefile] then
	  if fpos < fleof then
	    freadbytes(source,symbuf,pagesize)
	  else escape(-8)
	else
	  if eof(source) then escape(-8)
	  else any_to_UCSD(source,symbuf);
	end;
      if ioresult <> ord(inoerror) then escape(-10);
      symcursor := oldsymcursor;
      symbolstart := symcursor;
      linestart := oldlinestart;
      if ftype = norml then
	begin
	list := gtemplist;
	linenumber := gtemplinenumber;
	width := gtempwidth;
	if putcode = false then putcode := temp_put;
	end;
      setlinewidth;
      end;
    end
  else
    begin LINESTART := SYMCURSOR; setlinewidth end;
  oldDP := DP;
  END; (*CHECKEND*)

  procedure option;
    var
      optionname: optionlist;
      ltitle: fid;
      lid: alpha;
      btemp,done: boolean;
      lvid: vid;
      ltid: fid;
      i,lsegs,ior: integer;
      lkind: filekind;
      s: string[10];

    procedure eatspaces;
      begin
      while symbuf[symcursor]=' ' do symcursor:=symcursor+1;
      end;

    function sw: boolean;
      { look for identifier in input,
	determine if it is 'ON' or OFF' }

      begin {sw}
      sw := true;
      if sy = ident then
	begin
	upc(id);
	if id = 'OFF' then sw := false
	else if id <> 'ON' then error(6);
	insymbol; { advance past the symbol }
	end;
      end;

    function getinteger: integer;
      var lsp: stp; lvalu: valu; oldexp: exptr;
      begin
      oldexp := curexp;
      constant([dollarsy,comma,semicolon],lsp,lvalu);
      curexp := oldexp;
      if lsp <> intptr then begin error(50); getinteger := 0 end
      else getinteger := lvalu.ival;
      end;

    procedure gettitle(var s: string);
      { convert pa of char constant val.valp^ to string }
      begin s[0] := chr(0);
      if sy <> stringconst then error(648)
      else
	if val.intval then
	  begin
	  s[0] := chr(1);
	  s[1] := chr(val.ival);
	  end
	else with val.valp^ do
	  begin
	  if slgth > strmax(s) then error(648)
	  else
	    begin s[0] := chr(slgth);
	    moveleft(sval,s[1],slgth);
	    end;
	  end;
      insymbol;
      end;

    procedure getoptionname;
      var loptionname: optionlist;
	  svskip,found: boolean;

      begin svskip := skipping; skipping := false;
      insymbol;
      if sy = ifsy then (*** kLuGe ***)
	begin sy := ident; id := 'IF' end
      else if sy = endsy then
	begin sy := ident; id := 'END' end;
      if sy <> ident then
	begin loptionname := emptyop;
	if not(sy in [semicolon,comma]) then
	  begin error(6);
	  skip([dollarsy,semicolon,comma]);
	  end;
	end
      else
	begin {search in option array}
	loptionname := aliasop; found:=false;
	while (loptionname < illegal) and (not found) do
	  if id = optionarray[loptionname] then found:=true
	  else loptionname:=succ(loptionname);
	insymbol;
	end;
      skipping := svskip;
      optionname := loptionname;
      end; {getoptionname}

    procedure doinclude;
      {Process a $INCLUDE command}
      var
	tfpos : integer;
      begin
      tfpos := fibp(addr(source))^.fpos;
      gettitle(ltitle);
      if sy <> dollarsy then
	begin error(24); skip([dollarsy]) end;
      IF srcindex >= maxinfiles THEN ERROR(608);
      fixname(ltitle,textfile);
      if opensource(LTITLE,srcindex+1,false) then
	begin
	with sourceinfoptr^[srcindex] do          {save current file info}
	  begin
	  OLDSYMCURSOR := SYMCURSOR;
	  OLDLINESTART := LINESTART;
	  oldfilepos := filepos;
	  oldsymblk := symblk;
	  oldrelinum := relinum;
	  oldftype := ftype;
	  end;
	with fibp(addr(source))^ do
	  if fkind = textfile  then
	    begin
	    filepos := pagesize;
	    fpos := filepos;
	    end
	  else
	    filepos := 0;
	symblk := 0;
	IF (LIST=listfull) or listopen and (curerr>0) then
	  begin        {First listing of include line}
	  fixupend;
	  symcursor := symcursor+1;
	  printline;
	  end;
	srcindex := srcindex+1;
	relinum := 0;
	ftype := norml;
	GETNEXTPAGE;
	end
      ELSE
	begin         {Couldn't open include file}
	ERROR(609);
	if not opensource(sourceinfoptr^[srcindex].filename,srcindex,true) then
	  escape(0)
	else      {restore SOURCE to old file}
	  fibp(addr(source))^.fpos := tfpos;
	end;
      end; {doinclude}

    procedure doccif;
      {Process $IF boolean expression - changed 5/80 to call CONSTANT}
      var
	lsp: stp; lvalu: valu;
	oldexp: exptr; oldinbody: boolean;
      begin
      if ccinif then error(605); {nested $IF}
      ccinif := true;
      oldexp := curexp;
      oldinbody := inbody;
      inbody := true; {allow all op's to be folded}
      $IF fulldump$
	new(lastexp);  {scratch place for exp list}
      $END$
      constant([dollarsy,comma,semicolon],lsp,lvalu);
      inbody := oldinbody;
      curexp := oldexp;
      if lsp <> boolptr then error(135) else skipping := not odd(lvalu.ival);
      end; {doccif}

    procedure refdefop(var fsize: integer;
	defaultsize: integer; var fvolname: string);
      var
	tvolname: string255;
      begin
      if not beforefirsttoken then
	error(600);
      if sy=intconst then
	begin fsize := getinteger;
	if (fsize<0) or (fsize>32767) then
	  begin error(648);
	  fsize := defaultsize;
	  end;
	end
      else
	begin
	gettitle(tvolname);
	if tvolname[strlen(tvolname)] <> ':' then
	  tvolname := tvolname + ':';
	if strlen(tvolname) > strmax(fvolname) then
	  error(648)
	else
	  fvolname := tvolname;
	end;
      end; {refdefop}


    begin {option}
    if stdpasc then error(606);
    inoption := true;
    REPEAT                            {Process a control item}
      getoptionname;
      if skipping then
	begin {Ignore all options except $END}
	if optionname = ccendop then
	  begin skipping := false; ccinif := false end
	else
	  begin
	  if optionname = ccifop then error(605);
	  skipping := false;
	  if optionname in [searchop,overlayop] then
	    skip([dollarsy])
	  else
	    skip([dollarsy,comma,semicolon]);
	  skipping := true;
	  end;
	end
      else
	case optionname of
	  emptyop: ;
	  aliasop:
	    begin
	    if not aliasok then error(621);
	    if indefinesection then
	      error(646);
	    aliasok := false;
	    gettitle(lid);
	    upc(lid);
	    newident(aliasptr,lid);
	    end;
	  allowpacked:
	    allow_packed := sw;
	  ansiop:
	    begin
	    if not beforefirsttoken then error(600);
	    stdpasc := sw;
	    end;
	  callabsop:
	    if sw then gcallmode := abscall
	    else gcallmode := relcall;
	  ccifop:
	    doccif;
	  ccendop:
	    if ccinif then ccinif := false  {end of successful $IF}
	    else error(605);                {not in $IF}
	  codeop:
	    begin
	    if inbody then error(602);
	    putcode := sw;
	    end;
	  copyrightop:
	    gettitle(gcopyright);
	  debugop:
	    begin
	    if inbody then error(602);
	    DEBUGGING := SW;
	    end;
	  defop:
	    refdefop(defilesize,
		     defiledefault,defvolname);
	  floatop:
	    begin
	    if inbody then error(602);
	    float := flt_on;
	    if sy = ident then
	      begin
	      upc(id);
	      if id = 'OFF' then float := flt_off
	      $IF not MC68020$
	      else if id = 'TEST' then float := flt_test
	      $END$
	      else if id <> 'ON' then error(6);
	      insymbol;
	      end;
	    end;
	  heapdisposeop:
	    begin if not beforefirsttoken then error(600);
	    heapdispose := sw;
	    end;
	  inclop:
	    doinclude;
	  iochkop:
	    giocheck := sw;
	  linesop:
	    begin linespp := getinteger;
	    if linespp < 20 then
	      begin error(648); linespp := 20 end;
	    end;
	  listop :
	    if sy = stringconst then
	      begin    { LIST 'filename' }
	      gettitle(ltitle);
	      if (initlistmode <> listnone) and
		 not list_option_L then
		begin
		fixname(ltitle,textfile);
		close(lp,'lock');
		if ioresult <> ord(inoerror) then
		  begin
		  setstrlen(s,0);
		  ior := ioresult;
		  strwrite(s,1,i,ior:1);
		  warning(linenumber,'Error closing listing file, ioresult('+s+')');
		  end;
		rewrite(lp,LTITLE);
		listopen := (IORESULT = ord(inoerror));
		if listopen then
		  begin
		  if initlistmode = listfull then
		    LIST := LISTFULL;
		  end
		else error(400);
		end;
	      end
	    else  {LIST ON/OFF}
	      begin
	      btemp := sw;
	      if initlistmode = listfull then
		if btemp then LIST := listfull
		else LIST := listnone;
	      end;
	  modcalop:
	    $IF allowmodcal$
	      begin modcal := sw;
	      if not beforefirsttoken then error(600);
	      end;
	    $END$
	    $IF not allowmodcal$
	      begin error(649);
	      btemp := sw;
	      end;
	    $END$
	  numop:
	    begin
	    linenumber := getinteger-1;
	    if (linenumber < -1) or
	       (linenumber > 65534) then
	      begin
	      error(614);
	      linenumber := 0;
	      end;
	    end;
	  overlayop:
	    begin
	    if maxoverlays = 0 then
	      begin
	      maxoverlays := overlaydefault;
	      newbytes(overlaylistptr,16*maxoverlays);
	      end;
	    overlaytop := 0;
	    done := false;
	    repeat
	      if sy = stringconst then
		begin
		gettitle(ltitle);
		if strlen(ltitle) > 15 then
		  error(648)
		else
		  begin
		  if overlaytop>=maxoverlays
		    then error(604)
		  else
		    begin
		    upc(ltitle);
		    overlaytop := overlaytop+1;
		    overlaylistptr^[overlaytop] := ltitle;
		    end;
		  end;
		end
	      else error(648);
	      if (sy=comma) or (sy=semicolon) then
		insymbol
	      else if sy = dollarsy then
		done := true
	      else
		begin
		error(6);
		skip([dollarsy,stringconst]);
		end;
	    until done;
	    end;
	  overlaysizeop:
	    begin
	    if not beforefirsttoken then
	      error(600);
	    i := getinteger;
	    if (i < 0) or (i > 32767) then
	      error(648)
	    else
	      if maxoverlays = 0 then
		maxoverlays := i
	      else
		error(649);
	    if maxoverlays <> 0 then
	      newbytes(overlaylistptr,16*maxoverlays);
	    end;
	  ovlfchkop:
	    govflcheck := sw;
	  pageop:
	    if list = listfull then
	      begin  {force a new page}
	      linecount:=linespp; incrlinecount;
	      linecount:=linecount-1     {not really printing a line}
	      end;
	  pagewidthop:
	    begin
	    i:= getinteger;
	    if i < 80 then
	      begin pagewidth := 80; error(648) end
	    else if i > 132 then
	      begin pagewidth := 132; error(648) end
	    else pagewidth := i;
	    end;
	  partevalop:
	    gshortcircuit := sw;
	  PCop:
	    begin
	    if inbody then error(602);
	    listPC := sw;
	    end;
	  rangeop:
	    grangecheck := sw;
	  refop:
	    refdefop(refilesize,
		     refiledefault,refvolname);
	  saveop:
	    saveconst := sw;
	  searchsizeop:
	    begin
	    if not beforefirsttoken then
	      error(600);
	    i := getinteger;
	    if (i < 0) or (i > 32766) then
	      error(648)
	    else
	      if maxsearchfiles = 0 then
		 maxsearchfiles:= i+1
	      else
		error(649);
	    if maxsearchfiles <> 0 then
	      newbytes(searchlistptr,122*maxsearchfiles);
	    searchfilestop := 1;
	    searchlistptr^[searchfilestop]:=syslibrary;
	    end;
	  searchop:
	    begin
	    if maxsearchfiles = 0 then
	      begin
	      maxsearchfiles := searchdefault;
	      newbytes(searchlistptr,122*maxsearchfiles);
	      end;
	    searchfilestop := 0;
	    done := false;
	    repeat
	      if sy = stringconst then
		begin
		gettitle(ltitle);
		fixname(ltitle,codefile);
		if searchfilestop>=maxsearchfiles-1
		  then error(604)
		else
		  begin
		  searchfilestop := searchfilestop+1;
		  searchlistptr^[searchfilestop] := ltitle;
		  end;
		end
	      else error(647);
	      if (sy=comma) or (sy=semicolon) then
		insymbol
	      else if sy = dollarsy then
		done := true
	      else
		begin
		error(6);
		skip([dollarsy,stringconst]);
		end;
	    until done;
	    searchfilestop := searchfilestop+1;
	    searchlistptr^[searchfilestop]:=syslibrary;
	    end;
	  stackchkop:
	    begin
	    if inbody then error(602);
	    gstackcheck := sw;
	    end;
	  strposop:
	    begin
	    switch_strpos := sw;
	    if not beforefirsttoken then
	      error(600);
	    strpos_warn := false;
	    end;
	  sysprogop:
	    begin
	    sysprog := sw;
	    if not beforefirsttoken then
	      error(600);
	    end;
	  tablesop:
	    begin
	    if inbody then error(602);
	    tables := sw;
	    end;
	  ucsdop:
	    begin ucsd := sw;
	    if not beforefirsttoken then error(600);
	    end;
	  warnop:
	    warn := sw;
	  otherwise error(649)
	  END; (*CASES*)
      UNTIL (sy <> semicolon) and (sy <> comma);
    if sy <> dollarsy then begin error(24); skip([dollarsy]) end;
    inoption := false;
    end; {option}


  PROCEDURE COMMENTER;
    var svskip,done: boolean;
    BEGIN
    SYMCURSOR := SYMCURSOR+1; (* POINT TO THE FIRST CHAR PAST "(*" OR "{" *)
    svskip := skipping; skipping := true;    {Mark commented lines as ignored}
    SYMCURSOR := SYMCURSOR-1; (* ADJUST FOR FIRST +1 IN LOOP *)
    done := false;
    REPEAT
      SYMCURSOR := SYMCURSOR+1;
      WHILE SYMBUF[SYMCURSOR] = EOL DO
	begin
	if importexportext then
	  begin
	  symbolstart := symcursor;
	  symcursor := symcursor + 1;
	  outputsymbol;
	  symcursor := symcursor - 1;
	  end;
	CHECKEND;
	end;
      if symbuf[symcursor] = '}' then
	begin done := true; symcursor := symcursor+1 end
      else if symbuf[symcursor] = '*' then
	if symbuf[symcursor+1] = ')' then
	  begin done := true; symcursor := symcursor+2 end;
    UNTIL done;
    skipping := svskip;
    END; (*COMMENTER*)

  PROCEDURE ASTRING;
    LABEL 1;
    VAR TP,cval: INTEGER;
	lvp: csp;
	T: PACKED ARRAY [1..110] OF CHAR;
    BEGIN
    TP := 0;            (* # of characters accumulated *)
    while (symbuf[symcursor]='#') or (symbuf[symcursor]='''') do
      begin
      if symbuf[symcursor]='#' then
	begin
	symcursor := symcursor+1;
	if stdpasc then error(606);
	if symbuf[symcursor] in ['0'..'9'] then
	  begin         {#number}
	  cval := ord(symbuf[symcursor]) - ord('0');
	  symcursor := symcursor+1;
	  while symbuf[symcursor] in ['0'..'9'] do
	    begin
	    $OVFLCHECK on$
	    try
	      cval := cval*10 + ord(symbuf[symcursor]) - ord('0');
	    recover
	      if escapecode = -4 {overflow} then
		cval := 256 { insure syntax error }
	      else
		escape(escapecode);
	    $IF not ovflchecking$
	      $OVFLCHECK off$
	    $END$
	    symcursor := symcursor+1;
	    end;
	  TP := TP+1;
	  if cval > 255 then error(708);
	  T[TP] := chr(cval mod 256);
	  end
	else if (symbuf[symcursor] in ['@@'..'z'])
	  and (symbuf[symcursor] <> '`'{grave}) then
	  begin         {#control char}
	  TP := TP+1;
	  T[TP] := chr(ord(symbuf[symcursor]) mod 32);
	  symcursor := symcursor+1;
	  end
	else   {# followed by something weird}
	  begin symcursor := symcursor+1;
	  error(709);
	  end;
	if inoption then error(6);
	end {#}
      else
	begin {char is '}
	REPEAT
	  REPEAT
	    SYMCURSOR := SYMCURSOR+1;
	    TP := TP+1;
	    T[TP] := SYMBUF[SYMCURSOR];
	    IF SYMBUF[SYMCURSOR] = EOL THEN BEGIN ERROR(660); GOTO 1 END;
	  UNTIL SYMBUF[SYMCURSOR]='''';
	  SYMCURSOR := SYMCURSOR+1;
	UNTIL SYMBUF[SYMCURSOR]<>'''';
      1:TP := TP-1;         (* Take out ending ' *)
	end
      end; {while # or '}
    SYMCURSOR := SYMCURSOR-1;   (* adjust for INSYMBOL's incrementing *)
    SY := STRINGCONST;
    LGTH := TP;
    IF TP=1 THEN        (* SINGLE CHARACTER CONSTANT *)
      with val do begin intval := true; IVAL := ORD(T[1]) end
    ELSE
      begin
      newwords(lvp,(sizeof(constrec,true,paofch)-(strglgth-lgth)+1) div 2);
      WITH lvp^ DO
	BEGIN CCLASS := paofch; SLGTH := TP;
$ALLOW_PACKED ON$
	MOVELEFT(T[1],SVAL[1],TP);
$ALLOW_PACKED OFF$
	END;
      with val do begin intval := false; VALP := lvp end
      end;
    END; (*ASTRING*)

  PROCEDURE NUMBER;
    label 1;
    VAR numstart,expoffset,ISUM,J: INTEGER;
	TIPE: (inttipe,realtipe);
	dummybool: boolean;
	LVP: CSP;
	realtemp: string80;
    BEGIN
    TIPE := inttipe;
    numstart := SYMCURSOR;
    expoffset := 0;
    REPEAT                      {scan over integer part}
      SYMCURSOR := SYMCURSOR+1
    UNTIL (SYMBUF[SYMCURSOR]<'0') OR (SYMBUF[SYMCURSOR]>'9');
    IF SYMBUF[SYMCURSOR]='.' THEN
      { Following line modified 8/12/89 JWH }
      { IF SYMBUF[SYMCURSOR+1]<>'.' THEN }     (* WATCH OUT FOR '..' *)
      IF ((SYMBUF[SYMCURSOR+1]<>'.') AND (SYMBUF[SYMCURSOR+1] <> ')')) THEN
	BEGIN
	TIPE := REALTIPE;
	SYMCURSOR := SYMCURSOR+1;
	WHILE (SYMBUF[SYMCURSOR]>='0') AND (SYMBUF[SYMCURSOR]<='9') DO
	  SYMCURSOR := SYMCURSOR+1;     {scan fractional part}
	END;
    IF SYMBUF[SYMCURSOR] IN ['e','E','l','L'] THEN
      BEGIN
      tipe := realtipe;
      expoffset := symcursor-numstart+1;
      SYMCURSOR := SYMCURSOR+1;
      if stdpasc and
	 (symbuf[symcursor-1] in ['l','L']) then
	error(606);
      IF SYMBUF[SYMCURSOR] IN ['+','-'] THEN SYMCURSOR := SYMCURSOR+1;
      if (symbuf[symcursor] < '0') OR (symbuf[symcursor] > '9') then
	warning(linenumber,
'chars other than 0-9,+,-,E,L in exponent are ambiguous / do not conform to ANSI');
      WHILE (SYMBUF[SYMCURSOR]>='0') AND (SYMBUF[SYMCURSOR]<='9') DO
	SYMCURSOR := SYMCURSOR+1;
      END;
    (* NOW CONVERT TO INTERNAL FORM *)
    IF TIPE=INTTIPE THEN
      BEGIN
     {*********************************************************************

		CONVERT TO RETURN A NEGATIVE REPRESENTATION
		IF UMINUS IS TRUE.  IF UMINUS IS FALSE AND
		THE NUMBER DOESN'T HAVE A POSITIVE REPRESENTATION
		ON THE HARDWARE, GIVE AN ERROR (e.g, 32768 in 16 bits);
		OTHERWISE, RETURN THE POSITIVE NUMBER.

      *********************************************************************}
      SY := INTCONST;
      ISUM := 0;
      try
	$ovflcheck on$
	FOR J := numstart TO symcursor-1 DO
	  ISUM := ISUM*10-(ORD(SYMBUF[J])-ORD('0'));
	$if not ovflchecking$
	  $ovflcheck off$
	$end$
      recover
	if escapecode = -4 then { integer ovfl }
	  error(661)
	else escape(escapecode);
   1: with val do
	begin intval := true;
	if uminus then ival := isum
	else
	  if isum > MININT then ival := -isum
	  else begin ival := 0; error(661) end;
	end;
      END
    ELSE
      BEGIN (* REAL NUMBER HERE *)
      SY := REALCONST;
      NEW(LVP,true,REEL);
      with LVP^ do
	begin CCLASS := REEL;
	j := symcursor-numstart;      {length of number}
	if j > strmax(realtemp) then
	  begin
	  error(680);
	  j := strmax(realtemp);
	  end;
	realtemp[0] := chr(j+1);
	if uminus then realtemp[1] := '-'
	else realtemp[1] := '+';
$ALLOW_PACKED ON$
	moveleft(symbuf[numstart], realtemp[2], j);
$ALLOW_PACKED OFF$
	if expoffset>0 then realtemp[expoffset+1] := 'E';
	if realtemp[strlen(realtemp)] = '.' then
	  error(18);
	buildreal(realtemp,RVAL);
	end;
      with VAL do begin intval := false; VALP := LVP end;
      END; {type real}
    SYMCURSOR := SYMCURSOR-1;   (* adjust for INSYMBOL's incrementing *)
    END; (*NUMBER*)

  BEGIN (* INSYMBOL *)
1:symbolstart := symcursor;
  SY := OTHERSY;        (* IF NO CASES EXERCISED BLOW UP *)
  OP := NOOP;
  CASE SYMBUF[SYMCURSOR] OF
    '''','#':   ASTRING;
    '0'..'9':   NUMBER;
    'A'..'Z','a'..'z':
      begin
      idsearch(id,symbuf);
      if not modcal then
	if sy >= forwardsy then
	  case sy of
	    forwardsy:
	      begin
	      sy := ident; id := 'FORWARD';
	      end;
	    externlsy:
	      begin
	      sy := ident; id := 'EXTERNAL';
	      end;
	    trysy:
	      if not sysprog then
		begin
		sy := ident; id := 'TRY';
		end;
	    recoversy:
	      if not sysprog then
		begin
		sy := ident; id := 'RECOVER';
		end;
	    anyvarsy:
	      if not sysprog then
		begin
		sy := ident; id := 'ANYVAR';
		end;
	    end;
      end;

    '$': begin sy := dollarsy;
	 if not inoption then
	   begin
	   symcursor := symcursor+1;
	   btemp := importexportext;
	   importexportext := false;
	   option;
	   importexportext := btemp;
	   goto 1;
	   end;
	 end;
    '{': BEGIN COMMENTER; GOTO 1 END;
    '(': IF SYMBUF[SYMCURSOR+1]='*' THEN
	   BEGIN SYMCURSOR := SYMCURSOR+1;
	   COMMENTER; GOTO 1;
	   END
	 else if symbuf[symcursor+1] = '.' then
	   begin symcursor := symcursor+1; sy := lbrack end
	 ELSE SY := LPARENT;
    ')': SY := RPARENT;
    ',': SY := COMMA;
    ' ',chr(tab):
	    BEGIN
	    SYMCURSOR := SYMCURSOR+1;
	    if importexportext then outputsymbol;
	    GOTO 1;
	    END;
    '.': IF SYMBUF[SYMCURSOR+1]='.' THEN
	   BEGIN SYMCURSOR := SYMCURSOR+1;
	   SY := rangesy;
	   END
	 else if symbuf[symcursor+1] = ')' then
	   begin symcursor := symcursor+1; sy := rbrack end
	 ELSE SY := PERIOD;
    ':': IF SYMBUF[SYMCURSOR+1]='=' THEN
	   BEGIN SYMCURSOR := SYMCURSOR+1;
	   SY := BECOMES;
	   END
	 ELSE
	   SY := COLON;
    ';': SY := SEMICOLON;
    '^','@@': SY := ARROW;
    '[': SY := LBRACK;
    ']': SY := RBRACK;
    '*': BEGIN SY := MULOP; OP := MUL END;
    '+': BEGIN SY := ADDOP; OP := PLUS END;
    '-': BEGIN SY := ADDOP; OP := MINUS END;
    '/': BEGIN SY := MULOP; OP := RDIV END;
    '<': BEGIN SY := RELOP;
	 CASE SYMBUF[SYMCURSOR+1] OF
	   '>': BEGIN OP := NEOP; SYMCURSOR := SYMCURSOR+1 END;
	   '=': BEGIN OP := LEOP; SYMCURSOR := SYMCURSOR+1 END;
	   otherwise op := ltop
	   END; { case }
	 END;
    '=': BEGIN SY := RELOP; OP := EQOP END;
    '>': BEGIN SY := RELOP;
	 IF SYMBUF[SYMCURSOR+1]='=' THEN
	   BEGIN OP := GEOP;
	   SYMCURSOR := SYMCURSOR+1;
	   END
	 ELSE OP := GTOP;
	 END;
    otherwise
	 begin
	 IF SYMBUF[SYMCURSOR] = EOL THEN
	   begin
	   if importexportext then
	     begin
	     symcursor := symcursor + 1;
	     outputsymbol;
	     symcursor := symcursor - 1;
	     end;
	   CHECKEND;
	   symbolstart := symcursor;
	   end
	 ELSE
	   begin
	   symcursor:=symcursor+1;
	   if not skipping then ERROR(98);
	   end;
	 GOTO 1 {try again}
	 end
    END; (* CASE SYMBUF[SYMCURSOR] OF *)
  SYMCURSOR := SYMCURSOR+1;     (* NEXT CALL TALKS ABOUT NEXT TOKEN *)
  if skipping then goto 1;      (* Ignore token found if skipping=true *)
  if importexportext and not (sy = implmtsy) then
    outputsymbol;
  END; (*INSYMBOL*)

PROCEDURE SKIP (*FSYS: SETOFSYS*);
  BEGIN
  WHILE NOT (SY IN FSYS) DO INSYMBOL
  END;

procedure iowrapup(*term: termtype*);
  begin
  close(source,'normal');
  try
    $ovflcheck on$
    SCREENDOTS := SCREENDOTS+1
    $if not ovflchecking$
      $ovflcheck off$
    $end$
  recover
    if escapecode = -4 then screendots := 1
    else escape(escapecode);
  linenumber := linenumber+1;
  if linenumber > 65534 then
    linenumber := 0;
  relinum := relinum + 1;
  IF (LIST=listfull) or listopen and (curerr>0) THEN
    BEGIN       {print last line}
    fixupend;
    symcursor := symcursor+1;
    if printlastline then PRINTLINE;
    END;
  IF listopen THEN
    begin       {Report error count}
    if (totalerrors>0) or (pagecount > 0) or
       (totalwarnings>0) then
      begin
      if term = abort then
	begin
	incrlinecount; writeln(lp);
	incrlinecount; writeln(lp,'COMPILATION ABORTED');
	end;
      incrlinecount; writeln(lp);
      incrlinecount;
      if totalerrors > 0 then
	begin write(lp,totalerrors:1);
	if totalerrors = 1 then
	  write(lp,' error. ')
	else
	  write(lp,' errors. ');
	if lasterrln <> 0 then
	   write(lp,'See line ',lasterrln:1,'. ');
	end
      else write(lp,'No',' errors. ');
      if totalwarnings > 0 then
	begin
	write(lp,totalwarnings:1);
	if totalerrors = 1 then
	  write(lp,' warning.')
	else
	  write(lp,' warnings.');
	end
      else write(lp,'No',' warnings.');
      writeln(lp);
      if modcal or ucsd or sysprog then
	writeln(lp,'':15,'***** Nonstandard language features enabled *****');
      page(lp);
      end;
    end;
  WRITELN(OUTPUT);
  if term = abort then
    begin
    writeln(output,'COMPILATION ABORTED');
    writeln(output,'in ':8,
			fibp(addr(source))^.ftid,
			' at offset ',relinum:1);
    end;
  writeln(output);
  if not printlastline then
    screendots := screendots - 1;
  WRITE(OUTPUT,SCREENDOTS:1,' lines,  ');

  if totalerrors=0 then write(output,'No')
  else write(output,totalerrors:1);
  if totalerrors=1 then write(output,' error. ')
  else write(output,' errors. ');

  if totalwarnings=0 then write(output,'No')
  else write(output,totalwarnings:1);
  if totalwarnings=1 then writeln(output,' warning.')
  else writeln(output,' warnings.');

  if modcal or ucsd or sysprog then
    writeln(output,'***** Nonstandard language features enabled *****');
  if listabort then
    writeln(output,'Listing aborted');
  end; (*iowrapup*)

function getfid(anyvar s: fid) : fid;
  var
    i: shortint;
  begin
  if suffix(s) <> datafile then
    begin
    i := strlen(s);
    while (s[i] <> '.') do
      i := i - 1;
    getfid := str(s,1,i-1);
    end
  else { no suffix }
    getfid := s;
  end;

procedure compioinit;
  var
    listfile: fid;
  begin {compio initialization body}
  new(sourceinfoptr);
  if userinfo^.gotsym then
    sourcefilename := userinfo^.symfid
  else
    begin
    write(output,'Compile what text? ');
    readln(input,sourcefilename);
    fixname(sourcefilename,textfile);
    if sourcefilename='' then
      if streaming then escape(-1)
		   else escape(0);
    end;
  repeat
    ok := opensource(sourcefilename,1,false);
    if not ok then
      if streaming then
	begin
	error(401);
	escape(-1);
	end
      else
	begin
	if userinfo^.gotsym then
	  write(output,sourcefilename,' ');
	write(output,'not found. file ? ');
	readln(input,sourcefilename);
	fixname(sourcefilename,textfile);
	if sourcefilename='' then escape(-1);
	end;
  until ok;
  writeln(output);
  srcindex := 1;
  ftype := norml;
  skipping := false; ccinif := false; inoption := false;
  endofprog := false; width := 110;
  with fibp(addr(source))^ do
    if fkind = textfile  then
      begin
      filepos := pagesize;
      fpos := filepos;
      end
    else
      filepos := 0;
  symblk := 0;
  getnextpage;            {fill source buffer}
  listPC := false;
  write(output,'Printer listing (l/y/n/e)? ');
  repeat
    read(keyboard,ch);
    if not (ch in ['y','Y','n','N','e','E','l','L']) and
       streaming then escape(-1);
  until ch in ['y','Y','n','N','e','E','l','L'];
  writeln(output,ch);
  if ch >= 'a' then ch := chr(ord(ch)-32);    {uppercase it}
  list_option_L := false;
  if ch = 'N' then
    begin
    list := listnone; listopen := false;
    end
  else if ch = 'L' then
    begin
    list_option_L := true;
    list := listfull;
    listopen := false;
    writeln(output);
    repeat
      write(output,'What listing file? ');
      readln(listfile);
      fixname(listfile,textfile);
      rewrite(lp,listfile);
      if ioresult = ord(inoerror) then
	listopen := true
      else
	if streaming then escape(-10)
	else writeln('Error opening file');
    until listopen;
    end
  else
    begin
    if ch = 'Y' then list := listfull
    else list := listerronly;
$ALLOW_PACKED ON$
    rewrite(lp,'PRINTER:'
	       + getfid(fibp(addr(source))^.ftid)
	       + '.ASC');
$ALLOW_PACKED OFF$
    listopen := ioresult = ord(inoerror);
    end;
  linespp := linesperpage;
  linecount := maxint-1;
  initlistmode := LIST; pagewidth := 120;
  pagecount := 0; curerr := 0; relinum := 0; lasterrln := 0;
  end; {compioinit}


@


55.1
log
@Automatic bump of revision number for PWS version 3.25A
@
text
@@


54.1
log
@Automatic bump of revision number for PWS version 3.24
@
text
@@


53.1
log
@Automatic bump of revision number for PWS version 3.24B
@
text
@@


52.1
log
@Automatic bump of revision number for PWS version 3.24A
@
text
@@


51.1
log
@Automatic bump of revision number for PWS version 3.24d
@
text
@@


50.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@@


49.1
log
@Automatic bump of revision number for PWS version 3.24b
@
text
@@


48.1
log
@Automatic bump of revision number for PWS version 3.24a
@
text
@@


47.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


46.1
log
@Automatic bump of revision number for PWS version 3.23
@
text
@@


45.1
log
@Automatic bump of revision number for PWS version 3.23C
@
text
@@


44.1
log
@Automatic bump of revision number for PWS version 3.23B
@
text
@@


43.1
log
@Automatic bump of revision number for PWS version 3.23aA
@
text
@@


42.1
log
@Automatic bump of revision number for PWS version 3.23e
@
text
@@


41.1
log
@Automatic bump of revision number for PWS version 3.23d
@
text
@@


40.2
log
@

        Added code to restore putcode to it's previous
        value if it is currently false. For FSDdt04001.
@
text
@@


40.1
log
@Automatic bump of revision number for PWS version 3.23c
@
text
@d564 1
@


39.1
log
@Automatic bump of revision number for PWS version 3.23b
@
text
@@


38.1
log
@Automatic bump of revision number for PWS version 3.23a
@
text
@@


37.3
log
@
  Corrected typing error from previous change.
@
text
@@


37.2
log
@
Change made to routine NUMBER in file SCANNER to fix FSDdt02041 -
'compiler will not handle (. .) notation correctly'.
@
text
@d1211 1
a1211 1
      IF (SYMBUF[SYMCURSOR+1]<>'.' AND SYMBUF[SYMCURSOR+1] <> ')') THEN
@


37.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@d1209 3
a1211 1
      IF SYMBUF[SYMCURSOR+1]<>'.' THEN      (* WATCH OUT FOR '..' *)
@


36.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


35.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


34.1
log
@Automatic bump of revision number for PWS version 3.22
@
text
@@


33.1
log
@Automatic bump of revision number for PWS version 3.22D
@
text
@@


32.1
log
@Automatic bump of revision number for PWS version 3.22C
@
text
@@


31.1
log
@Automatic bump of revision number for PWS version 3.22B
@
text
@@


30.1
log
@Automatic bump of revision number for PWS version 3.22A
@
text
@@


29.1
log
@Automatic bump of revision number for PWS version 3.22b
@
text
@@


28.1
log
@Automatic bump of revision number for PWS version 3.3b
@
text
@@


27.1
log
@Automatic bump of revision number for PWS version 3.3a
@
text
@@


26.1
log
@Automatic bump of revision number for PWS version 3.3 Synch
@
text
@@


25.1
log
@Automatic bump of revision number for PWS version 3.2Y
@
text
@@


24.3
log
@Code added to number parsing to generate a warning when a blank is in the
exponent field of a real constant.
@
text
@@


24.2
log
@Carrage returns inside comments in the interface section must be written
to the interface section of the code file.  These are handled in COMMENTER.
@
text
@d1225 3
@


24.1
log
@Automatic bump of revision number for PWS version 3.2
@
text
@d1093 11
a1103 1
      WHILE SYMBUF[SYMCURSOR] = EOL DO CHECKEND;
@


23.1
log
@Automatic bump of revision number for PWS version 3.2P
@
text
@@


22.1
log
@Automatic bump of revision number for PWS version 3.2N
@
text
@@


21.1
log
@Automatic bump of revision number for PWS version 3.2M
@
text
@@


20.1
log
@Automatic bump of revision number for PWS version 3.2L
@
text
@@


19.1
log
@Automatic bump of revision number for PWS version 3.2K
@
text
@@


18.1
log
@Automatic bump of revision number for PWS version 3.2J
@
text
@@


17.1
log
@Automatic bump of revision number for PWS version 3.2I+
@
text
@@


16.1
log
@Automatic bump of revision number for PWS version 3.2I
@
text
@@


15.1
log
@Automatic bump of revision number for PWS version 3.2H
@
text
@@


14.2
log
@Fixes to remove packed elements passed with anyvar
@
text
@@


14.1
log
@Automatic bump of revision number for PWS version 3.2G
@
text
@d58 1
d60 1
d330 1
d332 1
d365 1
d367 1
d374 1
d376 1
d392 1
d394 1
d1176 1
d1178 1
d1266 1
d1268 1
d1601 1
d1605 1
@


13.1
log
@Automatic bump of revision number for PWS version 3.2F
@
text
@@


12.1
log
@Automatic bump of revision number for PWS version 3.2E
@
text
@@


11.1
log
@Automatic bump of revision number for PWS version 3.2D
@
text
@@


10.1
log
@Automatic bump of revision number for PWS version 3.2C
@
text
@@


9.1
log
@Automatic bump of revision number for PWS version 3.2B
@
text
@@


8.1
log
@Automatic bump of revision number for PWS version 3.2A
@
text
@@


7.1
log
@Automatic bump of revision number for PWS version 3.2l
@
text
@@


6.2
log
@Pws2unix automatic delta on Wed Nov 19 15:16:12 MST 1986
@
text
@@


6.1
log
@Automatic bump of revision number for PWS version 3.2k
@
text
@d195 1
a195 1
    with fibp(addr(source))^ do begin
a200 1
    end;
@


5.1
log
@Automatic bump of revision number for PWS version 3.2j
@
text
@@


4.3
log
@Pws2unix automatic delta on Tue Oct 28 10:57:29 MEZ 1986
@
text
@@


4.2
log
@When open uxfile, tell am to expand tabs.
@
text
@a195 4
      if fkind = uxfile then begin
	{ tell am to expand tabs }
	fb0 := false; fb1 := true;
      end;
@


4.1
log
@Automatic bump of revision number for PWS version 3.2i
@
text
@d195 5
a199 1
    with fibp(addr(source))^ do
d205 1
@


3.1
log
@Automatic bump of revision number for PWS version 3.2h
@
text
@@


2.1
log
@Auto bump rev number to 2.1 for sys 3.2e.
@
text
@@


1.1
log
@Initial revision
@
text
@@
