                        {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;
        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
      IF SYMBUF[SYMCURSOR+1]<>'.' THEN      (* WATCH OUT FOR '..' *)
        BEGIN
         if SYMBUF[SYMCURSOR+1]<>')' THEN (* WATCH OUT FOR '.)' *)
          begin
           TIPE := REALTIPE;
           SYMCURSOR := SYMCURSOR+1;
           WHILE (SYMBUF[SYMCURSOR]>='0') AND (SYMBUF[SYMCURSOR]<='9') DO
           SYMCURSOR := SYMCURSOR+1;     {scan fractional part}
          end;
        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}


