!                                                                 finput3a
! 26/04/87 - correct text generated for too many continuations
!          - missing ENDDO faulted
!                                                                    finput2a
! 18/02/87 - correct parameter to call of selectoutput in routine cklab
!                                                                finput1a
! 15/01/87 - insert %alias for in number
!
!                                                               finput1
! 16/11/86 - incorporate changes up to ftninput19
! 10/10/86 - insert include files
!                                                               ftninput18
! 01/10/86 - give error line if only listing is object
!*                                                              ftninput17
! 06/09/86 - inhibit listings of include files unless requested
! 02/08/86 - support EBCDIC on Amdahl
!*                                                              ftninput16
!* 10/06/86 allow '...' '....' (in formats)
!* 07/06/86 Gould extensions
!* 04/06/86 align dp consts                                     ftninput15
!* 22/04/86 allow for NatSemi hex const reversal
!* 26/11/85 avoid spurious * continuation marker in List Source Line
!* 21/09/85 allow Q consts on IBM
!* 30/08/85 change to use In Number for numeric conversion
!* 07/06/85 J140 Read Line - avoid possible misinterpretation of .<lett>.
!* modified 21/02/85
!*
%include "ftn_ht"
{%include "ftn_consts3"}
!* modified 23/09/86
!*
!*
%constinteger WSCALE = 2;! scale word address to byte address
%constinteger BSCALE = 0;! scaling factor for words to architectural units
%constinteger CSCALE = 0;! byte offset to architectural unit offset
%constinteger DSCALE = 2;! dict pointer scaling in RES records
!*
%constinteger W1 =  4 ;!  1 word  in architectural units
%constinteger W2 =  8 ;!  2 words in architectural units
%constinteger W3 = 12 ;!  3 words in architectural units
%constinteger W4 = 16 ;!  4 words in architectural units
!*
%constinteger TRIADLENGTH    = 12 ;! size of an individual triad
%constinteger BLRECSIZE      = 44 ;! size of a block table entry in architectural units
%constinteger LOOPRECSIZE    = 16 ;! size of a loop table entry
%constinteger PROPRECSIZE    = 12 ;! size of a propagation table entry
%constinteger CLOOPSZ        = 12 ;! size of cloop table entry
%constinteger FRSIZE         =  8 ;! size of freelist created by PUSHFREE
%constinteger TESZ           = 20
%constinteger DTSZ           = 20
%constinteger ARTICSZ        =  4
%constinteger CTSIZE         =  2 ;! used in OP3
%constinteger EXTNSIZE       =  4 ;! used in OP3
!*
!* following used in strength reduction
!*
%constinteger RDSZ           =  8
%constinteger RUSESZ         = 12
%constinteger RTESTSZ        =  4
%constinteger RDEFSZ         = 16
%constinteger USESZ          = 32
%constinteger SRUSESZ        =  2
%constinteger SRSCALE        =  2;! SR==RECORD(ABLOCKS + SRPTR<<SRSCALE)
%constinteger SRFIXED        = 36
!*
!*
%conststring(5) REG1="reg7"
%constinteger GLAOFFSET=32
%if target=ibm %thenstart
   %constinteger dvarea=7
%finishelsestart
   %constinteger DVAREA=2
%finish
!*
!***********************************************************************
!* Constants defining the size of DICT records                         *
!***********************************************************************
!*
   %constinteger IDRECSIZE    = 28;! size of dict entry reserved for a new identifier
   %constinteger CONRECSIZE   = 16
   %constinteger CNSTRECMIN   =  4
   %constinteger IMPDORECSIZE = 12;! size of DATA-implied-DO list item
   %constinteger LABRECSIZE   = 40
   %constinteger PLABRECSIZE  =  8;! N.B. this is a reduced size for compiler using Put interfaces
   %constinteger XREFSIZE     =  8
   %constinteger CMNRECEXT    = 16;! extra space on iden record for common block name
   %constinteger TMPRECSIZE   = 20
   %constinteger DVRECSIZE    = 28
   %constinteger TRIADSIZE    = 12
   %constinteger LBLKSIZE     = 520
!*
!*
!********************* TRIAD qualifiers ********************************
!*
%CONSTINTEGER NULL    = 0
%CONSTINTEGER LABID   = 1
%CONSTINTEGER PLABID  = 2
%CONSTINTEGER PROCID  = 3
%CONSTINTEGER STKLIT  = 4
%CONSTINTEGER GLALIT  = 5
%CONSTINTEGER SRTEMP  = 6
%CONSTINTEGER BREG    = 7
%CONSTINTEGER VALTEMP = 8
%CONSTINTEGER DESTEMP = 9
%CONSTINTEGER LSCALID =16
%CONSTINTEGER OSCALID =17
%CONSTINTEGER CSCALID =18
%CONSTINTEGER ASCALID =19
%CONSTINTEGER PSCALID =20
%CONSTINTEGER ARRID   =21
%CONSTINTEGER TMPID   =22
%CONSTINTEGER PERMID  =23
%CONSTINTEGER STFNID  =24
%CONSTINTEGER ITMPID  =22
%CONSTINTEGER RTMPID  =22
%CONSTINTEGER ETMPID  =22
%CONSTINTEGER TRIAD   =32
%CONSTINTEGER ARREL   =33
%CONSTINTEGER CHAREL  =34
%CONSTINTEGER CHVAL   =35
%CONSTINTEGER LIT     =64
%CONSTINTEGER NEGLIT  =65
%CONSTINTEGER CNSTID  =66
!*
!********************* TRIAD masks *************************************
!*
%CONSTINTEGER CONSTMASK=X'40'
%CONSTINTEGER IDMASK   =X'10'
%CONSTINTEGER TEXTMASK =X'20'
!*
!********************* other useful masks ******************************
!*
%CONSTINTEGER ARRAYBIT  = X'04'
%CONSTINTEGER CMNBIT    = X'02'
%CONSTINTEGER EQUIVBIT  = X'80'
!*
!********************* modes *******************************************
!*
%CONSTINTEGER INT2    = 0, INT4    = 1, INT8    = 2
%CONSTINTEGER REAL4   = 3, REAL8   = 4, REAL16  = 5
%CONSTINTEGER CMPLX8  = 6, CMPLX16 = 7, CMPLX32 = 8
%CONSTINTEGER LOG1    = 9, LOG2    =10, LOG4    =11
%CONSTINTEGER LOG8    =12, CHARMODE=13, HOLMODE =14
%CONSTINTEGER BYTE    =15, HEXCONST=16
!*
!********************* types *******************************************
!*
%CONSTINTEGER INTTYPE   = 1
%CONSTINTEGER REALTYPE  = 2
%CONSTINTEGER CMPLXTYPE = 3
%CONSTINTEGER LOGTYPE   = 4
%CONSTINTEGER CHARTYPE  = 5
!*
!********************* scaling factors *********************************
!*
!*
!********************* length of maximum source statement **************
!*
%CONSTINTEGER INPUT LIMIT = 1328
!*
!********************* mode to size/type *******************************
!*
%CONSTBYTEINTEGERARRAY MODETOST(0:15)=  %C
   X'41',X'51',X'61',X'52',X'62',X'72',
   X'53',X'63',X'73',X'34',X'44',X'54',X'64',5,0,X'31'
!*
!********************* mode to bytes etc. ******************************
!*
%CONSTBYTEINTEGERARRAY CSIZE(0:15)=  %c
   2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
%CONSTBYTEINTEGERARRAY ModetoBytes(0:15)=  %c
   2,4,8,4,8,16,8,16,32,1,2,4,8,1,0,1
%CONSTBYTEINTEGERARRAY ModetoTempBytes(0:15)=  %c
   4,4,8,4,8,16,8,16,32,4,4,4,8,4,4,4
%CONSTBYTEINTEGERARRAY SETMODE(0:63)= %C
0(4),10,13,0(11),1,3,6,11,0(12),2,4,7,8,0(12),15,5,8,9,0(11)
!*
!********************** location of pseudo common record in dict *******
!*
%CONSTINTEGER PSEUDOCMN=20
!*
!********************** location of blank common record in dict ********
!*
%CONSTINTEGER BLCMPTR=96
!*
!********************** other useful consts ****************************
!*
%CONSTINTEGER NO  = 0
%CONSTINTEGER YES = 1
%CONSTINTEGER FULL= 2
!*
!********************** area identifiers *******************************
!*
%constinteger STACK   = 0
%CONSTINTEGER GLA     = 2
%CONSTINTEGER SST     = 4
%CONSTINTEGER GST     = 5
%CONSTINTEGER DIAGS   = 6
%if target=ibm %thenstart
   %constinteger scalars=7
%finishelsestart
   %CONSTINTEGER SCALARS = 2
%finish
%CONSTINTEGER IOAREA  = 8
%CONSTINTEGER ZEROGST = 9
%CONSTINTEGER CONSTS  =10
!*
!********************** system procedures ******************************
!*
%constinteger F77AUX   = 0
%constinteger F77STOP  = 1
%constinteger F77PAUSE = 2
%constinteger F77IOA   = 3
%constinteger F77IOB   = 4
%constinteger F77IOC   = 5
%constinteger F77IOD   = 6
%constinteger F77IOE   = 7
%constinteger F77IOF   = 8
%constinteger F77FILE  = 9
%constinteger IMPSTOP  =10
%constinteger F77RTERR =11
%constinteger F77IOAR  =12
%constinteger F77IOBR  =13
%constinteger F77IOG   =14
%constinteger F77CPSTR =15
%constinteger F77CONCAT=16
%constinteger F77INDEX =17
%constinteger FIBITS   =18
%constinteger FISHFTC  =19
%constinteger F77PCHECK=20
%constinteger F77IOH   =21
%constinteger F77IOI   =22
!***********************************************************************
!*
{%include "ftn_options2"}
!*
%constinteger Dbugcol1     = 1
%constinteger Xbugcol1     = 2
%constinteger Ybugcol1     = 4
%constinteger Defreal8     = 8
%constinteger Listinc      = x'10'
%constinteger genprof      = x'20'
%constinteger inhiberrs    = x'40'
%constinteger dovectorize  = x'80'
%constinteger opt4inclist  = x'100'
%constinteger opt4exclist  = x'200'
{%include "ftn_fmts2"}
!* 09/12/85 - add recordformat SUBFMT
!* modified 14/03/85
!*
!***********************************************************************
!* Formats for accessing dictionary records                            *
!***********************************************************************
!*
%recordformat PRECF(%byteinteger CLASS,TYPE,X0,X1,
                    %integer LINK1, LINK2,
                   (%shortinteger COORD,LINK3  %OR %integer LAST   %C
                        %OR %integer CONSTRES %OR %integer INF3),
                    %integer ADDR4,
                    %shortinteger DISP,LEN,IDEN,IIN,
                    %integer LINE,XREF,CMNLENGTH,CMNREFAD)
!*
%recordformat SRECF(%integer INF0, LINK1, INF2, INF3, INF4)
!*
%recordformat RESF((%integer W %OR %shortinteger H0,
                      (%shortinteger H1 %OR %byteinteger FORM,MODE)))
!*
%recordformat DORECF( %C
    %integer LABEL, LINK1,
    %record(RESF) LOOPAD, ENDREF, INDEXRD, INCRD, FINALRD, ICRD,
    %integer LABLIST,LINE)
!*
%recordformat BFMT(%integer L,U,M)
!*
%recordformat ARRAYDVF(%integer DIMS, ADDRDV,ADDRZERO,  %C
            %integer ZEROTOFIRST, ADFIRST, NUMELS, ELLENGTH,  %C
            %record(BFMT) %ARRAY B(1 : 7))
!*
!*
%recordformat LRECF(%integer NOTFLAG,LINK1,
                    %record(RESF) ORLAB,ANDLAB,
                    %integer RELOP)
!*
%recordformat IFRECF(%integer TYPE,LINK1,
                     %record(RESF) ENDIFLAB,FALSELAB,
                     %integer LABLIST,LINE)
!*
%recordformat LABRECF(%shortinteger BLKIND,%byteinteger X0,X1,  %C
            %integer LINK1,LINK2,LINK3,ADDR4,LINK5,LAB,LINE,  %C
            %shortinteger DOSTART,DOEND,IFSTART,IFEND)
!*
%recordformat PLABF(%shortinteger BLKIND,%byteinteger USE,X1,
                    %integer INDEX,CODEAD,REF,REFCHAIN)
!*
%recordformat IMPDORECF(%integer VAL,LINK,IDEN)
!*
%recordformat CONSTRECF(%shortinteger MODE,LENGTH,
                      (%integer VALUE %OR %integer LINK1),
                      %integer DADDR,CADDR)
!*
%recordformat TMPF((%byteinteger CLASS,TYPE,
                        %shortinteger LEN %OR %integer W0),
                    %integer LINK1,
                    %byteinteger REG,MODE,%shortinteger INDEX,
                    %shortinteger COORD,USECNT,
                    %integer ADDR)
!*
%recordformat CHARF(%integer ADESC,LINK,LEN)
!*
%recordformat FNRECF(%integer FPTR,LINK1,HEAD,PCT)
!*
%recordformat TERECF(%shortinteger MODE,LOOP,
                      %integer CHAIN,DISP1,INDEX,
                      %shortinteger COORD,FLAGS)
!*
%recordformat DTRECF(%shortinteger MODE,IDENT,
                      %integer CHAIN,DISP2,
                      %shortinteger FLAGS,INDEX,
                     (%integer LOOP %OR %record(RESF) CONST))
!*
!*
!***********************************************************************
!* TRIAD record format                                                 *
!***********************************************************************
!*
%recordformat TRIADF(  %C
               %byteinteger OP,
               (%byteinteger USE %OR %byteinteger VAL2),
               %shortinteger CHAIN,
               (%record(RESF) RES1      %OR     %C
               (%shortinteger OPD1,%byteinteger QOPD1,MODE  %OR  %C
               (%integer SLN %OR %integer VAL1))),
               (%record(RESF) RES2      %OR   %C
                %shortinteger OPD2,%byteinteger QOPD2,MODE2))
!*
!***********************************************************************
!* COM record format                                                   *
!***********************************************************************
!*
%recordformat COMFMT(%integer CONTROL,OPT,OPTIONS1,OPTIONS2,PTRACE,
      ADICT,ANAMES,ADOUTPUT,ADBLKDTAID,DICLEN,DPTR,
      MAXTRIADS,NEXTPLAB,ALABH,ADLHEAD,
      SUBPROGTYPE,SFPTR,EXTERNALS,CBNPTR,SCPTR,CHECKLIST,
      RESCOM1,RESCOM2,F77PARM,FNO,FAULTY,LINEST,CMNIIN,SFMK,
      LISTL,LISTSTREAM,DIAGSTREAM,LISTMODE,XREF,
      PACKCMN,ITSMODE,PATHANAL,CHARACTER CODE,SPACE CHAR,
      HEADINGS,ARRAYCHECKS,JBRMODE,MESSLEN,NAMESLEN,
      NEXTCH,FUNRESDISP,WARNCOUNT,INP,MAXINP,MESSCOUNT,
      UNASSPATTERN,LISTCODE,PI21INT,DOPTR,SUBPROGPTR,
      FNLST,LAB,NAMESFREE,ALGOLREF,FIRSTSTATNUM,CEXPDICT,
      COMMONBASE,FASTPROLOGUE,STATEMENT,IFPTR,
      CNSTCA,COMMENTCNT,ADIDENT,ADERRIDEN,
      ADEXT,MAXDICT,MAXNAMES,MAXOUTPUT,MAXEXT,
      ACOMP,ASUBNAMES,MAXPSTACK,
      ATRIADS,TRFILEID,TRBLOCK,CMNCNT,SCANONLY,NOISY,
      MAXANAL,MAXGEN,SAVEANAL,SAVEGEN,OPTFLAGS,NEXTBIT,
      ACMNBITS,NEXTTEMP,ASSGOTOS,TMPPTR,DESTEMPS,OBJADDR,
      AREAADDR,PASTART,ADOPTDATA,TMINDEX,VRETURN,ENTRIES,
      EQUCHK,LABWARN,LINENO,MAXIBUFF,
      COMMENTS,DIAGLEVEL,WARNNOT77,WARNLENGTH,ALLOWUNIX,ALLOWVAX,
      ONETRIP,HOST,TARGET,MONERRS,CODECA,
      GLACA,DIAGCA,SSTCA,GSTCA,CONSTCA,SCALARCA,IOAREACA,ZGSTCA,STACKCA,
      W1,W2,W4,STATORDERMODE,CURSTATCLASS,LISTPOINT,STACKBASE,
      NEXTTRIAD,ASAVE,MAXSAVE,SUBTAB,LASTSUBTAB,
      INHIBOP4,ARGCNT,IDCNT,LABCNT,TMLIST,MAINPROG,PROCINDEX,CONSOLE)
!*
!***********************************************************************
!* record format for communicating with optimiser                      *
!***********************************************************************
!*
%recordformat OBJFMT(%string(35) MODULE,%integer MAINEP,I,J,K,
                     ADATE,ATIME,OPTIONS2,EXTPROCS,ATRIADS,MAXTRIADS,
                     ABLOCKS,MAXBLOCKS,ALOOP,MAXLOOP,ATABS,MAXTABS,
                     SRFLAGS,INHIBMASK,OPT,OPTFLAGS,OPTDESC0,OPTDESC1,
                     D1,D2,D3,D4)
!*
!***********************************************************************
!*
!*
%RECORDFORMAT SUBRECF(%INTEGER LINK,FLAGS,TRIADS,DICT,NAMES,PTRS,PROG,
      LABCNT,ARGCNT,IDCNT,TRCNT,REFSCNT,SUBSCNT,
      DPTR,NEXTTRIAD,NAMESFREE,NEXTBIT,SUBPROGTYPE,SUBPROGPTR,
      CBNPTR,SCPTR,CMNIIN,FUNRESDISP,CMNCNT,ASSGOTOS,VRETURN,ENTRIES,
      TMLIST,ALABS,ALHEADS,NEXTPLAB,
      %STRING(32) NAME,%INTEGERARRAY COORDS(0:15))
!*
%CONSTINTEGER SUBSIZE=232
%CONSTINTEGER LABSIZE=128
%CONSTINTEGER LHEADSIZE=620
!*
!*
!***********************************************************************
!* Exports                                                             *
!***********************************************************************
!*
%routinespec Init Input(%integer Acom)
%routinespec List Line
%routinespec Read Next
%integerfnspec Include File(%string(255) Name)
%routinespec Fault(%integer er)
%routinespec Ifault(%integer er,val)
%routinespec Lfault(%integer er)
%routinespec Tfault(%integer E,Ta,Tb)
%integerfnspec Readline(%byteintegerarrayname Input,Type,%integername Ltype)
%routinespec First Stat
%integerfnspec Next Label
%integerfnspec Set Constant(%integer P1,
                            %integername Pi21length,Pi21mode,Ctyp,Er,
                            %record(Resf)%name Res,
                            %byteintegerarrayname Input,Type)
%routinespec Cklab
!*
!***********************************************************************
!* Imports                                                             *
!***********************************************************************
!*
%externalroutinespec Source Line(%integer Atbuff)
%externalintegerfnspec Select Include(%string(255) Name)
%externalroutinespec Faultnum(%integer er,comad,update)
%externalintegerfnspec Warncheck(%integer Er,Comad)
%externalintegerfnspec In Number %alias "s#innumber" %c
                         (%integer Data Ad,Data Len,
                                          Format,Blanks,Decs,Scale,
                                 %integername Textptr,Textend,
                                 %byteintegerarrayname Buffer,Text)
!*
%if Target=IBM %thenstart
   %externalroutinespec Itoe %alias "s#itoe"(%integer ad,len)
%finish
!*
!***********************************************************************
!* OWN variables                                                       *
!***********************************************************************
!*
%ownrecord(comfmt)%name com
%ownbyteintegerarray Tbuff(0:133)
%ownbyteintegerarray Ibuff(0:2121)
%ownintegerarray Chmark(0:2121)
%ownbyteintegerarray prbuff(-13:161)
%ownintegerarray savetbuff(0:209)
%ownintegerarray savelinenum(0:10)
%ownstring(63) diagtext
%owninteger len
%owninteger diagheads
%owninteger comad
%owninteger include level
%owninteger Atbuff
%owninteger REAL LENGTH=4
%owninteger DP LENGTH=8
%owninteger INTEGER LENGTH=4
%owninteger LOGICAL LENGTH=4
!*
!***********************************************************************
!* local consts
!***********************************************************************
!*
%constbyteintegerarray CLASS(0 : 127) =    %C
   X'0F', X'0F', X'0F', X'0F', X'0F', X'0F', X'0F', X'0F',
  {                                                      }
   X'0F', X'17', X'0C', X'0F', X'0F', X'15', X'0F', X'0F',
  {        tab     nl                   cr               }
   X'0F', X'0F', X'0F', X'0F', X'0F', X'0F', X'0F', X'0F',
  {                                                      }
   X'0F', X'0D', X'0F', X'15', X'0F', X'0F', X'0F', X'0F',
  {        eof            cr                             }
   X'00', X'16', X'18', X'0E', X'0E', X'0E', X'8B', X'05',
  {  sp      !      "      #      $      %      &      ' }
   X'14', X'07', X'89', X'8A', X'12', X'8A', X'04', X'89',
  {   (      )      *      +      ,      -      .      / }
   X'83', X'83', X'83', X'83', X'83', X'83', X'83', X'83',
  {   0      1      2      3      4      5      6      7 }
   X'83', X'83', X'8B', X'0E', X'0E', X'13', X'0E', X'0E', 
  {   8      9      :      ;      <      =      >      ? }
   X'0E', X'81', X'81', X'81', X'81', X'81', X'81', X'81',
  {   @      A      B      C      D      E      F      G }
   X'06', X'81', X'81', X'81', X'81', X'81', X'81', X'81',
  {   H      I      J      K      L      M      N      O }
   X'81', X'81', X'81', X'81', X'81', X'81', X'81', X'81',
  {   P      Q      R      S      T      U      V      W }
   X'81', X'81', X'81', X'0E', X'0E', X'0E', X'0E', X'0E',
  {   X      Y      Z      [      \      ]      ^      _ }
   X'0E', X'11', X'11', X'11', X'11', X'11', X'11', X'11',
  {   `      a      b      c      d      e      f      g }
   X'11', X'11', X'11', X'11', X'11', X'11', X'11', X'11',
  {   h      i      j      k      l      m      n      o }
   X'11', X'11', X'11', X'11', X'11', X'11', X'11', X'11',
  {   p      q      r      s      t      u      v      w }
   X'11', X'11', X'11', X'0E', X'0E', X'0E', X'0E', X'10'
  {   x      y      z     -(      |     )-      ~    del }
!*
%ownintegerarray COMPAR(1 : 6) =  %C
   M'GT',M'LT',M'NE',M'EQ',M'GE',M'LE'
!*
!*
!***********************************************************************
!*
{%include "ftn_copy1"}
!* modified 23/09/86
!*
%routine Copy(%integer Length,Fbase,Fdisp,Tbase,Tdisp)
!***********************************************************************
!* copy Length bytes from fbase(fdisp) to tbase(tdisp)                 *
!***********************************************************************
%integer I,From,To
      %if Length<=0 %then %return
      From=Fbase+Fdisp
      To=Tbase+Tdisp
      %cycle I=0,1,Length-1
         byteinteger(To+I)=byteinteger(From+I)
      %repeat
%end;! Copy
!*
%routine Putbyte(%integer Val,Base,Offset)
      byteinteger(Base+Offset)=VAL
%end;! Putbyte
!*
!*
%externalroutine Init Input(%integer Acom)
      comad=acom
      com==record(acom)
      diagtext=""
      include level=0
      atbuff=addr(Tbuff(0))
      %if Com_Liststream#-1 %then selectoutput(Com_Liststream)
%end;! init iniput
!*
!*
%externalroutine List Line
      %IF COM_LISTL=0 %THEN %RETURN
      %if include level>0 %and Com_Options2&Listinc=0 %then %return
      WRITE(COM_LINENO+1,5)
      SPACES(5)
      PRINTSTRING(STRING(ATBUFF))
      NEWLINE
%end;! List Line
!*
%externalroutine Read Next
      Com_Lineno=Com_Lineno+1
      Source Line(atbuff)
      %if Tbuff(1)=25 %and include level>0 %thenstart
!         printstring("
!end of include file
!")
         include level=include level-1
         Com_Lineno=savelinenum(include level)
         copy(82,addr(savetbuff(0)),include level*84,atbuff,0)
      %finish
%end;! Read Next
!*
%externalintegerfn Include File(%string(255) name)
%integer i
      %if include level=10 %then %result=336;! to many nested includes
      copy(82,atbuff,0,addr(savetbuff(0)),include level*84)
!      printstring("
!selecting -".name."
!")
      i=select include(name)
!      printstring("
!result=")
!      write(i,3)
!      newline
      %if i#0 %then %result=335;! file not available
      savelinenum(include level)=Com_Lineno
      Com_Lineno=-1
      include level=include level+1
{      Com_Lineno=Com_Lineno-1}
      Read Next
      %result=0
%end;! include file
!*
!*
!*
%ROUTINE LIST SOURCE LINE
!***********************************************************************
!* reconstruct last line                                               *
!***********************************************************************
%INTEGER I, J, K, Count
      Count=0
      %RETURN %IF COM_LINENO=0;! EMPTY FILE
      WRITE(COM_LINEST,5)
      %IF COM_LAB = 0 %THENSTART
         SPACES(10)
      %FINISHELSE WRITE(COM_LAB,9)
      SPACE
      PRINTSYMBOL(IBUFF(7))
      I = 8
L1:   J = IBUFF(I)
      %if J=' ' %thenstart
         K=1
L3:      %if Ibuff(I+1)=NL %then newline %and %return
         %if I-6 = (I-6)//66*66 %then -> L2
         I=I+1
         J=Ibuff(I)
         %if J=NL %then newline %and %return
         %if J=' ' %then K=K+1 %and -> L3
         spaces(K)
      %finish
      PRINTSYMBOL(J)
      %UNLESS J=NL %THENSTART
L2:      %IF I-6 = (I-6)//66*66 %THENSTART
            NEWLINE
            Count=Count+1
            %if Count=20 %then %return
            SPACES(16)
            PRINTSYMBOL('*')
         %FINISH
         I = I+1
         -> L1
      %FINISH
%END;! LIST SOURCE LINE
!*
!*
%ROUTINE POINT(%INTEGER J)
      %IF 0<J<COM_MAXIBUFF %THENSTART
         SPACES(10+J)
         PRINTSYMBOL('^')
      %FINISH
      NEWLINE
%END;! POINT
!*
!* Com_Listmode = 0  no listing
!*                1  listing, diagstream = liststream
!*                2  listing, diagstream # liststream
!*
%EXTERNALROUTINE FAULT(%INTEGER ER)
%integer I,J,Mode
      Mode=Com_Listmode
      %if Warncheck(Er,Comad)#0 %then %return
      J = 6
      %IF COM_INP>0 %THENSTART
         J=CHMARK(COM_INP)
         %WHILE J>72 %CYCLE
            J = J-66
         %REPEAT
         %IF Er=100 %OR Er=106 %THEN Com_Pi21int=J
      %FINISHELSE J=0
      %if Mode<2 %thenstart
         selectoutput(Com_Diagstream)
         List Source Line
         Point(J)
         %if Mode=1 %then I=0 %else I=1
         Faultnum(Er,Comad,I)
         newline
         selectoutput(Com_Liststream)
      %finish
    { Querystop }
      %if Mode>0 %thenstart
         %if Com_Listl=0 %then List Source Line
         Point(J)
         Faultnum(Er,Comad,1)
         newline
      %finish
%END
!*
%EXTERNALROUTINE LFAULT(%INTEGER ER)
%integer I,Mode
      Mode=Com_Listmode
      %if Warncheck(Er,Comad)#0 %then %return
      %if Mode<2 %thenstart
         selectoutput(Com_Diagstream)
         %if Er#101 %and  Er#102 %thenstart;! EXCEPT CONTINUATION ON FIRST STATEMENT
            %unless Er=303 %or 323<=Er<=329 %then List Source Line;! except for missing END
         %finish
         %if Mode=1 %then I=0 %else I=1
         newline
         Faultnum(Er,Comad,I)
         newline
         selectoutput(Com_Liststream)
      %finish
    { Querystop }
      %if Mode>0 %thenstart
         %if Com_Listl=0 %then List Source Line
         newline
         Faultnum(Er,Comad,1)
         newline
      %finish
%END
!*
!*
%externalroutine Tfault(%integer E,Ta,Tb)
      STRING(COM_ADIDENT)=STRING(TA)
      %IF TB#0 %THEN STRING(COM_ADERRIDEN)=STRING(TB)
      LFAULT(E)
%end;! Tfault
!*
%externalroutine Ifault(%integer E,I)
      Com_Pi21int=I
      LFAULT(E)
%end;! Ifault
!*
!*
%externalroutine Cklab
!***********************************************************************
!* CHECK FOR LABELS NOT SET AT END OF SUBPROGRAM                       *
!***********************************************************************
%INTEGER I, J,PTR,Any
      Any=0
%RECORD(LABRECF)%NAME LABREC
%INTEGER LABH
      LABH=COM_ALABH
      I = 0
      %cycle J = 0,1,31
         PTR = integer(Labh)
         Labh=Labh+W1
         %while PTR # 0 %cycle
            LABREC == RECORD(COM_ADICT+PTR)
            %if LABREC_LINE = 0 %and LABREC_LAB#0 %thenstart;  ! LABEL NOT SET
               Any=1
               Com_Pi21int=LABREC_LAB
               %if Com_Listmode<2 %thenstart
                  selectoutput(Com_Diagstream)
                  %if Com_Listmode=1 %then I=0 %else I=1
                  Faultnum(111,COMAD,I)
                  selectoutput(Com_Liststream)
               %finish
               %if Com_Listmode>0 %thenstart
                  Faultnum(111,COMAD,1)
               %finish
            %finish
            PTR = LABREC_LINK1
         %repeat
      %repeat
      %if Any=0 %and Com_Doptr#0 %then Lfault(369);! missing END DO
%end;                                   ! Cklab
!*
%externalintegerfn Readline(%byteintegerarrayname Input,Type,
                            %integername Ltype)
%integer I,J,K,L,M,N,P,KK,JJ, COUNT,BPTR,CONT,INLEN
%integer BC,EQ,COMMA,ER,IFRB,CHPTR,Quote
%integer P1,P2
%recordFORMAT BBF((%integer W %or %BYTEINTEGER B0,B1,B2,B3))
%record(BBF) BB
%integer II,III
%constinteger BS=8
%constinteger TAB=9
%constinteger NL=10
%constinteger NP=12
%constinteger CRET=13
%SWITCH T(0 : 27)
%integer ATBUFF,AIBUFF,AINPUT
%ownintegerarray Cstart(0:31)
!*
%routine Reset
      Com_Linest = Com_Lineno+1
      Com_Inp = 1
      P = 1
      M = 0
      COMMA = 0
      EQ = 0
      BC = 0
      Com_Lab = 0
      CONT = 0
      IFRB=0
%end
!*
%integerfn Ucchar(%integer N)
%integer I
      I=Input(N)
      %if 'a'<=I %then %result=I-32 %else %result=I
%end;! Ucchar
!*
      ATBUFF=ADDR(TBUFF(0))
      AINPUT=ADDR(Input(0))
      AIBUFF=ADDR(IBUFF(0))
      Cstart(0)=1
EOF:  I=TBUFF(1)
      %if I = 25 %thenstart
         %if Com_Linest=0 %then I=2 %else I=1
         %result=I
      %finish
LST:  LIST LINE
      %if I=' ' %then ->Notcom
      %if I = 'C' %or I='c' %or I='*' %then ->Getnext
      %if Com_Allowvax=YES %thenstart
         %if I='D' %or i='d' %thenstart
            %if Target=Gould %thenstart
               %if Com_Options2 & Dbugcol1 # 0 %thenstart
                  Tbuff(1)=' '
                  I=' '
                  ->Notcom
               %finish
            %finish
            ->Getnext
         %finish
      %finish
      %if I='!' %then ->Getnext
      %if I=TAB %and Com_Allowvax=YES %then ->Tabs
      ->Notcom
GETNEXT:READNEXT
      I=TBUFF(1)
      J=TBUFF(6)
      %if I = 25 %thenstart
         %if Com_Linest=0 %then %result=2
         %result=1
      %finish
      %if I='&' %then ->Er101 
      %if I=TAB %and Com_Allowvax=YES %thenstart
         List Line
Tabs:    Reset
         %cycle I=1,1,6
            Ibuff(I)=' '
         %repeat
         M=1
         Count=66
         P=7
         ->Copyl
      %finish
      %if J=' ' %then ->Lst;! shortest path
      %if I = 'C' %or I='c' %or I='*' %or J = '0' %then ->Lst
      %if Com_Allowvax=YES %thenstart
         %if I='D' %or I='d' %thenstart
            %if Target=Gould %thenstart
               %if Com_Options2&Dbugcol1#0 %thenstart
                  Tbuff(I)=' '
                  ->NoD
               %finish
            %finish
            ->Lst
         %finish
         %if I='!' %then -> Lst
      %finish
Nod:  %cycle I=1,1,6
         J=Tbuff(I)
         %if J=CRET %then ->Lst
         %if J=TAB %thenstart
            Reset
            %cycle J=1,1,6
               Ibuff(J)=' '
            %repeat
            %cycle J=1,1,I-1
               Ibuff(J)=Tbuff(J)
            %repeat
            M=I
            Count=66
            P=7
            ->Copyl
         %finish
      %repeat
      ->Er101
CLOOP:LIST LINE
      ->MINUS
Notcom:Reset
      COUNT = 72
Copyl:COPY(COUNT,ATBUFF,M+1,AIBUFF,P)
      P = COUNT+P
MINUS:READNEXT
      I=TBUFF(1)
      %if I#' ' %and (I='C' %or I='c' %or I='*') %thenstart
         L=0
         K=0
         %cycle I=1,1,66
            J=IBUFF(I)
            %if J#' ' %thenstart
               L=L<<8!J
               K=K+1
               %if K>3 %thenstart
                  LIST LINE
                  ->MINUS
               %finish
            %finish
         %repeat
         %if L=M'END' %then ->SETIBUF %else ->CLOOP
         LIST LINE
         ->MINUS
      %finish
!*
      %if I=25 %then ->Setibuf
!*
      N=0
      %if Com_Allowvax=YES %thenstart
         %cycle I=1,1,5
            J=Tbuff(I)
            %if J#' ' %thenstart
               %if J=TAB %then ->Setibuf
               %if Com_Allowunix=YES %and J='&' %and I=1 %thenstart
                  M=1
                  ->Checkcont
               %finish
               %if J=CRET %thenstart
                 %if N#0 %then ->Setibuf %else ->Cloop
               %finish
               N=1
            %finish
         %repeat
      %finish
!*
      M = 6
      I=Tbuff(6);! continuation marker
      %if I=' ' %or I='0' %thenstart
         %cycle I=1,1,72
             %if Tbuff(I)#' ' %then ->Setibuf
         %repeat
         %if N#0 %then ->Setibuf %else ->Cloop;! blank line
      %finishelsestart
         %if I=TAB %or I=CRET %then ->Setibuf
      %finish
!*
      %if N#0 %thenstart
         Lfault(102)
         ->Copyl
      %finish
!*
Checkcont:
      Cont = Cont+1
      %if Target=Gould %thenstart
         -> Er103 %if Cont>31
      %finishelsestart
         -> Er103 %if Cont > 19
      %finish
      Cstart(Cont)=P;! noted for exclam comment processing
      Count=66
      List Line
      -> Copyl
!*
SETIBUF: IBUFF(P) = NL
         INLEN=P
!*
         N=0
         %cycle L = 1,1,5
            I = IBUFF(L)
            %if I#' ' %thenstart
               J = CLASS(I)
               %if J=X'83' %thenstart;! digit
                  N=1
                  Com_Lab = 10*Com_Lab+I&15
               %finishelsestart
                  %unless J=21 %thenstart;! unless cr
                     %if J=23 %thenstart;! if tab
                        Bptr=L+1
                        P=0
                        ->Nxtchar
                     %finish
                     LFAULT(108);! non-numeric label
                     Com_Lab=0
                     ->COL7
                  %finish
               %finish
            %finish
         %repeat
         %if N#0 %and Com_Lab=0 %then IFAULT(110,0);! invalid label no.
COL7:    BPTR = 7
         P = 0
         -> NXTCHAR
SETYPE:  TYPE(Com_Inp) = J&31
         Input(Com_Inp) = I
         CHMARK(Com_Inp)=CHPTR
         CHMARK(Com_Inp+1)=CHPTR+1
         Com_Inp = Com_Inp+1
NXTCHAR: I = IBUFF(BPTR)&127;! AVOID FAILURE WITH DUFF CHARS
         J = CLASS(I)
!printstring("
!nxtchr i,j = ")
!write(i,1)
!write(j,1)
!newline
         CHPTR=BPTR
!{PERQ}   %while CHPTR>72 %cycle
!{PERQ}      CHPTR=CHPTR-66
!{PERQ}   %repeat
         BPTR = BPTR+1
LCTOUC:  -> SETYPE %if J >= 128
         -> T(J)
!*
T(0):    ! space
!*
{%include "pf_readline3"}
!*
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!+ scan for all spaces in balance of line could be optimised           +
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!*
{end "pf_readline3"}
!*
         ->NXTCHAR
!*
T(19):   EQ = 2 %if BC = 0             ;! =
         J=11
         ->SETYPE
T(18):   COMMA = 1 %if BC = 0          ;! COMMA
         J=7
         ->SETYPE
T(20):   BC = BC+1                     ;! (
         J=11
         ->SETYPE
T(7):    BC = BC-1                     ;! )
         %if BC=0 %and IFRB=0 %then IFRB=Com_Inp
         ->SETYPE
T(4):                                   ! .
         ->NOTOP %unless TYPE(Com_Inp-1)=1 ;! UNLESS ALPHABETIC
         -> NOTOP %if P = 0 %or Com_Inp-P > 5
!*
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!+ extract the next 4 input characters                                 +
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
         BB_B0=Input(P+1)
         BB_B1=Input(P+2)
         BB_B2=Input(P+3)
         BB_B3=Input(P+4)
         KK=BB_W
!*
         %if Com_Inp-P=5 %thenstart
            %if KK=M'NEQV' %thenstart
               I='#'
OPSET:         Input(P) = I
               TYPE(P)=10
               Com_Inp = P+1
               P=0
               -> NXTCHAR
            %finishelse ->NOTOP
         %finish
         -> A107 %unless Com_Inp-P = 4
         KK=KK>>8
         %if KK=M'AND' %then I='&' %and ->OPSET
         %if KK=M'EQV' %then I='~' %and ->OPSET
         %if KK=M'NOT' %then I='\' %and ->OPSET
         %if KK=M'XOR' %and Com_Allowvax=YES %then I='#' %and ->OPSET
         ->NOTOP
NOTOP:   P = Com_Inp;! note latest . in case start of comparator etc.
         ->SETYPE
A107:    -> Notop %unless Com_Inp-P=3;! J140
         K=KK>>16
         %cycle JJ = 1,1,6
            %if K = COMPAR(JJ) %then -> A106
         %repeat
         -> NOTOP %unless K = M'OR'
         I = '!'
         -> OPSET
A106:    Input(P) = '>'
         Input(P+1) = JJ*2
         TYPE(P)=10
         TYPE(P+1) = 6
         Com_Inp = P+2
         -> NXTCHAR
T(6):    %if Com_Inp < 4 %then -> A111;! H
         K = Com_Inp-1
         %unless TYPE(K) = 3 %then -> A111
A1190:   K = K-1
         -> A111 %if K = 1
         -> A1190 %if TYPE(K) <4
         %if Input(K)='*' %thenstart
            %if TYPE(K+1)<3 %then ->A111 %else ->A1190
         %finish
         -> A111 %if TYPE(K+1) <3
         %cycle K = Com_Inp-1,-1,Com_Inp-4
            -> A110 %unless TYPE(K) = 3
         %repeat
A111:    J = 1
         -> SETYPE
A110:    N = 0
         %cycle M = K+1,1,Com_Inp-1
            N = 10*N+Input(M)&15
         %repeat
         ER = 115;! invalid Holerith constant length
         -> A95 %unless 0 < N <= 256
         Input(Com_Inp) = 'H'
         TYPE(Com_Inp) = 6
         CHMARK(Com_Inp)=CHPTR
         Com_Inp = Com_Inp+1
         ER = 105;! incomplete Hollerith constant
         COPY(N,AIBUFF,BPTR,AINPUT,Com_Inp)
         BPTR=BPTR+N
         Com_Inp=Com_Inp+N
         %if BPTR>INLEN %then ->A95;! HOLLERITH PAST END OF RECORD
         TYPE(Com_Inp-1) = 4
         -> NXTCHAR
T(5):    Quote=''''
Char:    %if Com_Inp>1 %and Input(Com_Inp-1)=Quote %thenstart
            %if Target=Gould %thenstart
               Type(Com_Inp)=18
               Input(Com_Inp)=','
               Chmark(Com_Inp)=Chptr
               Com_Inp=Com_Inp+1
            %finishelsestart
               ->Synerr
             %finish
         %finish
         P1 = Com_Inp+1;! '
         P2 = BPTR
         TYPE(Com_Inp) = 5
A114:    Input(Com_Inp) = I
         CHMARK(Com_Inp)=CHPTR
         Com_Inp = Com_Inp+1
         TYPE(Com_Inp)=0;! to avoid later misclassification ( PI(107) )
         I = IBUFF(BPTR)
         BPTR = BPTR+1
         %if I = NL %thenstart
            Com_Inp = P1
            BPTR = P2
            TYPE(P1-1) = 11
            -> NXTCHAR
         %finish
         %if Com_Allowunix=YES %thenstart
            %if I='\' %thenstart
               I=Ibuff(Bptr)
               Bptr=Bptr+1
               %if I='n' %then I=NL %elsestart
                  %if I='t' %then I=TAB %elsestart
                     %if I='b' %then I=BS %elsestart
                        %if I='f' %then I=NP %elsestart
                           %if I='0' %then I=0 %elsestart
                              %if I=quote %or I='\' %thenstart
                                 Input(Com_Inp)='\'
                                 Chmark(Com_Inp)=Chptr
                                 Com_Inp=Com_Inp+1
                              %finish
                           %finish
                        %finish
                     %finish
                  %finish
               %finish
               ->A114
            %finish
         %finish
         -> A114 %unless I = Quote
         I = IBUFF(BPTR)
         %unless I = Quote %thenstart
            TYPE(Com_Inp) = 11
            Input(Com_Inp) = Quote
            CHMARK(Com_Inp)=CHPTR
            Com_Inp = Com_Inp+1
            -> NXTCHAR
         %finish
Setch:   Input(Com_Inp) = I
         CHMARK(Com_Inp)=CHPTR+1
         Com_Inp = Com_Inp+1
         TYPE(Com_Inp)=0
         BPTR = BPTR+1
         -> A114
Synerr:
T(8):    ER = 100;! syntax error - should not occur here
Faulty:  Chmark(Com_Inp)=Bptr
         Com_Maxibuff=Bptr+1
         FAULT(ER)
         -> EOF
A98:     ER = 109;! brackets not matched
A95:     LFAULT(ER)
         -> EOF
ER103:   ER = 103;! > 19 continuation statements
         -> A95
ER101:   ER = 101;! first statement is a continuation
         -> A95
EOL:
T(12):   Input(Com_Inp) = NL
         TYPE(Com_Inp) = 12
         Com_Maxibuff=BPTR
         %if Com_Inp = 1 %then ->EOF
         -> A98 %unless BC = 0
         LTYPE=COMMA+EQ
         %unless Input(1)='I' %and Input(2)='F' %and Input(3)='('  %C
                                        %then %result=0
         %if Input(IFRB+1)='=' %then %result=0
         LTYPE=LTYPE+4
         BC=1
         %cycle L=4,1,Com_Inp
            I=Input(L)
            %if I='(' %thenstart
               BC=BC+1
            %finishelsestart
               %if I=')' %thenstart
                  BC=BC-1
                  %if BC=0 %thenstart
                     %if Input(L+1)='=' %then LTYPE=2
                     %result=0
                  %finish
               %finish
            %finish
         %repeat
         %result=0
T(13):   %result=1;! EOF
T(22):   !  !
         %if Com_Allowvax=YES %thenstart;! rest of line is comment
            %cycle I=0,1,Cont
               %if Cstart(I)>=Bptr %thenstart
                  Bptr=Cstart(I)
                  ->Nxtchar
               %finish
            %repeat
            ->EOL
         %finish
T(24):   %if Com_Allowunix=YES %thenstart
            Quote='"'
            ->Char
         %finish
T(14):   Er=106;! invalid character
         %if Target=Gould %thenstart
            %if I='$' %or I='_' %thenstart
               J=2
               ->Setype
            %finish
         %finish
         %if I='$' %then J=11 %and ->Setype
T14A:    CHMARK(Com_Inp)=CHPTR
         ->Faulty
T(23):   !  tab
         %if Com_Allowvax=YES %then ->Nxtchar
T(16):                 ! DEL
T(15):   Er=107;! invalid (non-graphic) character
         ->T14A
T(17):   Er=106;! lower-case char
         I=I-32;! lower case to upper case
         J=CLASS(I)
         ->LCTOUC
T(21):   !  cr
         ->Nxtchar
%end;! Readline
!*
%externalroutine First Stat
!* check for invalid first statement
%constinteger TAB=9
%constinteger CRET=13
%integer I,J
      I=Tbuff(1)
      J=Tbuff(6)
      %unless I='C' %or I='*' %or I= 25 %or J='0' %or J=' ' %thenstart
         %unless I='c' %or I='D' %or I='d' %thenstart
            %cycle I=1,1,5
               J=Tbuff(I)
               %if J=TAB %or J=CRET %then %return
            %repeat
            Lfault(101);! First Statement has continuation marker
         %finish
      %finish
%end;! First Stat
!*
%externalintegerfn Next Label
%integer I,J,K,L
      K=0
      %cycle L = 1,1,5
         I = Tbuff(L)
         J = Class(I)
         %if J = X'83' %thenstart;! digit
            K = K*10+I&15
         %finishelsestart
            %unless I=' ' %then %result=0
         %finish 
      %repeat
      %result=K
%end;! Next Label
!*
%externalintegerfn Set Constant(%integer P1,
                                %integername Pi21length,Pi21mode,Ctyp,Er,
                                %record(Resf)%name Res,
                                %byteintegerarrayname Input,Type)
!*
!* result = 0  normal return
!*          1  report error
!*          2  switch syntax (not a complex constant)
!*
%routinespec Setname
%ownbyteintegerarray Tempbuff(0:1400)
%switch Sw(1:18)
%integer I,J,K,L,M,N,P,Pcomx,P2,P3,Complexlength,Quote
%ownstring(32) Identifier
      Complexlength=0
      Pcomx=0
      P2=0
      P3=0
      ->Sw(Type(Com_Inp))
!*
Sw(1):      ! must be a hex const
      %if P1=6 %then %result=2;! not a complex const
      I=Com_Inp+2
      K=I
Hloop1:J=Input(K)
      %if J=10 %then ->Bad Const
      %if Target=Gould %thenstart
         %if K>2000 %then ->Bad Const
      %finishelsestart
         %if K>1328 %then ->Bad Const
      %finish
      %if J='''' %thenstart
         %if I=K %or I+16<K %then ->Bad Const
         Com_Inp=K+1
         Com_Nextch=Input(Com_Inp)
         ->Set Hex
      %finish
      K=K+1
      ->Hloop1
!*
Set Hex:
      L=K-I;! no of hex chars
      M=0
      %while L>0 %cycle
         J = Input(I)
         I=I+1
         %if 'A'<=J<='F' %or 'a'<=J<='f' %thenstart
            J=J&15+9
         %finishelsestart
            %if '0'<=J<='9' %then J=J&15 %else ->Bad Const
         %finish
         M=(M<<4)!J
         L=L-1
         %if L&7=0 %thenstart
            N=4-L>>1
            %if BSCALE=1 %then N=N>>1
            integer(Com_Adict+Com_Dptr+N)=M
            M=0
         %finish
      %repeat
      Res_H0=Com_Dptr>>DSCALE; Res_Form=1; Res_Mode=HEXCONST
      %if Host=WWC %thenstart;! all bytes reversed
         I=integer(Com_Adict+Com_Dptr)
         integer(Com_Adict+Com_Dptr)=integer(Com_Adict+Com_Dptr+4)
         integer(Com_Adict+Com_Dptr+4)=I
      %finish
      Com_Dptr=Com_Dptr+W2;! reserving 8 bytes
      Ctyp = 6;                      ! hex constant
      Pi21length=8
      Pi21mode=HEXCONST
      %result=0
!*
Bad Const:
      Er=116
      %result=1
!*
!********   0 - 9
Sw(3):
      ER = 144;                          ! VARIABLE NOT FOUND WHEN EXPECTED
      %result=1 %if P1 = 1;        ! IDENTIFIER REQUIRED
!*
      Pi21length=0;! will remain 0 for integers
      I=Com_Inp+1
      %while TYPE(I)=3 %cycle;! digit
         I=I+1
      %repeat
      K=I-Com_Inp;! no. of digits before decimal point
      %if P1=3 %then ->PI21GET;! integer requested
      J=Input(I)
      %if J='.' %thenstart
         Pi21length=REAL LENGTH
         I=I+1
         %if TYPE(I)=3 %thenstart;! digit
PI21C:      I=I+1
            %while TYPE(I)=3 %cycle;! digit
               I=I+1
            %repeat
PI21D:      J=TYPE(I)
            %if J=1 %thenstart;! alphabetic
               J=Input(I)
               %if J='E' %thenstart
                  Pi21length=REAL LENGTH
PI21E:            I=I+1
                  J=Input(I)
                  %if J='+' %or J='-' %thenstart
                     I=I+1
PI21F:               %if TYPE(I)=3 %thenstart;! digit
                        I=I+1
                        %while TYPE(I)=3 %cycle;! digit
                           I=I+1
                        %repeat
                        ->PI21GET
                     %finishelsestart
                        Er=117;! invalid real constant
                        %result=1
                     %finish
                  %finishelse ->PI21F;! to check digits
               %finish
               %if J='D' %thenstart
                  Pi21length=DP LENGTH
                  ->PI21E
               %finish
               %if TARGET=IBM %thenstart
                  %if J='Q' %thenstart                  
                     LFAULT(119);! warn about use of Q  
                     Pi21length=16                      
                     ->PI21E                            
                  %finish                               
               %finish
            %finish
            ->PI21GET
         %finish
      %finish
      ->PI21D
!*
PI21GET:
!* PTR locates start of const
!* I-1 locates last char of const
!* Pi21length = 0  if integer
!*              4,8 or 16 if real
      %if PCOMX#0 %or P1=6 %thenstart;! complex
         %if Pi21length=0 %then Pi21length=REAL LENGTH
         %if Complexlength=0 %thenstart
            Complexlength=Pi21length
         %finishelse Pi21length=Complexlength
      %finish
      %if Pi21length=0 %thenstart;! integer
         %if P3#0 %thenstart;! there is a sign to be included
            Com_Inp=Com_Inp-1
            P3=0
         %finishelsestart
            %if K<5 %and INTEGER LENGTH=4 %and TYPE(I)#6 %thenstart
                                           ! no sign and small int - short circuit
               L=0
               %cycle J=Com_Inp,1,I-1
                  L=10*L+Input(J)&X'F'
               %repeat
               Com_Pi21int=L
               Com_Inp=I
               Pi21mode=1
               CTYP=X'51'
               RES_H0=Com_Pi21int; Res_Form=0; Res_Mode=1
               %result=0
            %finish
         %finish
         L=Com_Inp
         M=I
         J=In Number(Com_Adict+Com_Dptr,4,'I',0,0,0,L,M,Input,Tempbuff)
         %if J>0 %then Er=120 %and %result=1
         Com_Pi21int=integer(Com_Adict+Com_Dptr)
         Com_Inp=I
         %if TYPE(Com_Inp)=6 %thenstart;! Hollerith
            Pi21length=Com_Pi21int
            COPY(Pi21length,addr(Input(0)),Com_Inp+1,  %c
                               Com_Adict+Com_Dptr+CNSTRECMIN,0)
            Com_Inp=Com_Inp+Pi21length+1
            Pi21mode=HOLMODE;! Hollerith
            ->PI21HOLL
         %finish
         Pi21mode=1
         CTYP=X'51'
         Pi21length=4
         %if 0<=Com_Pi21int<=X'7FFF' %thenstart
            Res_H0=Com_Pi21int; Res_Form=0; Res_Mode=1
            %result=0
         %finishelsestart
            Res_H0=Com_Dptr>>DSCALE; Res_Form=1; Res_Mode=1
            Com_Dptr=Com_Dptr+W2
         %finish
         %result=0
      %finishelsestart;! real
         %if P1=6 %and P2=0 %thenstart;! real part of complex const?
            %unless Input(I)=',' %then %result=2;! switch
         %finish
         %if P3#0 %thenstart;! there is a sign to be included
            Com_Inp=Com_Inp-1
            P3=0
         %finish
         L=Com_Inp
         M=I
         %if Pi21length=8 %and Com_Dptr&4#0 %then Com_Dptr=Com_Dptr+4  {dw align}
         J=In Number(Com_Adict+Com_Dptr,Pi21length,'R',0,0,0,
                                                       L,M,Input,Tempbuff)
         %if J>0 %then Er=120 %and %result=1;! const out of range
         %if J<0 %then FAULT(174);! comment - too great precision
         Com_Inp=I
!*
         %if Pi21length=4 %then I=3 %elsestart
            %if Pi21length=8 %then I=4 %else I=5
         %finish
         %if (PCOMX=1 %or P1=6) %thenstart;! complex no.
            %if P2=0 %thenstart;! real part
               %unless Input(Com_Inp)=',' %thenstart
                  %if P1=6 %then %result=2;! switch
                  Er=118
                  %result=1
               %finish
               Com_Inp=Com_Inp+1
               I=Input(Com_Inp)
               %if I='+' %or I='-' %thenstart
                  Com_Inp=Com_Inp+1
                  I=Input(Com_Inp)
                  P3=1;! to ensure sign is included later
               %finishelse P3=0
               %if HOST=PERQPNX %or HOST=ACCENT %thenstart
                  Com_Dptr=Com_Dptr+Pi21length>>1
               %finishelsestart
                  Com_Dptr=Com_Dptr+Pi21length
               %finish
               P2=1
               K=0; L=0; M=0; N=0; P=0
               Com_Nextch=I
               ->Sw(Type(Com_Inp))
            %finishelsestart;! imaginary part
               %unless Input(Com_Inp)=')' %then Er=118 %and %result=1
               Com_Inp=Com_Inp+1
               I=I+3;! complex modes
               %if HOST=PERQPNX %or HOST=ACCENT %thenstart
                  Com_Dptr=Com_Dptr-Pi21length>>1
               %finishelsestart
                  Com_Dptr=Com_Dptr-Pi21length;! now points at start of real part
               %finish
               Pi21length=Pi21length<<1
            %finish
         %finish
         Pi21mode=I
         CTYP=MODETOST(I)
         RES_H0=Com_Dptr>>DSCALE; Res_Form=1; Res_Mode=I
         Com_Dptr=Com_Dptr+Pi21length
      %finish
      %result=0
!******  NON-ALPHANUMERICS
Sw(4):
Sw(7):
Sw(8):
Sw(9):
Sw(10):
Sw(11):
Sw(13):
Sw(14):
Sw(15):
Sw(16):
Sw(17):
Sw(18):
      K=0;  L=0; M=0; N=0; P=0
      %if Com_Nextch = '.' %thenstart
         ER = 117;                      ! INVALID REAL NO.
         %result=1 %if P1 = 1 %or P1 = 3;! IDEN OR INTEGER EXPECTED
         I=TYPE(Com_Inp+1)
         %if I # 1 %thenstart;  ! NOT A LETTER
            %if I # 3 %thenstart
               %result=1
            %finish
            Pi21length=REAL LENGTH;! to indicate the .
            I=Com_Inp+1
            ->PI21C
         %finishelsestart;              ! A LETTER
            %result=2 %if P1 = 6;       ! NOT A COMPLEX CONSTANT - switch
            Com_Inp=Com_Inp+1
            Setname
            ER = 116;                   ! ILLEGAL CONST
            %if Identifier = "TRUE" %thenstart
               Com_Pi21int = 1
            %finishelsestart
               %if Identifier = "FALSE" %thenstart
                  Com_Pi21int = 0
               %finishelse %result=1
            %finish
            %result=1 %unless Input(Com_Inp) = '.'
PI21LOG:    Com_Inp = Com_Inp+1
            Ctyp = X'54';                   ! LOGICAL CONST
            Pi21mode=LOG4
            Res_H0=Com_Pi21int; Res_Form=0; Res_Mode=LOG4
            Pi21length=4
            %result=0
         %finish
      %finish
      %result=2 %if P1 = 6 %and Com_Nextch = '\';! MAY BE A VALID LOGICAL EXPRESSION
      ER = 106;                         ! INVALID CHAR
      %result=1 %unless 5 <= P1 <= 6;    ! FOLLOWING ONLY VALID IF A CONSTANT EXPECTED
      %if Com_Nextch = '(' %thenstart;      ! MAY BE COMPLEX
         %result=2 %if P1 = 6
         PCOMX = 1
      %finishelsestart
         %result=1 %unless P3 = 0;       ! SIGN ALREADY SET
         %if Com_Nextch='+' %or Com_Nextch='-' %thenstart
            P3=1;! indicates presence of a sign
         %finishelse %result=1
      %finish
      Com_Inp = Com_Inp+1
      Com_Nextch = Input(Com_Inp)
      -> Sw(Type(Com_Inp))
!******  CHARACTER
Sw(5):
      Pi21length = 0
      Quote=Com_Nextch
      M=Com_Inp+1;! note start in case it turns out to be hex
      %cycle
         Com_Inp = Com_Inp+1
         I = Input(Com_Inp)
         %if I = Quote %thenstart
            Com_Inp = Com_Inp+1
            I = Input(Com_Inp)
            %if I # Quote %then %exit;     ! END OF CHARACTER CONSTANT
         %finish
         %if I='\' %and Com_Allowunix=YES %thenstart
            Com_Inp=Com_Inp+1
            I=Input(Com_Inp)
         %finish
         Putbyte(I,Com_Adict+Com_Dptr,Pi21length+4)
         Pi21length = Pi21length+1
      %repeat
      %if I='X' %thenstart;! VAX type hex const
         I=M;! first actual
         K=Com_Inp-1;! trailing '
         Com_Inp=Com_Inp+1
         Com_Nextch=Input(Com_Inp)
         ->Set Hex
      %finish
      Pi21mode=CHARMODE;! to distinguish from Hollerith
PI21HOLL:
      %if P1=6 %then %result=2
      ER = 116;                         ! INVALID CONST
      %result=1 %unless P1 = 0 %or 4 <= P1 <= 5;   ! ONLY VALID IF CONST REQUESTED
      CTYP = 5;                         ! CHARACTER CONST
      %result=1 %unless 0 < Pi21length <=X'FFFF'
      %cycle J = 0,1,3
         Putbyte(' ',Com_Adict+Com_Dptr,Pi21length+4+J)
      %repeat
      integer(Com_Adict+Com_Dptr)=Pi21length
      Res_H0=Com_Dptr>>DSCALE
      RES_Form=1
      Res_Mode=Pi21mode
      %if Target=IBM %thenstart
         %if Com_CHARACTER CODE#0 %thenstart;! EBCDIC INTERNAL   
            ITOE(Com_Adict+Com_Dptr+CNSTRECMIN,Pi21length+4) 
         %finish                                             
      %finish
      Com_Dptr=Com_Dptr+(Pi21length+7)&X'FFC'
      %result=0
Sw(2):Er=100
      %result=1
Sw(12):
      Er=104
      %result=1
!*
%routine Setname
!***********************************************************************
!* EXTRACT IDEN FROM INPUT RECORD AND SET IN IDENTIFIER                *
!***********************************************************************
%integer I,J
%ownbyteintegerarray A(0 : 32)
         I = 1
         %while 1 <= Type(Com_Inp) <= 3 %cycle;  ! A - Z,  0 - 9
            %if I <= 32 %thenstart
               J = Input(Com_Inp)
               A(I) = J
            %finishelsestart
               I=I-1
            %finish
            I = I+1
            Com_Inp = Com_Inp+1
         %repeat
         A(0) = I-1
         Identifier = string(addr(A(0)))
%end;! Setname
!*
%end;! Set Const
!*
%endoffile